packages feed

monad-classes (empty) → 0.3

raw patch · 16 files changed

+973/−0 lines, 16 filesdep +basedep +conduitdep +data-lens-lightsetup-changed

Dependencies added: base, conduit, data-lens-light, ghc-prim, mmorph, monad-classes, monad-control, peano, reflection, tasty, tasty-hunit, transformers, transformers-base, transformers-compat

Files

+ Control/Monad/Classes.hs view
@@ -0,0 +1,52 @@+module Control.Monad.Classes+  ( -- * State+    MonadState+  , get+  , put+  , modify+  , modify'+  , gets+    -- * Reader+  , MonadReader+  , MonadLocal+  , ask+  , local+    -- * Writer+  , MonadWriter+  , tell+    -- * Exceptions+  , MonadExcept+  , throw+    -- * Exec+  , MonadExec+  , exec+    -- * Core classes and types+    -- ** Generic lifting+  , MonadLiftN(..)+    -- ** Effects+  , module Control.Monad.Classes.Effects+    -- ** N-classes+  , Peano(..)+  , MonadStateN(..)+  , MonadReaderN(..)+  , MonadLocalN(..)+  , MonadWriterN(..)+  , MonadExceptN(..)+  , MonadExecN(..)+    -- ** Type families+    -- | You should rarely need these. They are exported mostly for+    -- documentation and pedagogical purposes.+  , Find+  , FindTrue+  , MapCanDo+  , CanDo+  ) where++import Control.Monad.Classes.Effects+import Control.Monad.Classes.Core+import Control.Monad.Classes.State+import Control.Monad.Classes.Reader+import Control.Monad.Classes.Writer+import Control.Monad.Classes.Except+import Control.Monad.Classes.Exec+import Data.Peano (Peano (..))
+ Control/Monad/Classes/Core.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE UndecidableInstances #-}+module Control.Monad.Classes.Core where++import GHC.Prim (Proxy#, proxy#)+import Control.Monad.Trans.Class+import Data.Peano (Peano (..))++-- Peano naturals; used at the type level to denote how far a computation should be lifted+-- ... but GHC not promotes type synonyms+-- type Peano = Peano++-- | @'CanDo' m eff@ describes whether the given effect can be performed in the+-- monad @m@ (without any additional lifting)+type family CanDo (m :: (* -> *)) (eff :: k) :: Bool++-- | @'MapCanDo' eff stack@ maps the type-level function @(\m -> 'CanDo'+-- m eff)@ over all layers that a monad transformer stack @stack@ consists of+type family MapCanDo (eff :: k) (stack :: * -> *) :: [Bool] where+  MapCanDo eff (t m) = (CanDo (t m) eff) ': MapCanDo eff m+  MapCanDo eff m = '[ CanDo m eff ]++-- | @'FindTrue' bs@ returns a (type-level) index of the first occurrence+-- of 'True' in a list of booleans+type family FindTrue+  (bs :: [Bool]) -- results of calling Contains+  :: Peano+  where+  FindTrue (True ': t) = Zero+  FindTrue (False ': t) = Succ (FindTrue t)++-- | @'Find' eff m@ finds the first transformer in a monad transformer+-- stack that can handle the effect @eff@+type Find eff (m :: * -> *) =+  FindTrue (MapCanDo eff m)++class MonadLiftN (n :: Peano) m+  where+    type Down n m :: * -> *+    liftN :: Proxy# n -> Down n m a -> m a++instance MonadLiftN Zero m+  where+    type Down Zero m = m+    liftN _ = id++instance+  ( MonadLiftN n m+  , MonadTrans t+  , Monad m+  ) => MonadLiftN (Succ n) (t m)+  where+    type Down (Succ n) (t m) = Down n m+    liftN _ = lift . liftN (proxy# :: Proxy# n)
+ Control/Monad/Classes/Effects.hs view
@@ -0,0 +1,19 @@+module Control.Monad.Classes.Effects where++-- | Writer effect+data EffWriter (w :: *)++-- | Reader effect+data EffReader (e :: *)++-- | Local state change effect+data EffLocal (e :: *)++-- | State effect+data EffState (s :: *)++-- | Arbitrary monadic effect+data EffExec (w :: * -> *)++-- | Except effect+data EffExcept (e :: *)
+ Control/Monad/Classes/Except.hs view
@@ -0,0 +1,51 @@+module Control.Monad.Classes.Except where+import qualified Control.Monad.Trans.Except as Exc+import qualified Control.Monad.Trans.Maybe as Mb+import qualified Control.Exception as E+import Control.Monad+import Control.Monad.Trans.Class+import GHC.Prim (Proxy#, proxy#)+import Control.Monad.Classes.Core+import Control.Monad.Classes.Effects+import Data.Peano (Peano (..))++type instance CanDo IO (EffExcept e) = True++type instance CanDo (Exc.ExceptT e m) eff = ExceptCanDo e eff++type instance CanDo (Mb.MaybeT m) eff = ExceptCanDo () eff++type family ExceptCanDo e eff where+  ExceptCanDo e (EffExcept e) = True+  ExceptCanDo e eff = False++class Monad m => MonadExceptN (n :: Peano) e m where+  throwN :: Proxy# n -> (e -> m a)++instance Monad m => MonadExceptN Zero e (Exc.ExceptT e m) where+  throwN _ = Exc.throwE++instance E.Exception e => MonadExceptN Zero e IO where+  throwN _ = E.throwIO++instance Monad m => MonadExceptN Zero () (Mb.MaybeT m) where+  throwN _ _ = mzero++instance (MonadTrans t, Monad (t m), MonadExceptN n e m, Monad m)+  => MonadExceptN (Succ n) e (t m)+  where+    throwN _ = lift . throwN (proxy# :: Proxy# n)++-- | The @'MonadExcept' e m@ constraint asserts that @m@ is a monad stack+-- that supports throwing exceptions of type @e@+type MonadExcept e m = MonadExceptN (Find (EffExcept e) m) e m++-- | Throw an exception+throw :: forall a e m . MonadExcept e m => e -> m a+throw = throwN (proxy# :: Proxy# (Find (EffExcept e) m))++runExcept :: Exc.ExceptT e m a -> m (Either e a)+runExcept = Exc.runExceptT++runMaybe :: Mb.MaybeT m a -> m (Maybe a)+runMaybe = Mb.runMaybeT
+ Control/Monad/Classes/Exec.hs view
@@ -0,0 +1,31 @@+module Control.Monad.Classes.Exec+  ( MonadExec+  , exec+  , MonadExecN(..)+  , EffExec+  )+  where+import Control.Monad.Trans.Class+import GHC.Prim (Proxy#, proxy#)+import Control.Monad.Classes.Core+import Control.Monad.Classes.Effects+import Data.Peano (Peano (..))++type instance CanDo IO (EffExec IO) = True++class Monad m => MonadExecN (n :: Peano) w m where+  execN :: Proxy# n -> (w a -> m a)++instance Monad w => MonadExecN Zero w w where+  execN _ = id++instance (MonadTrans t, Monad (t m), MonadExecN n w m, Monad m)+  => MonadExecN (Succ n) w (t m)+  where+    execN _ = lift . execN (proxy# :: Proxy# n)++type MonadExec w m = MonadExecN (Find (EffExec w) m) w m++-- | Lift an 'IO' action+exec :: forall w m a . MonadExec w m => w a -> m a+exec = execN (proxy# :: Proxy# (Find (EffExec w) m))
+ Control/Monad/Classes/Proxied.hs view
@@ -0,0 +1,79 @@+-- | 'Proxied' monad. @'Proxied' x@ is a monad transformer that has a global+-- configuration parameter of type @x@ associated with it.+--+-- It is used to implement things like @ZoomT@\/@runZoom@ and+-- @CustromWriterT@\/@evalWriterWith@.+--+-- Most of the time you don't need to use this directly. It is exported for two purposes:+--+-- * you can use it to define new monad transformers+--+-- * you can define instances for @'Proxied' x@ and transformers that are+-- based on it+module Control.Monad.Classes.Proxied+  ( module Control.Monad.Classes.Proxied+  , R.Reifies+  , Proxy#+  , proxy#+  )+  where++import Control.Applicative+import Control.Monad+import Control.Monad.Base+import Control.Monad.IO.Class+import Control.Monad.Trans.Control+import Control.Monad.Trans.Class+import GHC.Prim (Proxy#, proxy#)+import qualified Data.Reflection as R+import Data.Proxy++newtype Proxied x m a = Proxied (forall (q :: *). R.Reifies q x => Proxy# q -> m a)++instance Functor m => Functor (Proxied x m) where+  fmap f (Proxied g) = Proxied (\px -> fmap f (g px))++instance Applicative m => Applicative (Proxied x m) where+  pure x = Proxied (\_ -> pure x)+  Proxied a <*> Proxied b = Proxied (\px -> a px <*> b px)++instance Monad m => Monad (Proxied x m) where+  return x = Proxied (\_ -> return x)+  Proxied a >>= k = Proxied $ \px ->+    a px >>= \v ->+    case k v of+      Proxied b -> b px++instance Alternative m => Alternative (Proxied x m) where+  empty = Proxied $ \_ -> empty+  Proxied a <|> Proxied b = Proxied (\px -> a px <|> b px)++instance MonadPlus m => MonadPlus (Proxied x m) where+  mzero = Proxied $ \_ -> mzero+  Proxied a `mplus` Proxied b = Proxied (\px -> a px `mplus` b px)++instance MonadTrans (Proxied x) where+  lift a = Proxied $ \_ -> a++instance MonadIO m => MonadIO (Proxied x m) where+  liftIO = lift . liftIO++instance MonadBase b m => MonadBase b (Proxied x m) where+  liftBase = liftBaseDefault++instance MonadTransControl (Proxied x) where+  type StT (Proxied x) a = a+  liftWith f = Proxied $ \px -> f $ \(Proxied a) -> a px+  restoreT a = Proxied $ \_ -> a++fromProxy# :: Proxy# a -> Proxy a+fromProxy# _ = Proxy++toProxy# :: Proxy a -> Proxy# a+toProxy# _ = proxy#++reify :: a -> (forall (q :: *). R.Reifies q a => Proxy# q -> r) -> r+reify a k = R.reify a $ \px -> k (toProxy# px)++reflect :: R.Reifies q a => Proxy# q -> a+reflect px = R.reflect (fromProxy# px)
+ Control/Monad/Classes/Reader.hs view
@@ -0,0 +1,82 @@+module Control.Monad.Classes.Reader where+import qualified Control.Monad.Trans.Reader as R+import qualified Control.Monad.Trans.State.Lazy as SL+import qualified Control.Monad.Trans.State.Strict as SS+import Control.Monad.Morph (MFunctor, hoist)+import Control.Monad.Trans.Class+import GHC.Prim (Proxy#, proxy#)+import Control.Monad.Classes.Core+import Control.Monad.Classes.Effects+import Data.Peano++type instance CanDo (R.ReaderT e m) eff = ReaderCanDo e eff++type family ReaderCanDo e eff where+  ReaderCanDo e (EffReader e) = True+  ReaderCanDo e (EffLocal e) = True+  ReaderCanDo e eff = False++class Monad m => MonadReaderN (n :: Peano) r m where+  askN :: Proxy# n -> m r++instance Monad m => MonadReaderN Zero r (R.ReaderT r m) where+  askN _ = R.ask++instance Monad m => MonadReaderN Zero r (SL.StateT r m) where+  askN _ = SL.get++instance Monad m => MonadReaderN Zero r (SS.StateT r m) where+  askN _ = SS.get++instance (MonadTrans t, Monad (t m), MonadReaderN n r m, Monad m)+  => MonadReaderN (Succ n) r (t m)+  where+    askN _ = lift $ askN (proxy# :: Proxy# n)++class Monad m => MonadLocalN (n :: Peano) r m where+  localN :: Proxy# n -> ((r -> r) -> m a -> m a)++instance Monad m => MonadLocalN Zero r (R.ReaderT r m) where+  localN _ = R.local++stateLocal :: Monad m => (a -> m ()) -> m a -> (a -> a) -> m b -> m b+stateLocal putFn getFn f a = do+  s <- getFn+  putFn (f s)+  r <- a+  putFn s+  return r++instance (Monad m) => MonadLocalN Zero r (SL.StateT r m) where+  localN _ = stateLocal SL.put SL.get++instance (Monad m) => MonadLocalN Zero r (SS.StateT r m) where+  localN _ = stateLocal SS.put SS.get++instance (MonadTrans t, Monad (t m), MFunctor t, MonadLocalN n r m, Monad m)+  => MonadLocalN (Succ n) r (t m)+  where+    localN _ = \f -> hoist (localN (proxy# :: Proxy# n) f)++-- | The @'MonadReader' r m@ constraint asserts that @m@ is a monad stack+-- that supports a fixed environment of type @r@+type MonadReader e m = MonadReaderN (Find (EffReader e) m) e m++-- | The @'MonadLocal' r m@ constraint asserts that @m@ is a monad stack+-- that supports a fixed environment of type @r@ that can be changed+-- externally to the monad+type MonadLocal e m = MonadLocalN (Find (EffLocal e) m) e m++-- | Fetch the environment passed through the reader monad+ask :: forall m r . MonadReader r m => m r+ask = askN (proxy# :: Proxy# (Find (EffReader r) m))++-- | Executes a computation in a modified environment.+local :: forall a m r. MonadLocal r m+      => (r -> r)  -- ^ The function to modify the environment.+      -> m a       -- ^ @Reader@ to run in the modified environment.+      -> m a+local = localN (proxy# :: Proxy# (Find (EffLocal r) m))++runReader :: r -> R.ReaderT r m a -> m a+runReader = flip R.runReaderT
+ Control/Monad/Classes/Run.hs view
@@ -0,0 +1,47 @@+-- | Functions to run outer layers of monadic stacks.+--+-- These are provided for convenience only; you can use the running+-- functions (like 'SL.runState') from the transformers' modules directly.+--+-- Note that reader and state runners have their arguments swapped around;+-- this makes it convenient to chain them.+module Control.Monad.Classes.Run+  ( -- * Identity+    run+    -- * Reader+  , runReader+    -- * State+  , runStateLazy+  , runStateStrict+  , evalStateLazy+  , evalStateStrict+  , execStateLazy+  , execStateStrict+    -- * Writer+  , runWriterLazy+  , runWriterStrict+  , evalWriterLazy+  , evalWriterStrict+  , execWriterLazy+  , execWriterStrict+  , evalWriterWith+  , mapWriter+  , CustomWriterT'(..)+  , CustomWriterT+    -- * Except+  , runExcept+  , runMaybe+    -- * Zoom+  , runZoom+  , ZoomT(..)+  ) where++import Data.Functor.Identity+import Control.Monad.Classes.Zoom+import Control.Monad.Classes.State+import Control.Monad.Classes.Writer+import Control.Monad.Classes.Reader+import Control.Monad.Classes.Except++run :: Identity a -> a+run = runIdentity
+ Control/Monad/Classes/State.hs view
@@ -0,0 +1,79 @@+module Control.Monad.Classes.State where+import qualified Control.Monad.Trans.State.Lazy as SL+import qualified Control.Monad.Trans.State.Strict as SS+import Control.Monad.Trans.Class+import GHC.Prim (Proxy#, proxy#)+import Control.Monad.Classes.Core+import Control.Monad.Classes.Effects+import Data.Peano (Peano (..))++type instance CanDo (SS.StateT s m) eff = StateCanDo s eff+type instance CanDo (SL.StateT s m) eff = StateCanDo s eff++type family StateCanDo s eff where+  StateCanDo s (EffState s) = True+  StateCanDo s (EffReader s) = True+  StateCanDo s (EffLocal s) = True+  StateCanDo s (EffWriter s) = True+  StateCanDo s eff = False++class Monad m => MonadStateN (n :: Peano) s m where+  stateN :: Proxy# n -> ((s -> (a, s)) -> m a)++instance Monad m => MonadStateN Zero s (SL.StateT s m) where+  stateN _ = SL.state++instance Monad m => MonadStateN Zero s (SS.StateT s m) where+  stateN _ = SS.state++instance (Monad (t m), MonadTrans t, MonadStateN n s m, Monad m)+  => MonadStateN (Succ n) s (t m)+  where+    stateN _ = lift . stateN (proxy# :: Proxy# n)++-- | The @'MonadState' s m@ constraint asserts that @m@ is a monad stack+-- that supports state operations on type @s@+type MonadState s m = MonadStateN (Find (EffState s) m) s m++-- | Construct a state monad computation from a function+state :: forall s m a. (MonadState s m) => (s -> (a, s)) -> m a+state = stateN (proxy# :: Proxy# (Find (EffState s) m))++-- | @'put' s@ sets the state within the monad to @s@+put :: MonadState s m => s -> m ()+put s = state $ \_ -> ((), s)++-- | Fetch the current value of the state within the monad+get :: MonadState a m => m a+get = state $ \s -> (s, s)++-- | Gets specific component of the state, using a projection function+-- supplied.+gets :: MonadState s m => (s -> a) -> m a+gets f = do+    s <- get+    return (f s)++-- | Maps an old state to a new state inside a state monad layer+modify :: MonadState s m => (s -> s) -> m ()+modify f = state (\s -> ((), f s))++-- | A variant of 'modify' in which the computation is strict in the+-- new state+modify' :: MonadState s m => (s -> s) -> m ()+modify' f = state (\s -> let s' = f s in s' `seq` ((), s'))++runStateLazy   :: s -> SL.StateT s m a -> m (a, s)+runStateLazy   =  flip SL.runStateT+runStateStrict :: s -> SS.StateT s m a -> m (a, s)+runStateStrict =  flip SS.runStateT++evalStateLazy   :: Monad m => s -> SL.StateT s m a -> m a+evalStateLazy   =  flip SL.evalStateT+evalStateStrict :: Monad m => s -> SS.StateT s m a -> m a+evalStateStrict =  flip SS.evalStateT++execStateLazy   :: Monad m => s -> SL.StateT s m a -> m s+execStateLazy   = flip SL.execStateT+execStateStrict :: Monad m => s -> SS.StateT s m a -> m s+execStateStrict = flip SS.execStateT
+ Control/Monad/Classes/Writer.hs view
@@ -0,0 +1,114 @@+module Control.Monad.Classes.Writer where+import Control.Applicative+import Control.Monad+import qualified Control.Monad.Trans.Writer.Lazy as WL+import qualified Control.Monad.Trans.Writer.Strict as WS+import qualified Control.Monad.Trans.State.Lazy as SL+import qualified Control.Monad.Trans.State.Strict as SS+import Control.Monad.Base+import Control.Monad.Trans.Control+import Control.Monad.Trans.Class+import Control.Monad.IO.Class+import Control.Monad.Classes.Core+import Control.Monad.Classes.Effects+import Control.Monad.Classes.Proxied+import Data.Monoid+import Data.Peano++type instance CanDo (WL.WriterT w m) eff = WriterCanDo w eff+type instance CanDo (WS.WriterT w m) eff = WriterCanDo w eff+type instance CanDo (CustomWriterT' w n m) eff = WriterCanDo w eff++type family WriterCanDo w eff where+  WriterCanDo w (EffWriter w) = True+  WriterCanDo w eff = False++class Monad m => MonadWriterN (n :: Peano) w m where+  tellN :: Proxy# n -> (w -> m ())++instance (Monad m, Monoid w) => MonadWriterN Zero w (WL.WriterT w m) where+  tellN _ = WL.tell++instance (Monad m, Monoid w) => MonadWriterN Zero w (WS.WriterT w m) where+  tellN _ = WS.tell++instance (Monad m, Monoid w) => MonadWriterN Zero w (SL.StateT w m) where+  -- lazy+  tellN _ w = SL.modify (<> w)++instance (Monad m, Monoid w) => MonadWriterN Zero w (SS.StateT w m) where+  tellN _ w = modify' (<> w)+    where+      modify' :: (s -> s) -> SS.StateT s m ()+      modify' f = SS.state (\s -> let s' = f s in s' `seq` ((), s'))++instance Monad m => MonadWriterN Zero w (CustomWriterT' w m m) where+  tellN _ w = CustomWriterT $ Proxied $ \px -> reflect px w++instance (MonadTrans t, Monad (t m), MonadWriterN n w m, Monad m)+  => MonadWriterN (Succ n) w (t m)+  where+    tellN _ = lift . tellN (proxy# :: Proxy# n)++-- | The @'MonadWriter' w m@ constraint asserts that @m@ is a monad stack+-- that supports outputting values of type @w@+type MonadWriter w m = MonadWriterN (Find (EffWriter w) m) w m++-- | @'tell' w@ is an action that produces the output @w@+tell :: forall w m . MonadWriter w m => w -> m ()+tell = tellN (proxy# :: Proxy# (Find (EffWriter w) m))++runWriterStrict :: (Monad m, Monoid w) => SS.StateT w m a -> m (a, w)+runWriterStrict = flip SS.runStateT mempty++evalWriterStrict :: (Monad m, Monoid w) => SS.StateT w m a -> m a+evalWriterStrict = flip SS.evalStateT mempty++execWriterStrict :: (Monad m, Monoid w) => SS.StateT w m a -> m w+execWriterStrict = flip SS.execStateT mempty++runWriterLazy :: (Monad m, Monoid w) => WL.WriterT w m a -> m (a, w)+runWriterLazy = WL.runWriterT++evalWriterLazy :: (Monad m, Monoid w) => WL.WriterT w m a -> m a+evalWriterLazy = liftM fst . runWriterLazy++execWriterLazy :: (Monad m, Monoid w) => WL.WriterT w m a -> m w+execWriterLazy = WL.execWriterT++-- The separation between 'n' and 'm' types is needed to implement+-- the MonadTransControl instance+newtype CustomWriterT' w n m a = CustomWriterT (Proxied (w -> n ()) m a)+  deriving (Functor, Applicative, Monad, Alternative, MonadPlus, MonadBase b, MonadIO)+type CustomWriterT w m a = CustomWriterT' w m m a++instance MonadTrans (CustomWriterT' w n) where+  lift a = CustomWriterT $ Proxied $ \_ -> a++instance MonadTransControl (CustomWriterT' w n) where+  type StT (CustomWriterT' w n) a = StT (Proxied (w -> n ())) a+  liftWith = defaultLiftWith CustomWriterT (\(CustomWriterT a) -> a)+  restoreT = defaultRestoreT CustomWriterT++instance MonadBaseControl b m => MonadBaseControl b (CustomWriterT' w n m) where+  type StM (CustomWriterT' w n m) a = ComposeSt (CustomWriterT' w n) m a+  liftBaseWith = defaultLiftBaseWith+  restoreM     = defaultRestoreM++evalWriterWith+  :: forall w m a . (w -> m ())+  -> CustomWriterT w m a+  -> m a+evalWriterWith tellFn a =+  reify tellFn $ \px ->+    case a of+      CustomWriterT (Proxied a') -> a' px++-- | Transform all writer requests with a given function+mapWriter+  :: forall w1 w2 m a . MonadWriter w2 m+  => (w1 -> w2)+  -> CustomWriterT w1 m a+  -> m a+mapWriter f a =+  evalWriterWith (\w1 -> tell (f w1)) a
+ Control/Monad/Classes/Zoom.hs view
@@ -0,0 +1,79 @@+module Control.Monad.Classes.Zoom where++import Control.Applicative+import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Base+import Control.Monad.IO.Class+import Control.Monad.Trans.Control+import Control.Monad.Classes.Core+import Control.Monad.Classes.Effects+import Control.Monad.Classes.Reader+import Control.Monad.Classes.State+import Control.Monad.Classes.Writer+import Control.Monad.Classes.Proxied+import Data.Functor.Identity+import Data.Monoid+import Data.Peano (Peano (..))++newtype ZoomT big small m a = ZoomT (Proxied (VLLens big small) m a)+  deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadTrans, MonadBase b, MonadIO)++newtype VLLens big small = VLLens (forall f . Functor f => (small -> f small) -> big -> f big)++vlGet :: VLLens b a -> b -> a+vlGet (VLLens l) s = getConst (l Const s)++vlSet :: VLLens b a -> a -> b -> b+vlSet (VLLens l) v s = runIdentity (l (\_ -> Identity v) s)++-- N.B. applies function eagerly+vlMod' :: VLLens b a -> (a -> a) -> b -> b+vlMod' (VLLens l) f s = runIdentity (l (\x -> Identity $! f x) s)++runZoom+  :: forall big small m a .+     (forall f. Functor f => (small -> f small) -> big -> f big)+  -> ZoomT big small m a+  -> m a+runZoom l a =+  reify (VLLens l) $ \px ->+    case a of ZoomT (Proxied f) -> f px++type instance CanDo (ZoomT big small m) eff = ZoomCanDo small eff++type family ZoomCanDo s eff where+  ZoomCanDo s (EffState s) = True+  ZoomCanDo s (EffReader s) = True+  ZoomCanDo s (EffWriter s) = True+  ZoomCanDo s eff = False++instance MonadReader big m => MonadReaderN Zero small (ZoomT big small m)+  where+  askN _ = ZoomT $ Proxied $ \px -> vlGet (reflect px) `liftM` ask++instance MonadState big m => MonadStateN Zero small (ZoomT big small m)+  where+  stateN _ f = ZoomT $ Proxied $ \px ->+    let l = reflect px in+    state $ \s ->+      case f (vlGet l s) of+        (a, t') -> (a, vlSet l t' s)++instance (MonadState big m, Monoid small) => MonadWriterN Zero small (ZoomT big small m)+  where+  tellN _ w = ZoomT $ Proxied $ \px ->+    let l = reflect px in+    state $ \s ->+      let s' = vlMod' l (<> w) s+      in s' `seq` ((), s')++instance MonadTransControl (ZoomT big small) where+  type StT (ZoomT big small) a = a+  liftWith = defaultLiftWith ZoomT (\(ZoomT a) -> a)+  restoreT = defaultRestoreT ZoomT++instance MonadBaseControl b m => MonadBaseControl b (ZoomT big small m) where+    type StM (ZoomT big small m) a = StM m a+    liftBaseWith = defaultLiftBaseWith+    restoreM     = defaultRestoreM
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2014 Roman Cheplyaka++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,27 @@+[![Build Status](https://travis-ci.org/feuerbach/monad-classes.svg?branch=master)](https://travis-ci.org/feuerbach/monad-classes)++See [this series of articles][1] for the detailed description and motivation.++[1]: https://ro-che.info/articles/extensible-effects++This is a more flexible version of mtl, the monad transformers library.++*   You can have many layers of e.g. state transformers in your stack, and+    you don't have to explicitly lift your `get`s and `put`s, as soon as+    different state transformers carry different types of states.++    Example:++    ``` haskell+    a :: (MonadState Bool m, MonadState Int m) => m ()+    a = do+      put False -- set the boolean state+      modify (+ (1 :: Int)) -- modify the integer state+    ```++*   mtl requires *Θ(n<sup>2</sup>)* instances (like `MonadReader e (StateT s m)`);+    monad-classes requires only *Θ(n)* of them (where *n* is the number of+    different transformer types).++    If you'd like to define your own monad-classes-style class, you have to+    write much less boilerplate code.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ monad-classes.cabal view
@@ -0,0 +1,82 @@+name:                monad-classes+version:             0.3+synopsis:            more flexible mtl+-- description:+homepage:            https://github.com/feuerbach/monad-classes+license:             MIT+license-file:        LICENSE+author:              Roman Cheplyaka <roma@ro-che.info>+maintainer:          Roman Cheplyaka <roma@ro-che.info>+-- copyright:+category:            Control+build-type:          Simple+extra-source-files:+  README.md+cabal-version:       >=1.10++library+  exposed-modules:+    Control.Monad.Classes+    Control.Monad.Classes.Run+    Control.Monad.Classes.Proxied+  other-modules:+    Control.Monad.Classes.State,+    Control.Monad.Classes.Writer,+    Control.Monad.Classes.Reader,+    Control.Monad.Classes.Except,+    Control.Monad.Classes.Exec,+    Control.Monad.Classes.Zoom,+    Control.Monad.Classes.Core,+    Control.Monad.Classes.Effects+  build-depends:+    base >=4.7 && <5,+    peano >=0.1,+    mmorph >=1.0.3,+    transformers >=0.2,+    transformers-compat >=0.3.1,+    transformers-base >=0.4.2,+    monad-control >=1,+    reflection >=1.4,+    ghc-prim+  -- hs-source-dirs:+  default-language:    Haskell2010+  default-extensions:+    TypeFamilies,+    DataKinds,+    KindSignatures,+    FlexibleInstances,+    ScopedTypeVariables,+    FlexibleContexts,+    PolyKinds,+    ConstraintKinds,+    MultiParamTypeClasses,+    TypeOperators,+    UndecidableInstances,+    MagicHash,+    GeneralizedNewtypeDeriving,+    RankNTypes+  ghc-options: -Wall+  if (impl (ghc >=7.10))+    ghc-options: -fno-warn-unticked-promoted-constructors++Test-suite test+  Default-language:+    Haskell2010+  Extensions:+    FlexibleContexts+  Type:+    exitcode-stdio-1.0+  Hs-source-dirs:+    tests+  Main-is:+    test.hs+  Build-depends:+      base >=4 && <5+    , tasty >=0.8+    , tasty-hunit+    , monad-classes+    , transformers+    , data-lens-light >=0.1.2+    , ghc-prim+    , conduit+    , mmorph
+ tests/test.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, NoMonomorphismRestriction,+             DataKinds, TypeFamilies, TemplateHaskell, ScopedTypeVariables,+             MagicHash #-}+import Test.Tasty+import Test.Tasty.HUnit+import Control.Monad.Trans.Class+import qualified Data.Functor.Identity as I+import qualified Control.Monad.Trans.Reader as R+import qualified Control.Monad.Trans.Writer as W+import Control.Monad.Classes+import Control.Monad.Classes.Run+import Control.Applicative+import Control.Exception hiding (throw)+import Data.Lens.Light+import GHC.Prim (Proxy#, proxy#)++-- for IO tests+import qualified Foreign.Storable as Foreign+import qualified Foreign.Marshal.Alloc as Foreign++-- for monad-control tests+import qualified Data.Conduit as C+import Control.Monad.Morph++-- for zoom tests+data Record = Record+  { _listL :: [Int]+  , _intL :: Int+  }+  deriving (Show, Eq)++makeLens ''Record++main = defaultMain tests++tests :: TestTree+tests = testGroup "Tests"+  [ simpleStateTests+  , twoStatesTests+  , liftingTest+  , localState+  , exceptTests+  , execTests+  , zoomTests+  , liftNTests+  , liftConduitTest+  , mapWriterTest+  ]++simpleStateTests = testGroup "Simple State"+  [ testCase "get" $+      (run $ runStateLazy (0 :: Int) get) @?= (0 :: Int, 0 :: Int)+  , testCase "put" $+      (run $ runStateLazy (0 :: Int) (put (1 :: Int))) @?= ((), 1 :: Int)+  , testCase "put-get-put" $+      (run $ runStateLazy (0 :: Int) (put (1 :: Int) *> get <* put (2 :: Int))) @?= (1 :: Int, 2 :: Int)+  ]++twoStatesComp = put 'b' >> put True >> put 'c'++twoStatesTests = testCase "Two States" $+  (run $ runStateLazy 'a' $ runStateLazy False twoStatesComp) @?= (((), True), 'c')++newtype Foo m a = Foo { runFoo :: m a }+  deriving (Functor, Applicative, Monad)+instance MonadTrans Foo where+  lift = Foo+type instance CanDo (Foo m) eff = False++liftingTest = testCase "Lifting through an unknown transformer" $+  (run $ runStateLazy 'a' $ runFoo $ runStateLazy False twoStatesComp) @?= (((), True), 'c')++localState = testCase "MonadLocal StateT" $+  (run $ evalStateStrict 'a' $+    do+      s1 <- get+      (s2,s3) <- local (toEnum . (+1) . fromEnum :: Char -> Char) $ do+        s2 <- get+        put 'x'+        s3 <- get+        return (s2,s3)+      s4 <- get+      return [s1,s2,s3,s4]) @?= "abxa"++exceptTests = testGroup "Except"+  [ testCase "Catch before IO" $ do+      r <- runExcept $ runStateStrict False $ throw $ ErrorCall "foo"+      (r :: Either ErrorCall ((), Bool)) @?= Left (ErrorCall "foo")+  , testCase "Let escape to IO" $ do+      r <- try $ runExcept $ runStateStrict False $ throw UserInterrupt+      (r :: Either AsyncException (Either ErrorCall ((), Bool))) @?= Left UserInterrupt+  ]++execTests = testCase "Exec" $ do+  r <- runWriterStrict $ exec $+    Foreign.alloca $ \ptr -> do+      Foreign.poke ptr True+      Foreign.peek ptr+  r @?= (True, ())++zoomTests = testCase "Zoom" $ do+  ((4, [2,5], 6), Record [2,5,10] 6) @?=+    (run $ runStateStrict (Record [2] 4) $ runZoom (vanLaarhoven intL) $ runZoom (vanLaarhoven listL) $ do+      (s0 :: Int) <- get+      tell [5 :: Int]+      (s1 :: [Int]) <- ask+      put (6 :: Int)+      (s2 :: Int) <- ask+      tell [10 :: Int]+      return (s0, s1, s2)+    )++liftNTests = testCase "liftN" $ do+  (run $ runReader 'a' $ runReader 'b' $ runReader 'c' $+    liftN (proxy# :: Proxy# (Succ Zero)) R.ask)+  @?= 'b'+++liftConduit+  :: forall m n effM eff i o r .+     ( n ~ Find eff m+     , MonadLiftN n m+     , effM ~ Down n m+     , Monad effM+     )+  => Proxy# eff+  -> C.ConduitM i o effM r+  -> C.ConduitM i o m    r+liftConduit _ = hoist (liftN (proxy# :: Proxy# n))++liftConduitTest = testCase "lift conduit" $+  (let+    src :: C.Source I.Identity Int+    src = C.yield 1 >> C.yield 2++    sink :: C.Sink Int (W.Writer [Int]) ()+    sink =+      C.await >>=+        maybe (return ()) (\x -> do lift $ tell [x::Int]; sink)+   in+    W.execWriter $ hoist (liftN (proxy# :: Proxy# (Succ Zero))) src C.$$ sink+  ) @?= [1,2]+  {-++  execWriterStrict $ runReader (3 :: Int) $+    liftConduit (proxy# :: Proxy# (EffReader Int))+      (do+        x <- ask+        liftConduit (C.yield x)+        liftConduit (C.yield (x :: Int)))+    C.$$+      (proxy# :: Proxy# (EffWriter String)) (do C.awaitForever $ \y -> tell (show (y :: Int) ++ "\n")))+  @?= ""-}++mapWriterTest = testCase "mapWriter" $ do+  run (execWriterStrict $ mapWriter (\(w :: Char) -> [w]) $ do { tell 'a'; tell 'b'; tell 'c' }) @?= "abc"