module Attr where

import Data.IORef
import Data.STRef
import Control.Monad.ST
import Control.Monad.Reader
import Control.Monad.State hiding (get)
import Control.Monad.RWS hiding (get)

class Readable v m | v -> m where
   get :: v a -> m a

class Writable v m | v -> m where
   (=:) :: v a -> a -> m ()
   
---------------------------------------
-- IORef
---------------------------------------

instance Readable IORef IO where
   get  = readIORef

instance Writable IORef IO where
   (=:) = writeIORef
   
---------------------------------------
-- STRef
---------------------------------------

instance Readable (STRef s) (ST s) where
   get  = readSTRef

instance Writable (STRef s) (ST s) where
   (=:) = writeSTRef
   
---------------------------------------
-- Reader monad
---------------------------------------

newtype ReaderAttr r a = ReaderAttr (r -> a)

instance Readable (ReaderAttr r) (Reader r) where
   get (ReaderAttr getter)  = Reader getter
   
---------------------------------------
-- ReaderT monad
---------------------------------------

data ReaderTAttr r m a = ReaderTAttr (r -> m a) (a -> r -> m ())

instance Readable (ReaderTAttr r m) (ReaderT r m) where
   get (ReaderTAttr getter setter)  = ReaderT getter
   
instance Writable (ReaderTAttr r m) (ReaderT r m) where
   (ReaderTAttr getter setter) =: v = ReaderT (setter v)
   

---------------------------------------
-- StateAttr
---------------------------------------

data StateAttr s a = StateAttr (s -> a) (a -> s -> s)

instance Readable (StateAttr s) (State s) where
   get (StateAttr getter setter)  = State (\s -> (getter s, s))
   
instance Writable (StateAttr s) (State s) where
   (StateAttr getter setter) =: v = State (\s -> ((), setter v s))
   
---------------------------------------
-- StateTAttr
---------------------------------------

data StateTAttr s m a = StateTAttr (s -> m a) (a -> s -> m s)

instance Monad m => Readable (StateTAttr s m) (StateT s m) where
   get (StateTAttr getter setter)  = StateT (\s -> getter   s >>= (\x -> return (x,  s)))
   
instance Monad m => Writable (StateTAttr s m) (StateT s m) where
   (StateTAttr getter setter) =: v = StateT (\s -> setter v s >>= (\s -> return ((), s)))

---------------------------------------
-- RWS monad
---------------------------------------

data RWSAttr r w s a = RWSAttr (r -> s -> (a,w)) (a -> r -> s -> (s,w))

instance Readable (RWSAttr r w s) (RWS r w s) where
   get (RWSAttr getter setter)  = RWS (\r s -> let (v,w)  = getter   r s in (v,  s,  w))
   
instance Writable (RWSAttr r w s) (RWS r w s) where
   (RWSAttr getter setter) =: v = RWS (\r s -> let (s',w) = setter v r s in ((), s', w))


---------------------------------------
-- RWST monad
---------------------------------------

data RWSTAttr r w s m a = RWSTAttr (r -> s -> m (a,w)) (a -> r -> s -> m (s,w))

instance Monad m => Readable (RWSTAttr r w s m) (RWST r w s m) where
   get (RWSTAttr getter setter)  = RWST (\r s -> do
   					(v,w) <- getter r s
   					return (v, s, w))
   
instance Monad m => Writable (RWSTAttr r w s m) (RWST r w s m) where
   (RWSTAttr getter setter) =: v = RWST (\r s -> do
   					(s',w) <- setter v r s
   					return ((), s', w))


-------------------------------------
-- GIO Attributes
-------------------------------------

type Attr w a = ReaderTAttr w IO a
type Prop w   = ReaderT w IO ()

getp :: w -> Attr w a -> IO a
getp w attr = runReaderT (get attr) w

setp :: w -> [Prop w] -> IO ()
setp w props = runReaderT (sequence_ props) w

-------------------------------------
-- HOpenGL
-------------------------------------

newtype GettableStateVariable a = GettableStateVariable (IO a)

instance Readable GettableStateVariable IO where
   get (GettableStateVariable g) = g



newtype SettableStateVariable a = SettableStateVariable (a -> IO ())

instance Writable SettableStateVariable IO where
   (=:) (SettableStateVariable s) a = s a



data StateVariable a = StateVariable (IO a) (a -> IO ())

instance Readable StateVariable IO where
   get (StateVariable g _) = g

instance Writable StateVariable IO where
   (=:) (StateVariable _ s) a = s a