module Control.ContStuff
(
Id(..),
IdT(..),
Cont, runCont, evalCont, modifyCont,
ContT(..), runContT, evalContT, modifyContT,
State, runState, evalState, execState,
StateT(..), runStateT, evalStateT, execStateT,
OldWriter, runOldWriter, evalOldWriter, execOldWriter,
OldWriterT, runOldWriterT, evalOldWriterT, execOldWriterT,
WriterT, runWriterT,
Abortable(..),
LiftBase(..), io,
Runnable(..),
Stateful(..), getField, modify, modifyField, modifyFieldLazy, modifyLazy,
Transformer(..),
Writable(..),
module Control.Applicative,
module Control.Monad
)
where
import Control.Applicative
import Control.Arrow
import Control.Monad
import Control.Monad.Fix
import Control.Monad.ST
import Data.Monoid
newtype Id a = Id { getId :: a }
instance Functor Id where
fmap f (Id x) = Id (f x)
instance Applicative Id where
pure = Id
Id f <*> Id x = Id (f x)
instance Monad Id where
return = Id
Id x >>= f = f x
instance MonadFix Id where
mfix f = fix (f . getId)
newtype ContT r m a =
ContT { getContT :: (a -> m r) -> m r }
instance Applicative m => Abortable (ContT r m) where
type Result (ContT r m) = r
abort = ContT . const . pure
instance Alternative m => Alternative (ContT r m) where
empty = ContT $ const empty
ContT c <|> ContT d =
ContT $ \k -> c (\x -> d (\y -> k x <|> k y))
instance Applicative (ContT r m) where
pure = return
ContT cf <*> ContT cx =
ContT $ \k -> cf (\f -> cx (\x -> k (f x)))
instance Functor (ContT r m) where
fmap f (ContT c) = ContT $ \k -> c (\x -> k (f x))
instance Monad (ContT r m) where
return x = ContT $ \k -> k x
ContT c >>= f =
ContT $ \k -> c (\x -> getContT (f x) k)
instance Runnable (ContT r) r m a where
type Argument (ContT r) r m a = a -> m r
runT k (ContT c) = c k
instance Transformer (ContT r) where
lift c = ContT $ \k -> c >>= k
instance Alternative m => Writable (ContT r m) r where
tell x = ContT $ \k -> pure x <|> k ()
instance (Functor m, Monoid w) => Writable (ContT (r, w) m) w where
tell x = ContT $ \k -> fmap (second (`mappend` x)) (k ())
runContT :: (a -> m r) -> ContT r m a -> m r
runContT k (ContT c) = c k
evalContT :: Applicative m => ContT r m r -> m r
evalContT (ContT c) = c pure
modifyContT :: Functor m => (r -> r) -> ContT r m ()
modifyContT f = ContT $ \k -> fmap f (k ())
type Cont r a = ContT r Id a
runCont :: (a -> r) -> Cont r a -> r
runCont k (ContT c) = getId $ c (Id . k)
evalCont :: Cont r r -> r
evalCont (ContT c) = getId $ c pure
modifyCont :: (r -> r) -> Cont r ()
modifyCont = modifyContT
newtype IdT m a = IdT { getIdT :: m a }
instance Alternative m => Alternative (IdT m) where
empty = IdT empty
IdT c <|> IdT d = IdT (c <|> d)
instance Applicative m => Applicative (IdT m) where
pure = IdT . pure
IdT cf <*> IdT cx = IdT $ cf <*> cx
instance Functor m => Functor (IdT m) where
fmap f (IdT c) = IdT (fmap f c)
instance Monad m => Monad (IdT m) where
return = IdT . return
IdT c >>= f = IdT $ c >>= getIdT . f
instance MonadFix m => MonadFix (IdT m) where
mfix f = IdT $ mfix (getIdT . f)
instance Runnable IdT r m r where
type Argument IdT r m r = ()
runT _ (IdT c) = c
instance Transformer IdT where
lift = IdT
type OldWriterT r w m a = ContT (r, w) m a
runOldWriterT :: (Applicative m, Monoid w) => OldWriterT r w m r -> m (r, w)
runOldWriterT (ContT c) = c (\x -> pure (x, mempty))
evalOldWriterT :: (Applicative m, Monoid w) => OldWriterT r w m r -> m r
evalOldWriterT = fmap fst . runOldWriterT
execOldWriterT :: (Applicative m, Monoid w) => OldWriterT r w m r -> m w
execOldWriterT = fmap snd . runOldWriterT
type OldWriter r w a = ContT (r, w) Id a
runOldWriter :: Monoid w => OldWriter r w r -> (r, w)
runOldWriter = getId . runOldWriterT
evalOldWriter :: Monoid w => OldWriter r w r -> r
evalOldWriter = fst . getId . runOldWriterT
execOldWriter :: Monoid w => OldWriter r w r -> w
execOldWriter = snd . getId . runOldWriterT
newtype StateT r s m a =
StateT { getStateT :: s -> (s -> a -> m r) -> m r }
instance Applicative m => Abortable (StateT r s m) where
type Result (StateT r s m) = r
abort x = StateT $ \_ _ -> pure x
instance Alternative m => Alternative (StateT r s m) where
empty = StateT . const . const $ empty
StateT c <|> StateT d =
StateT $ \s0 k -> c s0 k <|> d s0 k
instance Applicative (StateT r s m) where
pure = return
StateT cf <*> StateT cx =
StateT $ \s0 k -> cf s0 (\s1 f -> cx s1 (\s2 x -> k s2 (f x)))
instance Functor (StateT r s m) where
fmap f (StateT c) =
StateT $ \s0 k -> c s0 (\s1 -> k s1 . f)
instance Monad (StateT r s m) where
return x = StateT $ \s0 k -> k s0 x
StateT c >>= f =
StateT $ \s0 k -> c s0 (\s1 x -> getStateT (f x) s1 k)
instance Runnable (StateT r s) r m a where
type Argument (StateT r s) r m a = (s, s -> a -> m r)
runT (s0, k) (StateT c) = c s0 k
instance Stateful (StateT r s m) where
type StateOf (StateT r s m) = s
get = StateT $ \s0 k -> k s0 s0
put s1 = s1 `seq` StateT $ \_ k -> k s1 ()
putLazy s1 = StateT $ \_ k -> k s1 ()
instance Transformer (StateT r s) where
lift c = StateT $ \s0 k -> c >>= k s0
instance Alternative m => Writable (StateT r s m) r where
tell x = StateT $ \s0 k -> pure x <|> k s0 ()
instance (Functor m, Monoid w) => Writable (StateT (r, w) s m) w where
tell x = StateT $ \s0 k -> fmap (second (`mappend` x)) (k s0 ())
runStateT :: s -> (s -> a -> m r) -> StateT r s m a -> m r
runStateT s0 k (StateT c) = c s0 k
evalStateT :: Applicative m => s -> StateT r s m r -> m r
evalStateT s0 (StateT c) = c s0 (\_ x -> pure x)
execStateT :: Applicative m => s -> StateT s s m a -> m s
execStateT s0 (StateT c) = c s0 (\s1 _ -> pure s1)
type State r s a = StateT r s Id a
runState :: s -> (s -> a -> r) -> State r s a -> r
runState s0 k c = getId $ runStateT s0 (\s1 -> Id . k s1) c
evalState :: s -> State r s r -> r
evalState = (getId .) . evalStateT
execState :: s -> State s s a -> s
execState = (getId .) . execStateT
type WriterT = ContT
runWriterT :: Alternative m => WriterT r m a -> m r
runWriterT (ContT c) = c (const empty)
class Abortable m where
type Result m
abort :: Result m -> m a
class LiftBase m a where
type Base m a
base :: Base m a -> m a
instance LiftBase IO a where type Base IO a = IO a; base = id
instance LiftBase Id a where type Base Id a = Id a; base = id
instance LiftBase Maybe a where type Base Maybe a = Maybe a; base = id
instance LiftBase (ST s) a where type Base (ST s) a = ST s a; base = id
instance LiftBase [] a where type Base [] a = [a]; base = id
instance LiftBase ((->) r) a where type Base ((->) r) a = r -> a; base = id
instance (LiftBase m a, Monad m) => LiftBase (IdT m) a where
type Base (IdT m) a = Base m a; base = lift . base
instance (LiftBase m a, Monad m) => LiftBase (ContT r m) a where
type Base (ContT r m) a = Base m a; base = lift . base
instance (LiftBase m a, Monad m) => LiftBase (StateT r s m) a where
type Base (StateT r s m) a = Base m a; base = lift . base
io :: (LiftBase m a, Base m a ~ IO a) => Base m a -> m a
io = base
class Runnable t r m a where
type Argument t r m a
runT :: Argument t r m a -> t m a -> m r
class Stateful m where
type StateOf m
get :: m (StateOf m)
put :: StateOf m -> m ()
put x = x `seq` putLazy x
putLazy :: StateOf m -> m ()
getField :: (Functor m, Stateful m) => (StateOf m -> a) -> m a
getField = (<$> get)
modify :: (Monad m, Stateful m) => (StateOf m -> StateOf m) -> m ()
modify f = liftM f get >>= put
modifyField :: (Monad m, Stateful m) =>
(StateOf m -> a) -> (a -> StateOf m) -> m ()
modifyField accessor f = liftM (f . accessor) get >>= put
modifyFieldLazy :: (Monad m, Stateful m) =>
(StateOf m -> a) -> (a -> StateOf m) -> m ()
modifyFieldLazy accessor f = liftM (f . accessor) get >>= putLazy
modifyLazy :: (Monad m, Stateful m) => (StateOf m -> StateOf m) -> m ()
modifyLazy f = liftM f get >>= putLazy
class Transformer t where
lift :: Monad m => m a -> t m a
class Writable m w where
tell :: w -> m ()