packages feed

Monatron (empty) → 0.3

raw patch · 15 files changed

+1123/−0 lines, 15 filesdep +basesetup-changed

Dependencies added: base

Files

+ Control/Monatron/AutoInstances.hs view
@@ -0,0 +1,16 @@+{-# OPTIONS+  -XFlexibleInstances+  -XOverlappingInstances+#-}++module Control.Monatron.AutoInstances where++import Control.Monatron.MonadT++------------------------------------------------------------------+instance (Monad m, MonadT t) => Monad (t m) where+    return = treturn+    fail   = lift . fail+    (>>=)  = tbind++instance (Monad m, MonadT t) => Functor (t m) where fmap = liftM
+ Control/Monatron/AutoLift.hs view
@@ -0,0 +1,128 @@+{-# OPTIONS+  -XFlexibleInstances+  -XMultiParamTypeClasses+  -XFunctionalDependencies+  -XUndecidableInstances+  -XOverlappingInstances+#-}++--  -XOverlappingInstances++module Control.Monatron.AutoLift (+ StateM(..), get,put,+ WriterM (..), tell,+ ReaderM(..), ask,local,+ ExcM(..), throw,handle,+ ContM(..), callCC,+ ListM(..), mZero,mPlus,+ module Control.Monatron.Operations+) where++import Control.Monatron.Operations+import Control.Exception (SomeException)+++------------------------------------------------------------------+-- State+class Monad m => StateM z m | m -> z where+    stateModel :: AlgModel (StateOp z) m++instance Monad m => StateM z (StateT z m) where+    stateModel = modelStateT++instance (StateM z m, MonadT t) => StateM z (t m) where+    stateModel = liftAlgModel stateModel++get :: StateM z m => m z+get = getX stateModel++put :: StateM z m => z -> m ()+put = putX stateModel++------------------------------------------------------------------+-- Traces+class (Monoid z, Monad m) => WriterM z m | m -> z where+    writerModel :: AlgModel (WriterOp z) m++instance (Monoid z, Monad m) => WriterM z (WriterT z m) where+    writerModel = modelWriterT++instance (Monoid z, WriterM z m, MonadT t) => WriterM z (t m) where+    writerModel = liftAlgModel writerModel++tell :: (Monoid z, WriterM z m) => z -> m ()+tell z = traceX writerModel z++------------------------------------------------------------------+-- Environments+class Monad m => ReaderM z m | m -> z where+    readerModel :: Model (ReaderOp z) m++instance Monad m => ReaderM z (ReaderT z m) where+    readerModel = modelReaderT++instance (ReaderM z m, Functor m, FMonadT t) => ReaderM z (t m) where+    readerModel = liftModel readerModel++ask :: ReaderM z m => m z+ask = askX readerModel++local :: ReaderM z m => (z -> z) -> m a -> m a+local = localX readerModel++------------------------------------------------------------------+-- Throw and Handle+class Monad m => ExcM z m | m -> z where+    throwModel :: AlgModel (ThrowOp z) m+    handleModel :: Model (HandleOp z) m++instance Monad m => ExcM z (ExcT z m) where+    throwModel = modelThrowExcT+    handleModel = modelHandleExcT++instance ExcM SomeException IO where+    throwModel  = modelThrowIO+    handleModel = modelHandleIO++instance (ExcM z m, Functor m, FMonadT t) => ExcM z (t m) where+    throwModel = liftAlgModel throwModel+    handleModel = liftModel handleModel++throw :: ExcM z m => z -> m a+throw = throwX throwModel++handle :: ExcM z m => m a -> (z -> m a) -> m a+handle = handleX handleModel++------------------------------------------------------------------+-- callCC operation++class Monad m => ContM r m | m -> r where+    contModel :: AlgModel (ContOp r) m++instance Monad m => ContM (m r) (ContT r m) where+    contModel = modelContT++instance (ContM r m, MonadT t) => ContM r (t m) where+    contModel = liftAlgModel contModel++callCC :: ContM r m => ((a -> r) -> a) -> m a+callCC = callCCX contModel++------------------------------------------------------------------+-- MPlus operations++class Monad m => ListM m where+    listModel :: AlgModel ListOp m++instance Monad m => ListM (ListT m) where+    listModel = modelListT++instance (ListM m, MonadT t) => ListM (t m) where+    listModel = liftAlgModel listModel++mZero :: (ListM m) => m a+mZero = zeroListX listModel++mPlus :: ListM m => m a -> m a -> m a+mPlus = plusListX listModel
+ Control/Monatron/Codensity.hs view
@@ -0,0 +1,36 @@+{-# OPTIONS -XRank2Types #-}++module Control.Monatron.Codensity (+ Codensity,+ codensity,+ runCodensity+) where++import Control.Monatron.MonadT+import Control.Monad.Fix+import Control.Monatron.AutoInstances()++----------------------------------------------------------+-- Codensity Monad+----------------------------------------------------------++newtype Codensity f a = Codensity { +      unCodensity :: forall b. (a -> f b) -> f b +}++codensity :: (forall b. (a -> f b) -> f b) -> Codensity f a+codensity = Codensity++runCodensity :: Monad m => Codensity m a -> m a+runCodensity c = unCodensity c return ++instance MonadT Codensity where+    lift m        = Codensity (m >>=)+    c `tbind` f   = Codensity (\k -> unCodensity c (\a -> unCodensity (f a) k))++-- still need to prove that MonadFix laws hold+instance MonadFix m => MonadFix (Codensity m) where+    mfix f = Codensity $ \k -> mfix (runCodensity. f) >>= k++------------------------+
+ Control/Monatron/IdT.hs view
@@ -0,0 +1,13 @@+module Control.Monatron.IdT  where ++import Control.Monatron.Monatron++newtype IdT m a = IdT { runIdT :: m a }++instance MonadT IdT where+    lift         = IdT+    tbind m f    = IdT $ runIdT m >>= runIdT . f +    +instance FMonadT IdT where+    tmap' d1 d2 g f       = IdT . f . fmapD d1 g . runIdT+
+ Control/Monatron/Monad.hs view
@@ -0,0 +1,67 @@++module Control.Monatron.Monad (+  State, Writer, Reader, Exception, Cont,+  state,writer,reader,exception,cont,+  runState, runWriter, runReader, runException, runCont,+  Id(..), Lift(..)+) where+  ++import Control.Monatron.Transformer+import Control.Monad+import Control.Monad.Fix++newtype Id a   = Id {runId :: a}+data    Lift a = L  {runLift :: a}++type State s      = StateT s Id+type Writer w     = WriterT w Id+type Reader r     = ReaderT r Id+type Exception x  = ExcT x Id+type Cont r       = ContT r Id++state :: (s -> (a, s)) -> State s a+state st = stateT $ \s -> Id $ st s++runState :: s -> State s a -> (a,s)+runState s = runId. runStateT s++writer :: Monoid w => (a,w) -> Writer w a+writer = writerT . Id++runWriter :: Monoid w => Writer w a -> (a,w)+runWriter = runId. runWriterT++reader :: (r -> a) -> Reader r a+reader e = readerT $ \r -> Id (e r)++runReader :: r -> Reader r a -> a+runReader r = runId . runReaderT r++exception :: Either x a -> Exception x a+exception = excT . Id++runException :: Exception x a -> Either x a+runException = runId. runExcT++cont :: ((a -> r) -> r) -> Cont r a+cont c = contT $ \k -> Id $ c (runId . k)++runCont :: (a -> r) -> Cont r a  -> r+runCont k = runId. runContT (Id. k)++instance Monad Id where+    return  = Id+    fail    = error+    m >>= f = f (runId m)++instance Monad Lift where+  return x  = L x+  fail x    = error x+  L x >>= k = k x++instance Functor Id   where fmap = liftM+instance Functor Lift where fmap = liftM++instance MonadFix Id   where mfix f = let m = f (runId m)   in m+instance MonadFix Lift where mfix f = let m = f (runLift m) in m
+ Control/Monatron/MonadT.hs view
@@ -0,0 +1,47 @@+{-# OPTIONS -XRank2Types #-}++module Control.Monatron.MonadT (+  MonadT(..), FMonadT(..), MMonadT(..), FComp(..), FunctorD(..), tmap, mtmap,+  module Control.Monad+) where++import Control.Monad+++----------------------------------------------------------+-- Class of monad transformers with +-- a lifting of first-order operations+----------------------------------------------------------++class MonadT t where+    lift    :: Monad m  => m a -> t m a+    treturn :: Monad m => a -> t m a+    treturn =  lift. return+    tbind   :: Monad m => t m a -> (a -> t m b) -> t m b++newtype FunctorD f = FunctorD {fmapD :: forall a b . (a -> b) -> f a -> f b}++functor :: Functor f => FunctorD f+functor = FunctorD fmap++class MonadT t => FMonadT t where+    tmap' :: FunctorD m -> FunctorD n -> (a -> b) -> (forall x. m x -> n x) -> t m a -> t n b+    +tmap :: (FMonadT t, Functor m, Functor n) => (forall b. m b -> n b) -> t m a -> t n a+tmap = tmap' functor functor id++mtmap :: FMonadT t => FunctorD f -> (a -> b) -> t f a -> t f b+mtmap fd f = tmap' fd fd f id++class FMonadT t => MMonadT t where+    flift      :: Functor f => f a -> t f a --should coincide with lift!+    monoidalT  :: (Functor f, Functor g) => t f (t g a) -> t (FComp f g) a ++----------------------------------------+-- Functor Composition+----------------------------------------+      +newtype (FComp f g) a = Comp {deComp :: (f (g a)) }++instance (Functor f, Functor g) => Functor (FComp f g) where+    fmap f (Comp fga) = Comp (fmap (fmap f) fga)
+ Control/Monatron/Monatron.hs view
@@ -0,0 +1,12 @@++module Control.Monatron.Monatron (+   module Control.Monatron.Monad,+   module Control.Monatron.AutoLift,+   version+)where++import Control.Monatron.Monad+import Control.Monatron.AutoLift++version :: (Int,Int,Int)+version = (0,0,1)
+ Control/Monatron/Open.hs view
@@ -0,0 +1,52 @@+{-# OPTIONS -fglasgow-exts -XNoMonomorphismRestriction -XOverlappingInstances #-}++module Control.Monatron.Open where++import Control.Monatron.Monatron+import Control.Monatron.AutoLift++infixr 9 :+:+infixr 9 <@>++data (:+:) f g a = Inl (f a) | Inr (g a)++newtype Fix f = In {out :: f (Fix f)}++type Open e f r = (e -> r) -> (f e -> r)++(<@>) :: Open e f r -> Open e g r -> Open e (f :+: g) r+evalf <@> evalg = \eval e -> +  case e of+    Inl el  -> evalf eval el+    Inr er  -> evalg eval er       +    +fix :: Open (Fix f) f r -> (Fix f -> r)+fix f =  let this = f this . out +         in this+            +-- Borrowed from Data types \`a la Carte++class (f :<: g) where+  inj :: f a -> g a+ +instance Functor f => (:<:) f f where+  inj = id+ +instance  (Functor g, Functor f) +          => (:<:) f (f :+: g) where+  inj = Inl+ +instance  (Functor g, Functor h, Functor f, f :<: g) +          => (:<:) f (h :+: g) where +  inj = Inr . inj++inject :: (f :<: g) => f (Fix g) -> Fix g+inject = In . inj++instance (Functor f, Functor g) => + Functor (f :+: g) where+  fmap f (Inl x)  = Inl (fmap f x)+  fmap f (Inr y)  = Inr (fmap f y)+  +foldFix :: Functor f => (f a -> a) ->  Fix f -> a+foldFix f = f . fmap (foldFix f) . out
+ Control/Monatron/Operations.hs view
@@ -0,0 +1,195 @@+{-# OPTIONS -XRank2Types #-}++module Control.Monatron.Operations (+    ExtModel, Model, AlgModel, toAlg, liftModel, liftAlgModel, liftExtModel,                         +    StateOp(..), modelStateT, getX, putX,+    ReaderOp(..), modelReaderT, askX, inEnvX,  localX,     +    WriterOp(..), modelWriterT, traceX,+    ThrowOp(..),HandleOp(..), modelThrowExcT, modelHandleExcT,+    modelThrowIO, modelHandleIO, throwX, handleX,+    ContOp(..), modelContT, callccX, callCCX, abortX,+    StepOp(..), stepX, modelStepT,+    ListOp(..), modelListT, zeroListX, plusListX,+    module Control.Monatron.Transformer+) where++import Control.Monatron.Codensity+import Control.Monatron.Transformer+import qualified Control.Exception as IO (throwIO,catch,SomeException)++-------------------------------------------------+-- Models and Standard Liftings+-------------------------------------------------+      +type ExtModel f g m  = forall a. f (m (g a)) -> m a+type Model f m       = forall a. f (m a) -> m a+type AlgModel f m    = forall a. f a -> m a++toAlg       :: (Functor f, Monad m) => Model f m -> AlgModel f (Codensity m)+toAlg op t  = codensity $ \k ->  op (fmap k t)++liftModel     :: (Functor f, Monad m, Functor m, FMonadT t, Monad (t (Codensity m))) => +                 Model f m -> Model f (t m)+liftModel op  = tmap runCodensity . join . lift . toAlg op . fmap (tmap lift)++liftAlgModel     :: (MonadT t, Monad m, Functor f) => AlgModel f m -> AlgModel f (t m)+liftAlgModel op  = lift . op++liftExtModel     ::  (  Functor f, Functor g, Monad m, Functor m, +                        MMonadT t, Functor (t f), Functor (t m)) => +                     ExtModel f g m -> ExtModel f g (t m)+liftExtModel op  =    tmap (op . fmap deComp . deComp) . +                      monoidalT . flift . fmap  (monoidalT . fmap flift) +      +----------------------+-- State Operations+----------------------+      +data StateOp s a = Get (s -> a) | Put s a++instance Functor (StateOp s) where+    fmap f (Get g)    = Get (f . g)+    fmap f (Put s a)  = Put s (f a)++modelStateT            :: Monad m => AlgModel (StateOp s) (StateT s m)+modelStateT (Get g)    = stateT (\s -> return (g s, s))+modelStateT (Put s a)  = stateT (\_ -> return (a, s))++getX     :: Monad m => AlgModel (StateOp s) m -> m s+getX op  = op $ Get id++putX       :: Monad m => AlgModel (StateOp s) m -> s -> m ()+putX op s  = op $ Put s ()+      +----------------------+-- Reader Operations+----------------------+      +data ReaderOp s a = Ask (s -> a) | InEnv s a++instance Functor (ReaderOp s) where+    fmap f (Ask g)      = Ask (f . g)+    fmap f (InEnv s a)  = InEnv s (f a)++modelReaderT              :: Monad m => Model (ReaderOp s) (ReaderT s m)+modelReaderT (Ask g)      = readerT (\s -> runReaderT s (g s))+modelReaderT (InEnv s a)  = readerT (\_ -> runReaderT s a)++askX     :: Monad m => Model (ReaderOp s) m -> m s+askX op  = op $ Ask return++inEnvX         :: Monad m => Model (ReaderOp s) m -> s -> m a -> m a+inEnvX op s m  = op $ InEnv s m +      +--derived++localX :: Monad m => Model (ReaderOp z) m -> (z -> z) -> m a -> m a+localX m f t = do z <- askX m+                  inEnvX m (f z) t++------------------------+-- Exception Operations+------------------------+      +data ThrowOp x a   = Throw x+data HandleOp x a  = Handle a (x -> a)++instance Functor (ThrowOp x) where+    fmap _ (Throw x) = Throw x++instance Functor (HandleOp x) where+    fmap f (Handle a h) = Handle (f a) (f . h)++modelThrowExcT            :: Monad m => AlgModel (ThrowOp x) (ExcT x m)+modelThrowExcT (Throw x)  = excT (return (Left x))++modelHandleExcT               :: Monad m => Model (HandleOp x) (ExcT x m)+modelHandleExcT (Handle m h)  = excT (runExcT m >>= \exa -> case  exa of+                                                Left x  -> runExcT (h x)+                                                Right a -> return (Right a))++modelThrowIO              :: AlgModel (ThrowOp IO.SomeException) IO+modelThrowIO (Throw x)    = IO.throwIO x++modelHandleIO               :: Model (HandleOp IO.SomeException) IO+modelHandleIO (Handle m h)  = IO.catch m h++throwX       :: Monad m => AlgModel (ThrowOp x) m -> x -> m a+throwX op x  = op $ Throw x++handleX         :: Monad m => Model(HandleOp x) m -> m a -> (x -> m a) -> m a+handleX op m h  = op $ Handle m h+      +------------------------+-- Writer Operations+------------------------+      +data WriterOp w a = Trace w a++instance Functor (WriterOp w) where+    fmap f (Trace w a) = Trace w (f a)++modelWriterT :: (Monad m, Monoid w) => AlgModel (WriterOp w) (WriterT w m)+modelWriterT (Trace w a)  = writerT (return (a,w))++traceX       :: (Monad m) => AlgModel (WriterOp w) m -> w -> m ()+traceX op w  = op $ Trace w ()+      +--------------------------+-- Continuation Operations+--------------------------+      +data ContOp r a = Abort r | CallCC ((a -> r) -> a)++instance Functor (ContOp r) where+    fmap _ (Abort r)      = Abort r+    fmap f (CallCC k)     = CallCC (\c -> f (k (c . f)))++modelContT             :: Monad m => AlgModel (ContOp (m r)) (ContT r m)+modelContT (Abort mr)  = contT $ \_ -> mr+modelContT (CallCC k)  = contT $ \c -> c (k c)++abortX       :: Monad m => AlgModel (ContOp r) m -> r -> m a+abortX op r  = op (Abort r)++callCCX       :: Monad m => AlgModel (ContOp r) m -> ((a -> r) -> a) -> m a+callCCX op f  = op (CallCC f)++callccX       :: Monad m => AlgModel (ContOp r) m -> ((a -> m b) -> m a) -> m a+callccX op f  =  join $ callCCX op (\k -> f (\x -> abortX op (k (return x))))  +      +--------------------------+-- Step Operations+--------------------------+      +newtype StepOp f x = StepOp (f x)++instance (Functor f) => Functor (StepOp f) where +    fmap h (StepOp fa) = StepOp (fmap h fa)++modelStepT              :: (Functor f, Monad m) => Model (StepOp f) (StepT f m)+modelStepT (StepOp fa)  = stepT (return (Right fa))++stepX     :: (Monad m) => Model (StepOp f) m -> f (m x) -> m x+stepX op  = op . StepOp +  +--------------------------+-- List Operations+--------------------------+      +data ListOp a = ZeroList | PlusList a a++instance Functor ListOp where+    fmap _ ZeroList        = ZeroList+    fmap f (PlusList a b)  = PlusList (f a) (f b)++modelListT               :: Monad m => AlgModel ListOp (ListT m)+modelListT ZeroList        = emptyL+modelListT (PlusList t u)  = appendL (return t) (return u)++zeroListX         :: Monad m => AlgModel ListOp m -> m a+zeroListX op      = op ZeroList++plusListX         :: Monad m => AlgModel ListOp m -> m a -> m a -> m a+plusListX op t u  = join $ op (PlusList t u)+
+ Control/Monatron/Transformer.hs view
@@ -0,0 +1,285 @@++module Control.Monatron.Transformer (+  StateT, stateT, runStateT,+  WriterT, writerT, runWriterT,+  ReaderT, readerT, runReaderT,+  ExcT, excT, runExcT,+  ContT, contT, runContT,+  StepT, stepT, runStepT, caseStepT, unfoldStepT,+  ListT, listT, runListT, foldListT, collectListT, emptyL, appendL,+--  module Monatron.Operations,+  module Control.Monatron.MonadT,+  module Data.Monoid+) where++--import Monatron.Operations+import Control.Monad.Fix+import Control.Monatron.MonadT+-- for Writer+import Data.Monoid+-- for Error (and Reader?)+--import Monatron.Codensity+import Control.Monatron.AutoInstances()++--State Monad Transformer+newtype StateT s m a = S { unS :: s -> m (a,s) }++stateT ::  (s -> m (a, s)) -> StateT s m a+stateT = S++runStateT :: s -> StateT s m a -> m (a,s) +runStateT s m = unS m s++instance MonadT (StateT s) where+    lift  m           = S $ \s -> m >>= \a -> return (a,s)+    m `tbind` k       = S $ \s -> unS m s >>= \ ~(a, s') -> unS (k a) s'++instance (MonadFix m) => MonadFix (StateT s m) where+  mfix f  = S $ \s -> mfix (runStateT s . f . fst)++instance FMonadT (StateT s) where+    tmap' d1 _d2 g f (S m) = S (f . fmapD d1 (\(x,s) -> (g x,s)) . m)++instance MMonadT (StateT s) where+    flift t          = S (\s -> fmap (\a -> (a,s)) t)+    monoidalT (S t)  = S (\s -> Comp $ fmap (\(S t',s') -> t' s') (t s))++{-+-- StateT implementation of operations+withStateT :: Monad m => Fop (With s) (StateT s m)+withStateT (With f)  = S $ \s  -> runStateT s (f s)++makeStateT :: Monad m => Fop (Make s) (StateT s m)+makeStateT (Make (m,s)) = S $ \_ -> runStateT s m+-}++--------------------------------------------------------------+-- Writer Monad Transformer++newtype WriterT w m a = W {unW :: m (a,w) } ++writerT :: (Monoid w, Monad m) => m (a,w) -> WriterT w m a+writerT = W++runWriterT :: (Monoid w) => WriterT w m a -> m (a,w)+runWriterT = unW+                 +instance Monoid w => MonadT (WriterT w) where  +    tbind (W m) f  = W (do  (a,w) <- m+                            (a',w') <- unW (f a)+                            return (a',w `mappend` w'))+    lift m         = W (liftM (\a -> (a,mempty)) m)++{-+instance (MonadFix m, Monoid w) => MonadFix (WriterT w m) where+    mfix f = W $ mfix (unW. f) +-}++instance Monoid w => FMonadT (WriterT w) where+    tmap' d1 _d2 g f  = W . f . fmapD d1 (\(x,s) -> (g x,s)) . unW++instance Monoid w => MMonadT (WriterT w) where+    flift t          = W (fmap (\a -> (a,mempty)) t)+    monoidalT (W t)  = W $ Comp $  fmap (\(W t',w) -> +                                   fmap (\(a,w') -> (a,w `mappend` w')) t') $ t++{-+-- WriterT implementation of operations+withWriterT :: (Monoid w, Monad m) => Fop (With w) (WriterT w m)+withWriterT (With c)   = W $ S $ \w -> runWriterT (c w)+++makeWriterT :: (Monoid w, Monad m) => Fop (Make w) (WriterT w m)+makeWriterT (Make (m, w)) = writerT $ runWriterT m >>= \(a,w') -> +                            return (a,w' `mappend` w)+-}+--------------------------------------------------------------+-- Reader Monad Transformer+newtype ReaderT s m a = R { unR :: s -> m a }++runReaderT      :: s -> ReaderT s m a -> m a+runReaderT s m  = unR m s++instance MonadT (ReaderT s) where+    tbind m k  = R (\s -> unR m s >>= \a -> unR (k a) s)+    lift  m    = R (\_ -> m)++readerT :: Monad m => (e -> m a) -> ReaderT e m a+readerT = R++{-+instance (MonadFix m) => MonadFix (ReaderT w m) where+    mfix f = R $ mfix (unR. f) +-}++instance FMonadT (ReaderT s) where+    tmap' d1 _d2 g f (R m) = R (f . fmapD d1 g . m)++instance MMonadT (ReaderT s) where+    flift t          = R (\_ -> t)+    monoidalT (R t)  = R (\s -> Comp $ fmap (($ s) . unR) (t s))++{-+-- ReaderT implementation of operations+makeReaderT :: Monad m => Fop (Make e) (ReaderT e m)+makeReaderT = R . makeStateT . fmap unR++withReaderT :: Monad m => Fop (With e) (ReaderT e m)+withReaderT = R . withStateT . fmap unR+-}+--------------------------------------------------------------+-- Exceptions Monad Transformer+newtype ExcT x m a = X {unX :: m (Either x a)}++excT :: Monad m => m (Either x a) -> ExcT x m a+excT = X++runExcT :: Monad m => ExcT x m a -> m (Either x a)+runExcT = unX+--+instance (MonadFix m) => MonadFix (ExcT x m) where+  mfix f  = X $ mfix (unX . f . fromRight)+    where fromRight (Right a) = a+          fromRight _         = error "ExceptionT: mfix looped."+++--+instance MonadT (ExcT x) where+    lift m           = X (liftM Right m)+    (X m) `tbind` f  = X (do a <- m+                             case a of+                                Left x  -> return (Left x)+                                Right b -> unX (f b))+++instance FMonadT (ExcT x) where+    tmap' d1 _d2 g f  = X . f . fmapD d1 func . unX where+      func (Left x)   = Left x+      func (Right y)  = Right (g y)++{-+-- internal operations+throwExcT :: Monad m => Fop (Throw x) (ExcT x m)+throwExcT (Throw x) = X $ return (Left x)+--+handleExcT :: Monad m => Fop (Handle x) (ExcT x m)+handleExcT (Handle (m, h)) = X (unX m >>= \exa ->+                                    case exa of+                                      Left x  -> unX (h x)+                                      Right a -> return (Right a))++-- Instances of the operations for IO exceptions+throwIO :: Fop (Throw IO.SomeException) IO+throwIO (Throw x) = IO.throwIO x+--+handleIO :: Fop (Handle IO.SomeException) IO+handleIO (Handle (m, h)) = IO.catch m h+-}++--------------------------------------------------------------+-- Continuations Monad Transformer++newtype ContT r m a = C {unC :: (a -> m r) -> m r}++runContT :: (a -> m r) -> ContT r m a -> m r+runContT = flip unC++contT ::  ((a -> m r) -> m r) -> ContT r m a+contT = C++instance MonadT (ContT r) where+    lift m = C (m >>=)+    m `tbind` k   = C $ \c -> unC m (\a -> unC (k a) c)++{-+callCCContT :: Monad m => Fop (CallCC (m r)) (ContT r m)+callCCContT (CallCC f) = C $ \k -> unC (f (\a -> unC a k)) k++abortContT :: Monad m => Fop (Abort (m r)) (ContT r m)+abortContT (Abort mr) = C $ \_ -> mr+-}+--------------------------------------------------------------+-- List monad transformer++data LSig f a b = NilT b+                | ConsT a (f a)++newtype ListT m a = L {unL :: m (LSig (ListT m) a ())}++runListT :: ListT m a -> m (LSig (ListT m) a ())+runListT = unL++listT :: m (LSig (ListT m) a ()) -> ListT m a+listT = L++emptyL :: Monad m => ListT m a+emptyL = L $ return $ NilT ()++appendL :: Monad m=> ListT m a -> ListT m a -> ListT m a+appendL (L m1) (L m2) = L $ do+            l <- m1+            case l of+              NilT ()    -> m2+              ConsT a l1 -> return (ConsT a (appendL l1 (L m2)))++foldListT :: Monad m => (a -> m b -> m b) -> m b -> ListT m a -> m b+foldListT c n (L m) = do l <- m +                         case l of +                            NilT ()    -> n +                            ConsT a l1 -> c a (foldListT c n l1)++collectListT :: Monad m => ListT m a -> m [a]+collectListT lt = foldListT (\a m -> m >>= return. (a:)) (return []) lt++instance MonadT ListT where+    lift m       = L $ liftM (`ConsT` emptyL) m+    m `tbind` f  = L $ foldListT (\a l -> unL $ f a `appendL` L l)+                                 (return $ NilT ())+                                 m++instance FMonadT ListT where+    tmap' d1 d2 g t (L m) = L $ t $ fmapD d1 (\lsig  -> case lsig of+                                            NilT ()    -> NilT ()+                                            ConsT a l  -> ConsT (g a) (tmap' d1 d2 g t l)) m++{-+mZeroListT :: Monad m => Fop MZero (ListT m)+mZeroListT (MZero _) = emptyL ++mPlusListT :: (Monad m) => Fop MPlus (ListT m)+mPlusListT (MPlus (a, b)) = appendL a b+-}+------------------------------------------------+-- Step Monad Transformer+------------------------------------------------+      +newtype StepT f m x = T {runT :: m (Either x (f (StepT f m x)))}++stepT :: m (Either x (f (StepT f m x))) -> StepT f m x+stepT = T++runStepT :: StepT f m x ->  m (Either x (f (StepT f m x)))+runStepT = runT++{-+instance (Functor f, Monad m) => Monad (StepT f m) where+    return  = treturn+    (>>=)   = tbind+-}++--instance (Functor f, Monad m) => Functor (StepT f m) where fmap = liftM++caseStepT            ::  (Functor f, Monad m) =>  +                         (a -> StepT f m x) -> (f (StepT f m a) -> StepT f m x)+                         -> StepT f m a -> StepT f m x+caseStepT v c (T m)  = T (m >>= either (runT . v) (runT . c))++unfoldStepT      :: (Functor f, Monad m) => (y -> m (Either x (f y))) -> y -> StepT f m x+unfoldStepT k y  = T (liftM (fmap (fmap (unfoldStepT k))) (k y))++instance (Functor f) => MonadT (StepT f) where+    tbind t f  = caseStepT f (T . return . Right . fmap (`tbind` f)) t+    lift       = T . liftM Left++instance (Functor f) => FMonadT (StepT f) where+    tmap' d1 d2 g t (T m) = T (t (fmapD d1 (either (Left . g) (Right . fmap (tmap' d1 d2 g t))) m))
+ Control/Monatron/Zipper.hs view
@@ -0,0 +1,118 @@+{-# OPTIONS -fglasgow-exts -XNoMonomorphismRestriction #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE RankNTypes #-}++module Control.Monatron.Zipper where++import Control.Monatron.MonadT ()+import Control.Monatron.IdT ()+import Control.Monatron.AutoLift +import Control.Monatron.Operations+import Control.Monatron.Monad ()+-- import Monatron.AutoInstances()++newtype (t1 :> (t2 :: (* -> *) -> * -> *)) m a = L { runL :: t1 (t2 m) a }++runZipper :: (t1 :> t2) m a -> t1 (t2 m) a+runZipper = runL++zipper :: t1 (t2 m) a -> (t1 :> t2) m a +zipper = L++-- * Relative Navigation++-- | shift focus to left+leftL  :: (t1 :> t2) m a -> t1 (t2 m) a+leftL   = runL++-- | shift focus to right+rightL :: t1 (t2 m) a -> (t1 :> t2) m  a+rightL  =  L ++-- The zipper is an FMonadT and a MonadT++instance (FMonadT t1, FMonadT t2) => FMonadT (t1 :> t2) where+     tmap' d1 d2 g f       = +       L . tmap' (FunctorD (mtmap d1)) (FunctorD (mtmap d2)) g (tmap' d1 d2 id f) . runL++instance (MonadT t1, MonadT t2) => MonadT (t1 :> t2) where+     lift         = L . lift . lift+     tbind m f    = L $ runL m >>= runL . f+     +-- Instances of the zipper for the various effects+     +instance (Monad m, MonadT t1, MonadT t2, StateM z (t2 m)) => StateM z ((t1 :> t2) m) where+     stateModel = L . liftAlgModel stateModel+     +instance (WriterM z (t2 m), MonadT t1, Monad m, MonadT t2) => WriterM z ((t1 :> t2) m) where+     writerModel  = L . liftAlgModel writerModel++instance (ReaderM z (t2 m), FMonadT t1, FMonadT t2, Functor (t2 m), Monad m) => +         ReaderM z ((t1 :> t2) m) where     +      readerModel  = L . liftModel readerModel . fmap runL +      +instance (ExcM z (t2 m), FMonadT t1, FMonadT t2, Functor (t2 m), Monad m) => +         ExcM z ((t1 :> t2) m) where+    throwModel  = L . liftAlgModel throwModel+    handleModel = L . liftModel handleModel . fmap runL +    +instance (ContM r (t2 m), FMonadT t1, FMonadT t2, Functor (t2 m), Monad m) => +         ContM r ((t1 :> t2) m) where+    contModel = L . liftAlgModel contModel+    +instance (ListM (t2 m), FMonadT t1, FMonadT t2, Functor (t2 m), Monad m) => +         ListM ((t1 :> t2) m) where+    listModel = L . liftAlgModel listModel+    +-- runtest :: (((),Int),Int)+-- runtest = runState 0 $ runStateT 0 $ runZipper (put 3)++-- Views and masks; could be in a different file+    +data (:><:) m n = View {+  to    :: forall a . m a -> n a,+  from  :: forall a . n a -> m a+}++i :: m :><: m+i = View id id++o :: (Monad m, MonadT t1, MonadT t2) => t1 (t2 m) :><: (t1 :> t2) m+o = View rightL leftL++vlift  :: (FMonadT t, Functor m, Functor n) +       => (m :><: n) -> (t m :><: t n)+vlift v  = View (tmap (to v)) (tmap (from v))+++hcomp :: (n :><: o) -> (m :><: n) -> (m :><: o)+v2 `hcomp` v1  =  View  (to v2 . to v1) (from v1 . from v2)++vcomp  :: (Functor m1, Functor m2, FMonadT t) +       => (t m2 :><: m3) -> (m1 :><: m2) -> (t m1 :><: m3)+v2 `vcomp` v1  = v2 `hcomp` (vlift v1)++-- program :: StateM Int m => m Int+-- program = put 3 >> return 4++-- t = runState 1 $ runStateT 0 $ runIdT $ runIdT $ view i program++r :: Monad m => StateT s m :><: ReaderT s m+r  = View  {+  to    = \s -> readerT (\e -> liftM fst $ runStateT e s),+  from  = \e -> stateT (\s ->  liftM (\x -> (x,s)) $ runReaderT s e)+}++stateIso  :: Monad m => (s1 -> s2) -> (s2 -> s1) -> StateT s1 m :><: StateT s2 m+stateIso f fm1 = View  {to = iso f fm1, from = iso fm1 f } where +  iso g h m = stateT $ \s2 -> do  (a, s1) <- runStateT (h s2) m+                                  return (a, g s1)+                                  +getv :: StateM s n => (m :><: n) -> m s+getv var  = from var get ++putv :: StateM s n => (m :><: n) -> s -> m ()+putv var  = from var . put
+ Control/Monatron/ZipperExamples.hs view
@@ -0,0 +1,83 @@+{-# OPTIONS -XTypeOperators -XFlexibleContexts #-}++module Control.Monatron.ZipperExamples where++import Control.Monatron.Monatron+import Control.Monatron.Zipper+import Control.Monatron.Open++-- Don't we need a bidirectional view to implement this combinator?++fmask :: (m :><: n) -> Open e f (n a) -> Open e f (m a)+fmask v evalf eval = from v . evalf (to v . eval)++type Env = [(String,Int)]++type Count = Int++data Mem e  = Store e | Retrieve++type Reg    = Int+ +evalMem2  :: (StateM Reg (t m), StateM Count m, MonadT t) +             => Open e Mem (t m Int)+evalMem2 eval (Store e) =+  do  count <- lift $ get+      lift $ put (count + 1)+      n <- eval e+      put n+      return n+evalMem2 eval Retrieve = lift $ get++type M4 =  StateT Reg (StateT Env (ExcT String (StateT Count Id)))++data Lit a = Lit Int+data Var a = Var String+data Add e = Add e e++instance Functor Lit where+  fmap _ (Lit l)      = Lit l++instance Functor Var where+  fmap _ (Var v)      = Var v++instance Functor Add where+  fmap f (Add e1 e2)  = Add (f e1) (f e2)+  +instance Functor Mem where+  fmap f (Store x)  = Store (f x)+  fmap f Retrieve   = Retrieve+  +lit :: (Lit :<: g)  => Int -> Fix g+lit l      = inject (Lit l)++var :: (Var :<: g)  => String -> Fix g +var v      = inject (Var v)++add :: (Add :<: g)  => Fix g -> Fix g -> Fix g+add e1 e2  = inject (Add e1 e2)++store :: (Mem :<: g) => Fix g -> Fix g+store e = inject (Store e)++retrieve :: (Mem :<: g) => Fix g+retrieve = inject Retrieve++type Expr3  = Fix (Mem :+: Var :+: Lit)++evalLit _ (Lit n) = return n ++evalVar _ (Var v) = do env <- get+                       case lookup v env of+                         Just n -> return n+                         Nothing -> throw "undefined variable"++eval4 :: Expr3 -> M4 Int+eval4 = fix  (    fmask (i `vcomp` o `vcomp` o) evalMem2+             <@>  fmask o evalVar  +             <@>  evalLit)+        +test = runId $ runStateT 0 $ handleExc $ runStateT [] $ runStateT 0 $ eval4 (store (lit 3))++handleExc :: Monad m => ExcT a m b -> m b+handleExc = liftM (either (error "Error!") id) . runExcT
+ LICENSE view
@@ -0,0 +1,31 @@+The Glasgow Haskell Compiler License++Copyright 2004, The University Court of the University of Glasgow.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.++- Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.++- Neither name of the University nor the names of its contributors may be+used to endorse or promote products derived from this software without+specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF+GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH+DAMAGE.
+ Monatron.cabal view
@@ -0,0 +1,34 @@+name:         Monatron+version:      0.3+license:      BSD3+license-file: LICENSE+author:       Mauro Jaskelioff+maintainer:   mauro@fceia.unr.edu.ar+category:     Control+synopsis:     Monad transformer library with uniform liftings+description:+	An extensible monad transformer library with uniform liftings, a +	fairly portable core, and option of explicit naming of liftings.+	See http:\/\/www.fceia.unr.edu.ar\/~mjj\/Monatron\/ for more information.++	The monad zipper allows modular composition of components with Monatron effects.+        It is a contribution of Bruno Oliveira and Tom Schrijvers.+        See http:\/\/www.cs.kuleuven.be\/~toms\/Haskell\/ for more information.+build-type: Simple+ghc-options: -Wall+exposed-modules:+	Control.Monatron.MonadT+	Control.Monatron.AutoInstances+	Control.Monatron.Operations+	Control.Monatron.Codensity+	Control.Monatron.Transformer+	Control.Monatron.Monad+	Control.Monatron.AutoLift+	Control.Monatron.Monatron+	Control.Monatron.IdT+	Control.Monatron.Zipper+	Control.Monatron.Open+	Control.Monatron.ZipperExamples+build-depends: base >= 2 && < 3+extensions: +	Rank2Types
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain