module Control.Object where
import Control.Comonad.Zero
import Control.Comonad
import Control.Monad.Trans.State
import Control.Monad
import Data.Typeable
newtype Object e m = Object { runObject :: forall x. e x -> m (x, Object e m) } deriving Typeable
transObject :: Monad n => (forall x. m x -> n x) -> Object e m -> Object e n
transObject f (Object m) = Object $ liftM (fmap (transObject f)) . f . m
adaptObject :: Monad m => (forall x. e x -> f x) -> Object f m -> Object e m
adaptObject f (Object m) = Object $ liftM (fmap (adaptObject f)) . m . f
echo :: Functor e => Object e e
echo = Object (fmap (\x -> (x, echo)))
(.>>.) :: Monad n => Object e m -> Object m n -> Object e n
Object m .>>. Object n = Object $ \e -> liftM (\((x, m'), n') -> (x, m' .>>. n')) $ n (m e)
oneshot :: (Functor e, Monad m) => (forall a. e (m a) -> m a) -> Object e m
oneshot m = go where
go = Object $ \e -> m (fmap return e) >>= \a -> return (a, go)
stateful :: (Functor e, Monad m) => (forall a. e (StateT s m a) -> StateT s m a) -> s -> Object (AccessT s e) m
stateful m = go where
go s = Object $ \k -> liftM (fmap go) $ case k of
LiftAccessT e -> runStateT (m (fmap return e)) s
Get cont -> return (cont s, s)
Put s' cont -> return (cont, s')
class Stateful s f where
get_ :: f s
put_ :: s -> f ()
data AccessT s f a = Get (s -> a) | Put s a | LiftAccessT (f a) deriving (Functor, Typeable)
instance Stateful s (AccessT s f) where
get_ = Get id
put_ s = Put s ()
variable :: Monad m => s -> Object (AccessT s Zero) m
variable s = Object $ \x -> case x of
Get cont -> return (cont s, variable s)
Put s' cont -> return (cont, variable s')
LiftAccessT e -> return (extract e, variable s)