git.iko.soy/typeable/ether
on master help sign in
Lazy MonadEtherState
commit217021cceb747de69a6a00d3df1a0fa1cdd358f5 authorIndex Int <vlad.z.4096@gmail.com> dateWed 10 Jun 2015, 12:38 (11 years ago) parente2b72ea
6 files changed+259−113
compare with master
unifiedsplit
ether.cabal+1−1 src/Control/Ether/Core.hs+3 src/Control/Monad/Ether/Reader.hs+2 src/Control/Monad/Ether/State.hs+146 src/Control/Monad/Trans/Ether/State.hs+107−2 src/Control/Monad/Trans/Ether/State/Lazy.hs−110
ether.cabal+1−1
@@ -28,8 +28,8 @@ library
2828 Control.Ether.Wrapped
2929 Control.Monad.Trans.Ether.Reader
3030 Control.Monad.Trans.Ether.State
31− Control.Monad.Trans.Ether.State.Lazy
3231 Control.Monad.Ether.Reader
32+ Control.Monad.Ether.State
3333
3434 build-depends: base >=4.8 && <4.9
3535 , transformers >=0.4.0.3
src/Control/Ether/Core.hs+3
@@ -9,6 +9,7 @@ module Control.Ether.Core
99 , UniqueEtherTag
1010 , UniqueEtherTags
1111 , ensureUniqueEtherTags
12+ , Strictness (Strict, Lazy)
1213 ) where
1314
1415import Data.Proxy (Proxy)
@@ -33,6 +34,8 @@ import qualified Control.Monad.Trans.Writer.Strict as Trans.Strict
3334-- Never declare instances for this class
3435class UniqueEtherTag a
3536
37+data Strictness = Strict | Lazy
38+
3639type family IsUnique (x :: k) (as :: [k]) :: Constraint where
3740 IsUnique x (x ': as) = UniqueEtherTag x
3841 IsUnique x (a ': as) = IsUnique x as
src/Control/Monad/Ether/Reader.hs+2
@@ -50,6 +50,8 @@ import qualified Control.Monad.Trans.Writer.Strict as Trans.Strict (WriterT , m
5050
5151class Monad m => MonadEtherReader tag r m | m tag -> r where
5252
53+ {-# MINIMAL (etherAsk | etherReader), etherLocal #-}
54+
5355 etherLocal :: proxy tag -> (r -> r) -> m a -> m a
5456
5557 etherAsk :: proxy tag -> m r
src/Control/Monad/Ether/State.hsnew file+146
@@ -0,0 +1,146 @@
1+{-# LANGUAGE MultiParamTypeClasses #-}
2+{-# LANGUAGE TypeFamilies #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE UndecidableInstances #-}
6+{-# LANGUAGE DataKinds #-}
7+{-# LANGUAGE ConstraintKinds #-}
8+{-# LANGUAGE TypeOperators #-}
9+{-# LANGUAGE FunctionalDependencies #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE RankNTypes #-}
12+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
13+module Control.Monad.Ether.State
14+ ( EtherStateT
15+ , EtherState
16+ , StateT'
17+ , State'
18+ , runEtherStateT
19+ , runEtherState
20+ , runStateT'
21+ , runState'
22+ --
23+ , MonadEtherState
24+ , etherGet
25+ , etherGets
26+ , etherPut
27+ , etherState
28+ --
29+ , MonadState'
30+ , get'
31+ , gets'
32+ , put'
33+ , state'
34+ ) where
35+
36+import Data.Proxy (Proxy(Proxy))
37+import Control.Monad.Trans (lift)
38+
39+import Control.Monad.Trans.Ether.State
40+
41+-- for mtl instances
42+import qualified Control.Monad.Trans.Cont as Trans (ContT)
43+import qualified Control.Monad.Trans.Except as Trans (ExceptT)
44+import qualified Control.Monad.Trans.Identity as Trans (IdentityT)
45+import qualified Control.Monad.Trans.List as Trans (ListT)
46+import qualified Control.Monad.Trans.Maybe as Trans (MaybeT)
47+import qualified Control.Monad.Trans.Reader as Trans (ReaderT)
48+import qualified Control.Monad.Trans.State.Lazy as Trans.Lazy (StateT)
49+import qualified Control.Monad.Trans.State.Strict as Trans.Strict (StateT)
50+import qualified Control.Monad.Trans.Writer.Lazy as Trans.Lazy (WriterT)
51+import qualified Control.Monad.Trans.Writer.Strict as Trans.Strict (WriterT)
52+
53+class Monad m => MonadEtherState tag s m | m tag -> s where
54+
55+ {-# MINIMAL etherState | etherGet, etherPut #-}
56+
57+ etherGet :: proxy tag -> m s
58+ etherGet proxy = etherState proxy (\s -> (s, s))
59+
60+ etherPut :: proxy tag -> s -> m ()
61+ etherPut proxy s = etherState proxy (\_ -> ((), s))
62+
63+ etherState :: proxy tag -> (s -> (a, s)) -> m a
64+ etherState proxy f = do
65+ s <- etherGet proxy
66+ let ~(a, s') = f s
67+ etherPut proxy s'
68+ return a
69+
70+etherGets :: MonadEtherState tag s m => proxy tag -> (s -> a) -> m a
71+etherGets proxy f = fmap f (etherGet proxy)
72+
73+type MonadState' s = MonadEtherState s s
74+
75+get' :: forall m s . MonadState' s m => m s
76+get' = etherGet (Proxy :: Proxy s)
77+
78+gets' :: forall m s a . MonadState' s m => (s -> a) -> m a
79+gets' = etherGets (Proxy :: Proxy s)
80+
81+put' :: forall m s . MonadState' s m => s -> m ()
82+put' = etherPut (Proxy :: Proxy s)
83+
84+state' :: forall m s a . MonadState' s m => (s -> (a, s)) -> m a
85+state' = etherState (Proxy :: Proxy s)
86+
87+instance {-# OVERLAPPING #-} Monad m => MonadEtherState tag s (EtherStateT tag s m) where
88+ etherGet proxy = etherStateT proxy (\s -> return (s, s))
89+ etherPut proxy s = etherStateT proxy (\_ -> return ((), s))
90+
91+instance (MonadEtherState tag s m) => MonadEtherState tag s (EtherStateT tag' s' m) where
92+ etherGet proxy = lift (etherGet proxy)
93+ etherPut proxy = lift . etherPut proxy
94+ etherState proxy = lift . etherState proxy
95+
96+-- Instances for mtl transformers
97+
98+instance MonadEtherState tag s m => MonadEtherState tag s (Trans.ContT r m) where
99+ etherGet proxy = lift (etherGet proxy)
100+ etherPut proxy = lift . etherPut proxy
101+ etherState proxy = lift . etherState proxy
102+
103+instance MonadEtherState tag s m => MonadEtherState tag s (Trans.ExceptT e m) where
104+ etherGet proxy = lift (etherGet proxy)
105+ etherPut proxy = lift . etherPut proxy
106+ etherState proxy = lift . etherState proxy
107+
108+instance MonadEtherState tag s m => MonadEtherState tag s (Trans.IdentityT m) where
109+ etherGet proxy = lift (etherGet proxy)
110+ etherPut proxy = lift . etherPut proxy
111+ etherState proxy = lift . etherState proxy
112+
113+instance MonadEtherState tag s m => MonadEtherState tag s (Trans.ListT m) where
114+ etherGet proxy = lift (etherGet proxy)
115+ etherPut proxy = lift . etherPut proxy
116+ etherState proxy = lift . etherState proxy
117+
118+instance MonadEtherState tag s m => MonadEtherState tag s (Trans.MaybeT m) where
119+ etherGet proxy = lift (etherGet proxy)
120+ etherPut proxy = lift . etherPut proxy
121+ etherState proxy = lift . etherState proxy
122+
123+instance MonadEtherState tag s m => MonadEtherState tag s (Trans.ReaderT r m) where
124+ etherGet proxy = lift (etherGet proxy)
125+ etherPut proxy = lift . etherPut proxy
126+ etherState proxy = lift . etherState proxy
127+
128+instance MonadEtherState tag s m => MonadEtherState tag s (Trans.Lazy.StateT s' m) where
129+ etherGet proxy = lift (etherGet proxy)
130+ etherPut proxy = lift . etherPut proxy
131+ etherState proxy = lift . etherState proxy
132+
133+instance MonadEtherState tag s m => MonadEtherState tag s (Trans.Strict.StateT s' m) where
134+ etherGet proxy = lift (etherGet proxy)
135+ etherPut proxy = lift . etherPut proxy
136+ etherState proxy = lift . etherState proxy
137+
138+instance (Monoid w, MonadEtherState tag s m) => MonadEtherState tag s (Trans.Lazy.WriterT w m) where
139+ etherGet proxy = lift (etherGet proxy)
140+ etherPut proxy = lift . etherPut proxy
141+ etherState proxy = lift . etherState proxy
142+
143+instance (Monoid w, MonadEtherState tag s m) => MonadEtherState tag s (Trans.Strict.WriterT w m) where
144+ etherGet proxy = lift (etherGet proxy)
145+ etherPut proxy = lift . etherPut proxy
146+ etherState proxy = lift . etherState proxy
src/Control/Monad/Trans/Ether/State.hs+107−2
@@ -1,5 +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 #-}
19module Control.Monad.Trans.Ether.State
2− ( module Control.Monad.Trans.Ether.State.Lazy
10+ ( EtherStateT
11+ , EtherState
12+ , StateT'
13+ , State'
14+ , runEtherStateT
15+ , runEtherState
16+ , runStateT'
17+ , runState'
18+ --
19+ , etherStateT
20+ , mapEtherStateT
21+ , liftCatch
22+ , liftCallCC'
23+ , liftListen
24+ , liftPass
325 ) where
426
5−import 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
36+
37+import qualified Control.Monad.Signatures as Sig
38+import qualified Control.Monad.Trans.State.Lazy as S
39+
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
45+
46+newtype EtherStateT tag s m a = EtherStateT (S.StateT s m a)
47+ deriving ( Functor, Applicative, Alternative, Monad, MonadPlus
48+ , MonadFix, MonadTrans, MonadIO )
49+
50+type instance EtherTags (EtherStateT tag r m) = tag ': EtherTags m
51+
52+type EtherState tag r = EtherStateT tag r Identity
53+
54+etherStateT :: proxy tag -> (s -> m (a, s)) -> EtherStateT tag s m a
55+etherStateT _proxy = EtherStateT . S.StateT
56+
57+runEtherStateT :: proxy tag -> EtherStateT tag s m a -> s -> m (a, s)
58+runEtherStateT _proxy (EtherStateT (S.StateT f)) = f
59+
60+runEtherState :: proxy tag -> EtherState tag s a -> s -> (a, s)
61+runEtherState proxy m s = runIdentity (runEtherStateT proxy m s)
62+
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)
65+
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)
68+
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)
71+
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)
74+
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)
77+
78+type StateT' s = EtherStateT s s
79+type State' s = EtherState s s
80+
81+runStateT' :: StateT' s m a -> s -> m (a, s)
82+runStateT' = runEtherStateT Proxy
83+
84+runState' :: State' s a -> s -> (a, s)
85+runState' m s = runIdentity (runStateT' m s)
86+
87+-- Instances for mtl classes
88+
89+instance Class.MonadCont m => Class.MonadCont (EtherStateT tag s m) where
90+ callCC = liftCallCC' Proxy Class.callCC
91+
92+instance Class.MonadReader r m => Class.MonadReader r (EtherStateT tag s m) where
93+ ask = lift Class.ask
94+ local = mapEtherStateT Proxy . Class.local
95+ reader = lift . Class.reader
96+
97+instance Class.MonadState s' m => Class.MonadState s' (EtherStateT tag s m) where
98+ get = lift Class.get
99+ put = lift . Class.put
100+ state = lift . Class.state
101+
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
107+
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
src/Control/Monad/Trans/Ether/State/Lazy.hsdeleted−110
@@ -1,110 +0,0 @@
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
10− ( EtherStateT
11− , EtherState
12− , StateT'
13− , State'
14− , runEtherStateT
15− , runEtherState
16− , runStateT'
17− , runState'
18− --
19− , etherStateT
20− , mapEtherStateT
21− , liftCatch
22− , liftCallCC'
23− , liftListen
24− , liftPass
25− ) where
26−
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
36−
37−import qualified Control.Monad.Signatures as Sig
38−import qualified Control.Monad.Trans.State.Lazy as S
39−
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
45−
46−newtype EtherStateT tag s m a = EtherStateT (S.StateT s m a)
47− deriving ( Functor, Applicative, Alternative, Monad, MonadPlus
48− , MonadFix, MonadTrans, MonadIO )
49−
50−type instance EtherTags (EtherStateT tag r m) = tag ': EtherTags m
51−
52−type EtherState tag r = EtherStateT tag r Identity
53−
54−etherStateT :: proxy tag -> (s -> m (a, s)) -> EtherStateT tag s m a
55−etherStateT _proxy = EtherStateT . S.StateT
56−
57−runEtherStateT :: proxy tag -> EtherStateT tag s m a -> s -> m (a, s)
58−runEtherStateT _proxy (EtherStateT (S.StateT f)) = f
59−
60−runEtherState :: proxy tag -> EtherState tag s a -> s -> (a, s)
61−runEtherState proxy m s = runIdentity (runEtherStateT proxy m s)
62−
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)
65−
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)
68−
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)
71−
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)
74−
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)
77−
78−type StateT' s = EtherStateT s s
79−type State' s = EtherState s s
80−
81−runStateT' :: StateT' s m a -> s -> m (a, s)
82−runStateT' = runEtherStateT Proxy
83−
84−runState' :: State' s a -> s -> (a, s)
85−runState' m s = runIdentity (runStateT' m s)
86−
87−-- Instances for mtl classes
88−
89−instance Class.MonadCont m => Class.MonadCont (EtherStateT tag s m) where
90− callCC = liftCallCC' Proxy Class.callCC
91−
92−instance Class.MonadReader r m => Class.MonadReader r (EtherStateT tag s m) where
93− ask = lift Class.ask
94− local = mapEtherStateT Proxy . Class.local
95− reader = lift . Class.reader
96−
97−instance Class.MonadState s' m => Class.MonadState s' (EtherStateT tag s m) where
98− get = lift Class.get
99− put = lift . Class.put
100− state = lift . Class.state
101−
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
107−
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