@@ -0,0 +1,110 @@
1+{-# LANGUAGE MultiParamTypeClasses #-}
2+{-# LANGUAGE TypeFamilies #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE UndecidableInstances #-}
6+{-# LANGUAGE DataKinds #-}
7+{-# LANGUAGE TypeOperators #-}
8+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9+module Control.Monad.Trans.Ether.State.Lazy
27+import Data.Proxy (Proxy(Proxy))
28+import Data.Functor.Identity (Identity(..))
29+import Data.Coerce (coerce)
30+import Control.Applicative (Alternative)
31+import Control.Monad (MonadPlus)
32+import Control.Monad.Fix (MonadFix)
33+import Control.Monad.Trans.Class (MonadTrans, lift)
34+import Control.Monad.IO.Class (MonadIO)
35+import Control.Ether.Core
37+import qualified Control.Monad.Signatures as Sig
38+import qualified Control.Monad.Trans.State.Lazy as S
40+import qualified Control.Monad.Cont.Class as Class
41+import qualified Control.Monad.Reader.Class as Class
42+import qualified Control.Monad.State.Class as Class
43+import qualified Control.Monad.Writer.Class as Class
44+import qualified Control.Monad.Error.Class as Class
46+newtype EtherStateT tag s m a = EtherStateT (S.StateT s m a)
47+ deriving ( Functor, Applicative, Alternative, Monad, MonadPlus
48+ , MonadFix, MonadTrans, MonadIO )
50+type instance EtherTags (EtherStateT tag r m) = tag ': EtherTags m
52+type EtherState tag r = EtherStateT tag r Identity
54+etherStateT :: proxy tag -> (s -> m (a, s)) -> EtherStateT tag s m a
55+etherStateT _proxy = EtherStateT . S.StateT
57+runEtherStateT :: proxy tag -> EtherStateT tag s m a -> s -> m (a, s)
58+runEtherStateT _proxy (EtherStateT (S.StateT f)) = f
60+runEtherState :: proxy tag -> EtherState tag s a -> s -> (a, s)
61+runEtherState proxy m s = runIdentity (runEtherStateT proxy m s)
63+mapEtherStateT :: proxy tag -> (m (a, s) -> n (b, s)) -> EtherStateT tag s m a -> EtherStateT tag s n b
64+mapEtherStateT _proxy f m = EtherStateT $ S.mapStateT f (coerce m)
66+liftCatch :: proxy tag -> Sig.Catch e m (a, s) -> Sig.Catch e (EtherStateT tag s m) a
67+liftCatch _proxy f m h = EtherStateT $ S.liftCatch f (coerce m) (coerce h)
69+liftCallCC' :: proxy tag -> Sig.CallCC m (a, s) (b, s) -> Sig.CallCC (EtherStateT tag s m) a b
70+liftCallCC' _proxy callCC f = EtherStateT $ S.liftCallCC' callCC (coerce f)
72+liftListen :: Monad m => proxy tag -> Sig.Listen w m (a, s) -> Sig.Listen w (EtherStateT tag s m) a
73+liftListen _proxy listen m = EtherStateT $ S.liftListen listen (coerce m)
75+liftPass :: Monad m => proxy tag -> Sig.Pass w m (a,s) -> Sig.Pass w (EtherStateT tag s m) a
76+liftPass _proxy pass m = EtherStateT $ S.liftPass pass (coerce m)
78+type StateT' s = EtherStateT s s
79+type State' s = EtherState s s
81+runStateT' :: StateT' s m a -> s -> m (a, s)
82+runStateT' = runEtherStateT Proxy
84+runState' :: State' s a -> s -> (a, s)
85+runState' m s = runIdentity (runStateT' m s)
87+-- Instances for mtl classes
89+instance Class.MonadCont m => Class.MonadCont (EtherStateT tag s m) where
90+ callCC = liftCallCC' Proxy Class.callCC
92+instance Class.MonadReader r m => Class.MonadReader r (EtherStateT tag s m) where
94+ local = mapEtherStateT Proxy . Class.local
95+ reader = lift . Class.reader
97+instance Class.MonadState s' m => Class.MonadState s' (EtherStateT tag s m) where
99+ put = lift . Class.put
100+ state = lift . Class.state
102+instance Class.MonadWriter w m => Class.MonadWriter w (EtherStateT tag s m) where
103+ writer = lift . Class.writer
104+ tell = lift . Class.tell
105+ listen = liftListen Proxy Class.listen
106+ pass = liftPass Proxy Class.pass
108+instance Class.MonadError e m => Class.MonadError e (EtherStateT tag s m) where
109+ throwError = lift . Class.throwError
110+ catchError = liftCatch Proxy Class.catchError