module Control.Object (
Object(..),
liftO,
echo,
oneshot,
stateful,
variable,
(.>>.),
transObject,
adaptObject,
sequential,
loner,
(.|>.),
sharing
)
where
import Control.Monad.Trans.State.Strict
import Control.Monad
import Data.Typeable
import Control.Applicative
import Control.Monad.Free
import Data.OpenUnion1.Clean
newtype Object e m = Object { runObject :: forall x. e x -> m (x, Object e m) } deriving Typeable
liftO :: Functor f => (forall x. e x -> f x) -> Object e f
liftO f = Object $ fmap (\x -> (x, liftO f)) . f
transObject :: Functor g => (forall x. f x -> g x) -> Object e f -> Object e g
transObject f (Object m) = Object $ fmap (fmap (transObject f)) . f . m
adaptObject :: Functor m => (forall x. e x -> f x) -> Object f m -> Object e m
adaptObject f (Object m) = Object $ fmap (fmap (adaptObject f)) . m . f
echo :: Functor e => Object e e
echo = Object (fmap (\x -> (x, echo)))
(.>>.) :: Functor n => Object e m -> Object m n -> Object e n
Object m .>>. Object n = Object $ \e -> fmap (\((x, m'), n') -> (x, m' .>>. n')) $ n (m e)
infixr 4 .>>.
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 :: Monad m => (forall a. e a -> StateT s m a) -> s -> Object e m
stateful h = go where
go s = Object $ liftM (\(a, s') -> (a, go s')) . flip runStateT s . h
sequential :: Monad m => Object e m -> Object (Free e) m
sequential obj = Object $ \x -> case x of
Pure a -> return (a, sequential obj)
Free f -> do
(a, obj') <- runObject obj f
runObject (sequential obj') a
variable :: Applicative f => s -> Object (State s) f
variable s = Object $ \m -> let (a, s') = runState m s in pure (a, variable s')
sharing :: Monad m => (forall a. e a -> StateT s m a) -> s -> Object (State s |> e |> Nil) m
sharing m = go where
go s = Object $ \k -> liftM (fmap go) $ ($k)
$ (\n -> return $ runState n s)
||> (\e -> runStateT (m e) s)
||> exhaust
loner :: Functor m => Object Nil m
loner = liftO exhaust
(.|>.) :: Functor m => Object f m -> Object (Union s) m -> Object (f |> Union s) m
p .|>. q = Object $ fmap (fmap (.|>.q)) . runObject p ||> fmap (fmap (p .|>.)) . runObject q
infixr 3 .|>.