git.iko.soy/typeable/ether
on master help sign in
Remove Proxy# and rename Dispatch to Handler
9de2a97Vladislav Zavialov
ether-flatten/ether-flatten.cabal+2−1
compare with master
unifiedsplit
@@ -28,6 +28,7 @@ library
28 , Control.Ether.Flatten
28 , Control.Ether.Flatten
29 build-depends: base >=4.9 && <4.10
29 build-depends: base >=4.9 && <4.10
30 , ether >=0.5 && <0.6
30 , ether >=0.5 && <0.6
31+ , mtl >=2.2.1
31 , transformers >=0.4.2
32 , transformers >=0.4.2
32 , transformers-lift >=0.1.0.1
33 , transformers-lift >=0.1.0.1
33 , ghc-prim >=0.3
34 , ghc-prim >=0.3
@@ -41,4 +42,4 @@ library
41 TypeApplications
42 TypeApplications
42
43
43 hs-source-dirs: src
44 hs-source-dirs: src
44− ghc-options: -Wall
45+ ghc-options: -Wall -O2
ether-flatten/src/Control/Ether/Flatten.hs+217−69
@@ -6,84 +6,232 @@
6{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE FlexibleInstances #-}
7{-# LANGUAGE GADTs #-}
7{-# LANGUAGE GADTs #-}
8{-# LANGUAGE TypeFamilies #-}
8{-# LANGUAGE TypeFamilies #-}
9−{-# LANGUAGE MagicHash #-}
9+{-# LANGUAGE TemplateHaskell #-}
10+{-# LANGUAGE StandaloneDeriving #-}
11+{-# LANGUAGE AllowAmbiguousTypes #-}
12+{-# LANGUAGE DeriveGeneric #-}
13+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
10
14
11module Control.Ether.Flatten
15module Control.Ether.Flatten
12 ( HasLens(..)
16 ( HasLens(..)
13− , Product
17+ , Product(..)
14− , load
15− , type (++)
16− , (<+>)
17 ) where
18 ) where
18
19
19−import Control.Lens
20import Control.DeepSeq
20import Control.DeepSeq
21−import GHC.Prim (Proxy#)
21+import Control.Lens
22+import GHC.Generics (Generic)
22
23
23class HasLens tag outer inner | tag outer -> inner where
24class HasLens tag outer inner | tag outer -> inner where
24− lensOf :: Proxy# tag -> Lens' outer inner
25+ lensOf :: Lens' outer inner
26+
27+data family Product :: [k] -> [*] -> *
28+
29+data instance Product ts '[a1, a2, a3, a4] =
30+ P4
31+ { p4_1 :: !a1
32+ , p4_2 :: !a2
33+ , p4_3 :: !a3
34+ , p4_4 :: !a4
35+ } deriving (Generic)
36+
37+deriving instance
38+ ( Show a1
39+ , Show a2
40+ , Show a3
41+ , Show a4
42+ ) => Show (Product ts '[a1, a2, a3, a4])
43+
44+instance
45+ ( NFData a1
46+ , NFData a2
47+ , NFData a3
48+ , NFData a4
49+ ) => NFData (Product ts '[a1, a2, a3, a4])
50+
51+instance a ~ a1 => HasLens t1
52+ (Product
53+ '[t1, t2, t3, t4]
54+ '[a1, a2, a3, a4]) a where
55+ lensOf = lens p4_1 (\p a -> p{ p4_1 = a })
56+ {-# INLINE lensOf #-}
57+
58+instance a ~ a2 => HasLens t2
59+ (Product
60+ '[t1, t2, t3, t4]
61+ '[a1, a2, a3, a4]) a where
62+ lensOf = lens p4_2 (\p a -> p{ p4_2 = a })
63+ {-# INLINE lensOf #-}
64+
65+instance a ~ a3 => HasLens t3
66+ (Product
67+ '[t1, t2, t3, t4]
68+ '[a1, a2, a3, a4]) a where
69+ lensOf = lens p4_3 (\p a -> p{ p4_3 = a })
70+ {-# INLINE lensOf #-}
71+
72+instance a ~ a4 => HasLens t4
73+ (Product
74+ '[t1, t2, t3, t4]
75+ '[a1, a2, a3, a4]) a where
76+ lensOf = lens p4_4 (\p a -> p{ p4_4 = a })
77+ {-# INLINE lensOf #-}
25
78
26−data Product (ts :: [k]) (as :: [*]) where
79+data instance Product ts '[a1, a2, a3, a4, a5] =
27− Nil :: Product '[] '[]
80+ P5
28− Cons :: a -> !(Product ts as) -> Product (t ': ts) (a ': as)
81+ { p5_1 :: !a1
82+ , p5_2 :: !a2
83+ , p5_3 :: !a3
84+ , p5_4 :: !a4
85+ , p5_5 :: !a5
86+ } deriving (Generic)
29
87
30−instance NFData (Product '[] '[]) where
88+deriving instance
31− rnf Nil = ()
89+ ( Show a1
90+ , Show a2
91+ , Show a3
92+ , Show a4
93+ , Show a5
94+ ) => Show (Product ts '[a1, a2, a3, a4, a5])
32
95
33instance
96instance
34− ( NFData a
97+ ( NFData a1
98+ , NFData a2
99+ , NFData a3
35− , NFData (Product ts as)
100+ , NFData a4
101+ , NFData a5
36− ) => NFData (Product (t ': ts) (a ': as))
102+ ) => NFData (Product ts '[a1, a2, a3, a4, a5])
37− where
103+
38− rnf (Cons a as) = rnf a `seq` rnf as
104+instance a ~ a1 => HasLens t1
39−
105+ (Product
40−load :: forall tag a . a -> Product '[tag] '[a]
106+ '[t1, t2, t3, t4, t5]
41−load a = Cons a Nil
107+ '[a1, a2, a3, a4, a5]) a where
108+ lensOf = lens p5_1 (\p a -> p{ p5_1 = a })
42−{-# INLINE load #-}
109+ {-# INLINE lensOf #-}
43−
110+
44−type family (xs1 :: [k]) ++ (xs2 :: [k]) :: [k] where
111+instance a ~ a2 => HasLens t2
45− '[] ++ xs2 = xs2
112+ (Product
46− (a ': xs1) ++ xs2 = a ': (xs1 ++ xs2)
113+ '[t1, t2, t3, t4, t5]
47−
114+ '[a1, a2, a3, a4, a5]) a where
48−(<+>)
115+ lensOf = lens p5_2 (\p a -> p{ p5_2 = a })
49− :: Product ts1 as1
116+ {-# INLINE lensOf #-}
50− -> Product ts2 as2
117+
51− -> Product (ts1 ++ ts2) (as1 ++ as2)
118+instance a ~ a3 => HasLens t3
52−Nil <+> as2 = as2
119+ (Product
53−Cons a as1 <+> as2 = Cons a (as1 <+> as2)
120+ '[t1, t2, t3, t4, t5]
121+ '[a1, a2, a3, a4, a5]) a where
122+ lensOf = lens p5_3 (\p a -> p{ p5_3 = a })
54−{-# INLINE (<+>) #-}
123+ {-# INLINE lensOf #-}
55−
124+
56−productHead ::
125+instance a ~ a4 => HasLens t4
57− Lens
58− (Product (t1 ': ts) (a ': as))
126+ (Product
127+ '[t1, t2, t3, t4, t5]
128+ '[a1, a2, a3, a4, a5]) a where
129+ lensOf = lens p5_4 (\p a -> p{ p5_4 = a })
130+ {-# INLINE lensOf #-}
131+
132+instance a ~ a5 => HasLens t5
59− (Product (t2 ': ts) (b ': as))
133+ (Product
60− a
134+ '[t1, t2, t3, t4, t5]
61− b
135+ '[a1, a2, a3, a4, a5]) a where
62−productHead =
136+ lensOf = lens p5_5 (\p a -> p{ p5_5 = a })
63− lens
137+ {-# INLINE lensOf #-}
64− (\(Cons a _) -> a)
138+
65− (\(Cons _ as) a -> Cons a as)
139+data instance Product ts '[a1, a2, a3, a4, a5, a6, a7, a8, a9] =
140+ P9
141+ { p9_1 :: !a1
142+ , p9_2 :: !a2
143+ , p9_3 :: !a3
144+ , p9_4 :: !a4
145+ , p9_5 :: !a5
146+ , p9_6 :: !a6
147+ , p9_7 :: !a7
148+ , p9_8 :: !a8
149+ , p9_9 :: !a9
150+ } deriving (Generic)
151+
152+deriving instance
153+ ( Show a1
154+ , Show a2
155+ , Show a3
156+ , Show a4
157+ , Show a5
158+ , Show a6
159+ , Show a7
160+ , Show a8
161+ , Show a9
162+ ) => Show (Product ts '[a1, a2, a3, a4, a5, a6, a7, a8, a9])
163+
164+instance
165+ ( NFData a1
166+ , NFData a2
167+ , NFData a3
168+ , NFData a4
169+ , NFData a5
170+ , NFData a6
171+ , NFData a7
172+ , NFData a8
173+ , NFData a9
174+ ) => NFData (Product ts '[a1, a2, a3, a4, a5, a6, a7, a8, a9])
175+
176+instance a ~ a1 => HasLens t1
177+ (Product
178+ '[t1, t2, t3, t4, t5, t6, t7, t8, t9]
179+ '[a1, a2, a3, a4, a5, a6, a7, a8, a9]) a where
180+ lensOf = lens p9_1 (\p a -> p{ p9_1 = a })
181+ {-# INLINE lensOf #-}
182+
183+instance a ~ a2 => HasLens t2
184+ (Product
185+ '[t1, t2, t3, t4, t5, t6, t7, t8, t9]
186+ '[a1, a2, a3, a4, a5, a6, a7, a8, a9]) a where
187+ lensOf = lens p9_2 (\p a -> p{ p9_2 = a })
188+ {-# INLINE lensOf #-}
189+
190+instance a ~ a3 => HasLens t3
191+ (Product
192+ '[t1, t2, t3, t4, t5, t6, t7, t8, t9]
193+ '[a1, a2, a3, a4, a5, a6, a7, a8, a9]) a where
194+ lensOf = lens p9_3 (\p a -> p{ p9_3 = a })
195+ {-# INLINE lensOf #-}
196+
197+instance a ~ a4 => HasLens t4
198+ (Product
199+ '[t1, t2, t3, t4, t5, t6, t7, t8, t9]
200+ '[a1, a2, a3, a4, a5, a6, a7, a8, a9]) a where
201+ lensOf = lens p9_4 (\p a -> p{ p9_4 = a })
202+ {-# INLINE lensOf #-}
203+
204+instance a ~ a5 => HasLens t5
205+ (Product
206+ '[t1, t2, t3, t4, t5, t6, t7, t8, t9]
207+ '[a1, a2, a3, a4, a5, a6, a7, a8, a9]) a where
208+ lensOf = lens p9_5 (\p a -> p{ p9_5 = a })
209+ {-# INLINE lensOf #-}
210+
211+instance a ~ a6 => HasLens t6
212+ (Product
213+ '[t1, t2, t3, t4, t5, t6, t7, t8, t9]
214+ '[a1, a2, a3, a4, a5, a6, a7, a8, a9]) a where
215+ lensOf = lens p9_6 (\p a -> p{ p9_6 = a })
66−{-# INLINE productHead #-}
216+ {-# INLINE lensOf #-}
67−
217+
68−productTail ::
218+instance a ~ a7 => HasLens t7
69− Lens
219+ (Product
70− (Product (t ': ts1) (a ': as))
220+ '[t1, t2, t3, t4, t5, t6, t7, t8, t9]
71− (Product (t ': ts2) (a ': bs))
221+ '[a1, a2, a3, a4, a5, a6, a7, a8, a9]) a where
72− (Product ts1 as)
222+ lensOf = lens p9_7 (\p a -> p{ p9_7 = a })
73− (Product ts2 bs)
74−productTail =
75− lens
76− (\(Cons _ as) -> as)
77− (\(Cons a _) as -> Cons a as)
78−{-# INLINE productTail #-}
223+ {-# INLINE lensOf #-}
79−
224+
80−instance a ~ b => HasLens tag (Product (tag ': tags) (a ': as)) b where
225+instance a ~ a8 => HasLens t8
81− lensOf _ = productHead
226+ (Product
227+ '[t1, t2, t3, t4, t5, t6, t7, t8, t9]
228+ '[a1, a2, a3, a4, a5, a6, a7, a8, a9]) a where
229+ lensOf = lens p9_8 (\p a -> p{ p9_8 = a })
82− {-# INLINE lensOf #-}
230+ {-# INLINE lensOf #-}
83−
231+
84−instance {-# OVERLAPPABLE #-}
232+instance a ~ a9 => HasLens t9
85− ( HasLens tag (Product tags as) a
233+ (Product
86− ) => HasLens tag (Product (t ': tags) (b ': as)) a
234+ '[t1, t2, t3, t4, t5, t6, t7, t8, t9]
87− where
235+ '[a1, a2, a3, a4, a5, a6, a7, a8, a9]) a where
88− lensOf t = productTail . lensOf t
236+ lensOf = lens p9_9 (\p a -> p{ p9_9 = a })
89− {-# INLINE lensOf #-}
237+ {-# INLINE lensOf #-}
ether-flatten/src/Control/Monad/Ether/Reader/Flatten.hs+33−48
@@ -1,5 +1,3 @@
1−{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
2−
3{-# LANGUAGE RankNTypes #-}
1{-# LANGUAGE RankNTypes #-}
4{-# LANGUAGE TypeSynonymInstances #-}
2{-# LANGUAGE TypeSynonymInstances #-}
5{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
@@ -8,71 +6,58 @@
8{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE FlexibleInstances #-}
9{-# LANGUAGE GADTs #-}
7{-# LANGUAGE GADTs #-}
10{-# LANGUAGE TypeFamilies #-}
8{-# LANGUAGE TypeFamilies #-}
11−{-# LANGUAGE MagicHash #-}
12
9
13module Control.Monad.Ether.Reader.Flatten
10module Control.Monad.Ether.Reader.Flatten
14 ( runReader
11 ( runReader
15 , runReaderT
12 , runReaderT
16 ) where
13 ) where
17
14
18−import qualified Control.Monad.Trans.Lift.Local as Lift
19−
20import Data.Functor.Identity
15import Data.Functor.Identity
21import Control.Monad.Ether.Reader.Class as C
16import Control.Monad.Ether.Reader.Class as C
22−import Control.Monad.Trans.Ether.Dispatch
17+import Control.Monad.Trans.Ether.Handler
23−import qualified Control.Monad.Trans.Reader as T
18+import qualified Control.Monad.Reader as T
24import Control.Lens
19import Control.Lens
25import Control.Ether.Flatten
20import Control.Ether.Flatten
21+import Data.Coerce
26
22
27−data READER (ts :: [k])
23+data READER
28
24
29−type ReaderT ts r = Dispatch (READER ts) (T.ReaderT r)
25+type family READERS ts where
26+ READERS '[] = '[]
27+ READERS (t ': ts) = '(READER, t) ': READERS ts
30
28
31−type Reader ts r = ReaderT ts r Identity
29+type ReaderT ts r = Handler (READERS ts) (T.ReaderT r)
32
30
33−reflatten
31+type Reader ts r = ReaderT ts r Identity
34− :: forall tagsOld tagsNew r m a
35− . ReaderT tagsOld r m a
36− -> ReaderT tagsNew r m a
37−reflatten = repack
38−{-# INLINE reflatten #-}
39
32
40instance
33instance
41− ( Monad m, Monad (trans m)
34+ ( HasLens tag payload r
42− , Lift.MonadTrans trans
35+ , T.MonadReader payload (trans m) -- FIXME: (forall m . T.MonadReader payload (trans m))
43− , Lift.LiftLocal trans
44− , C.MonadReader tag r m
45− ) => C.MonadReader tag r (Dispatch (READER '[]) trans m)
36+ ) => C.MonadReader tag r (Handler ('(READER, tag) ': dps) trans (m :: * -> *))
46 where
37 where
47− ask t = Lift.lift (ask t)
48− local t = Lift.liftLocal (ask t) (local t)
49
38
50−instance
39+ ask =
51− ( Monad m, HasLens tag payload r
40+ (coerce :: forall dp a .
52− , trans ~ T.ReaderT payload
41+ trans m a ->
53− ) => C.MonadReader tag r (Dispatch (READER (tag ': tags)) trans m)
42+ Handler dp trans m a)
54− where
55− ask t = pack $ view (lensOf t)
43+ (view (lensOf @tag))
56 {-# INLINE ask #-}
44 {-# INLINE ask #-}
57− local t f = pack . T.local (over (lensOf t) f) . unpack
58− {-# INLINE local #-}
59
45
60−instance {-# OVERLAPPABLE #-}
46+ local f =
61− ( Monad m
47+ (coerce :: forall dp a .
62− , C.MonadReader tag r (Dispatch (READER tags) trans m)
48+ (trans m a -> trans m a) ->
63− , trans ~ T.ReaderT payload
49+ (Handler dp trans m a -> Handler dp trans m a))
64− ) => C.MonadReader tag r (Dispatch (READER (t ': tags)) trans m)
50+ (T.local (lensOf @tag %~ f))
65− where
66− ask t = reflatten @tags @(t ': tags) (C.ask t)
67− {-# INLINE ask #-}
68− local t f
69− = reflatten @tags @(t ': tags)
70− . C.local t f
71− . reflatten @(t ': tags) @tags
72 {-# INLINE local #-}
51 {-# INLINE local #-}
73
52
53+runReaderT
74−runReaderT :: ReaderT tags (Product tags as) m a -> Product tags as -> m a
54+ :: ReaderT tags (Product tags as) m a
55+ -> Product tags as
56+ -> m a
75−runReaderT m = T.runReaderT (unpack m)
57+runReaderT m = T.runReaderT (coerce m)
76−
58+
59+runReader
77−runReader :: Reader tags (Product tags as) a -> Product tags as -> a
60+ :: Reader tags (Product tags as) a
61+ -> Product tags as
62+ -> a
78−runReader m = T.runReader (unpack m)
63+runReader m = T.runReader (coerce m)
ether-flatten/src/Control/Monad/Ether/State/Flatten.hs+31−42
@@ -1,5 +1,3 @@
1−{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
2−
3{-# LANGUAGE RankNTypes #-}
1{-# LANGUAGE RankNTypes #-}
4{-# LANGUAGE TypeSynonymInstances #-}
2{-# LANGUAGE TypeSynonymInstances #-}
5{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
@@ -8,74 +6,65 @@
8{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE FlexibleInstances #-}
9{-# LANGUAGE GADTs #-}
7{-# LANGUAGE GADTs #-}
10{-# LANGUAGE TypeFamilies #-}
8{-# LANGUAGE TypeFamilies #-}
11−{-# LANGUAGE MagicHash #-}
12
9
13module Control.Monad.Ether.State.Flatten
10module Control.Monad.Ether.State.Flatten
14 ( runState
11 ( runState
15 , runStateT
12 , runStateT
16 ) where
13 ) where
17
14
18−import qualified Control.Monad.Trans.Class as Lift
19−
20import Data.Functor.Identity
15import Data.Functor.Identity
21import Control.Monad.Ether.State.Class as C
16import Control.Monad.Ether.State.Class as C
22−import Control.Monad.Trans.Ether.Dispatch
17+import Control.Monad.Trans.Ether.Handler
23−import qualified Control.Monad.Trans.State as T
18+import qualified Control.Monad.State as T
24import Control.Lens
19import Control.Lens
25import Control.Ether.Flatten
20import Control.Ether.Flatten
21+import Data.Coerce
26
22
27−data STATE (ts :: [k])
23+data STATE
28−
29−type StateT ts s = Dispatch (STATE ts) (T.StateT s)
30
24
31−type State ts s = StateT ts s Identity
25+type family STATES ts where
26+ STATES '[] = '[]
27+ STATES (t ': ts) = '(STATE, t) ': STATES ts
32
28
33−reflatten
29+type StateT ts s = Handler (STATES ts) (T.StateT s)
34− :: forall tagsOld tagsNew s m a
35− . StateT tagsOld s m a
36− -> StateT tagsNew s m a
37−reflatten = repack
38−{-# INLINE reflatten #-}
39
30
40−instance
31+type State ts s = StateT ts s Identity
41− ( Monad m, Monad (trans m)
42− , Lift.MonadTrans trans
43− , C.MonadState tag s m
44− ) => C.MonadState tag s (Dispatch (STATE '[]) trans m)
45− where
46− get t = Lift.lift (get t)
47− put t = Lift.lift . put t
48− state t = Lift.lift . state t
49
32
50instance
33instance
51 ( Monad m, HasLens tag payload s
34 ( Monad m, HasLens tag payload s
52− , trans ~ T.StateT payload
35+ , T.MonadState payload (trans m) -- FIXME: (forall m . T.MonadState payload (trans m))
53− ) => C.MonadState tag s (Dispatch (STATE (tag ': tags)) trans m)
36+ ) => C.MonadState tag s (Handler ('(STATE, tag) ': dps) trans m)
54 where
37 where
55− get t = pack $ use (lensOf t)
56− {-# INLINE get #-}
57− put t s = pack $ zoom (lensOf t) (T.put s)
58− {-# INLINE put #-}
59
38
60−instance {-# OVERLAPPABLE #-}
39+ get =
61− ( Monad m
40+ (coerce :: forall dp a .
62− , C.MonadState tag s (Dispatch (STATE tags) trans m)
41+ trans m a ->
63− , trans ~ T.StateT payload
42+ Handler dp trans m a)
64− ) => C.MonadState tag s (Dispatch (STATE (t ': tags)) trans m)
43+ (use (lensOf @tag))
65− where
66− get t = reflatten @tags @(t ': tags) (C.get t)
67 {-# INLINE get #-}
44 {-# INLINE get #-}
68− put t = reflatten @tags @(t ': tags) . C.put t
45+
46+ put s =
47+ (coerce :: forall dp a .
48+ trans m a ->
49+ Handler dp trans m a)
50+ (T.modify (lensOf @tag .~ s))
69 {-# INLINE put #-}
51 {-# INLINE put #-}
70
52
53+ state f =
54+ (coerce :: forall dp a .
55+ trans m a ->
56+ Handler dp trans m a)
57+ (T.state (lensOf @tag f))
58+ {-# INLINE state #-}
59+
71runStateT
60runStateT
72 :: StateT tags (Product tags as) m a
61 :: StateT tags (Product tags as) m a
73 -> Product tags as
62 -> Product tags as
74 -> m (a, Product tags as)
63 -> m (a, Product tags as)
75−runStateT m = T.runStateT (unpack m)
64+runStateT m = T.runStateT (coerce m)
76
65
77runState
66runState
78 :: State tags (Product tags as) a
67 :: State tags (Product tags as) a
79 -> Product tags as
68 -> Product tags as
80 -> (a, Product tags as)
69 -> (a, Product tags as)
81−runState m = T.runState (unpack m)
70+runState m = T.runState (coerce m)
ether-suite/bench/Bench.hs+116−113
@@ -3,6 +3,7 @@
3{-# LANGUAGE FunctionalDependencies #-}
3{-# LANGUAGE FunctionalDependencies #-}
4{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE DataKinds #-}
5{-# LANGUAGE DataKinds #-}
6+{-# LANGUAGE TypeOperators #-}
6
7
7module Main (main) where
8module Main (main) where
8
9
@@ -15,61 +16,66 @@ import qualified Control.Monad.Ether.Reader.Flatten as E.F
15import qualified Control.Monad.Ether.State.Flatten as E.F
16import qualified Control.Monad.Ether.State.Flatten as E.F
16import Control.Ether.Flatten
17import Control.Ether.Flatten
17import qualified Control.Lens as L
18import qualified Control.Lens as L
19+import Control.DeepSeq
18
20
19−readerSummatorMTL_flat_9
21+id' :: a -> a
22+id' = id
23+{-# NOINLINE id' #-}
24+
25+readerCombinerMTL_flat_9
20 :: M.MonadReader (Int, Int, Int, Int, Int, Int, Int, Int, Int) m
26 :: M.MonadReader (Int, Int, Int, Int, Int, Int, Int, Int, Int) m
21− => m String
27+ => m ()
22−readerSummatorMTL_flat_9 = do
28+readerCombinerMTL_flat_9 = do
23− concat <$> sequenceA
29+ rnf <$> sequenceA
24− [ show <$> L.view L._1
30+ [ L.view L._1
25− , show <$> L.view L._2
31+ , L.view L._2
26− , show <$> L.view L._3
32+ , L.view L._3
27− , show <$> L.view L._4
33+ , L.view L._4
28− , show <$> L.view L._5
34+ , L.view L._5
29− , show <$> L.view L._6
35+ , L.view L._6
30− , show <$> L.view L._7
36+ , L.view L._7
31− , show <$> L.view L._8
37+ , L.view L._8
32− , show <$> L.view L._9 ]
38+ , L.view L._9 ]
33−{-# NOINLINE readerSummatorMTL_flat_9 #-}
39+{-# NOINLINE readerCombinerMTL_flat_9 #-}
34−
40+
35−stateSummatorMTL_flat_9
41+stateCombinerMTL_flat_9
36 :: M.MonadState (Int, Int, Int, Int, Int, Int, Int, Int, Int) m
42 :: M.MonadState (Int, Int, Int, Int, Int, Int, Int, Int, Int) m
37− => m String
43+ => m ()
38−stateSummatorMTL_flat_9 = do
44+stateCombinerMTL_flat_9 = do
39− M.modify (L.over L._1 (+1))
45+ M.modify (L.over L._1 id')
40− M.modify (L.over L._2 (+2))
46+ M.modify (L.over L._2 id')
41− M.modify (L.over L._3 (+3))
47+ M.modify (L.over L._3 id')
42− M.modify (L.over L._4 (+4))
48+ M.modify (L.over L._4 id')
43− M.modify (L.over L._5 (+5))
49+ M.modify (L.over L._5 id')
44− M.modify (L.over L._6 (+6))
50+ M.modify (L.over L._6 id')
45− M.modify (L.over L._7 (+7))
51+ M.modify (L.over L._7 id')
46− M.modify (L.over L._8 (+8))
52+ M.modify (L.over L._8 id')
47− M.modify (L.over L._9 (+9))
53+ M.modify (L.over L._9 id')
48− concat <$> sequenceA
54+ rnf <$> sequenceA
49− [ show <$> L.use L._1
55+ [ L.use L._1
50− , show <$> L.use L._2
56+ , L.use L._2
51− , show <$> L.use L._3
57+ , L.use L._3
52− , show <$> L.use L._4
58+ , L.use L._4
53− , show <$> L.use L._5
59+ , L.use L._5
54− , show <$> L.use L._6
60+ , L.use L._6
55− , show <$> L.use L._7
61+ , L.use L._7
56− , show <$> L.use L._8
62+ , L.use L._8
57− , show <$> L.use L._9 ]
63+ , L.use L._9 ]
58−{-# NOINLINE stateSummatorMTL_flat_9 #-}
64+{-# NOINLINE stateCombinerMTL_flat_9 #-}
59−
65+
60−run_readerSummatorMTL_flat_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> String
66+run_readerCombinerMTL_flat_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> ()
61−run_readerSummatorMTL_flat_9
67+run_readerCombinerMTL_flat_9
62 (a1, a2, a3, a4, a5, a6, a7, a8, a9) =
68 (a1, a2, a3, a4, a5, a6, a7, a8, a9) =
63− M.runReader readerSummatorMTL_flat_9 (a9, a8, a7, a6, a5, a4, a3, a2, a1)
69+ M.runReader readerCombinerMTL_flat_9 (a9, a8, a7, a6, a5, a4, a3, a2, a1)
64
70
65−run_stateSummatorMTL_flat_9 ::
71+run_stateCombinerMTL_flat_9 ::
66 (Int, Int, Int, Int, Int, Int, Int, Int, Int) ->
72 (Int, Int, Int, Int, Int, Int, Int, Int, Int) ->
67− (String, (Int, Int, Int, Int, Int, Int, Int, Int, Int))
73+ ((), (Int, Int, Int, Int, Int, Int, Int, Int, Int))
68−run_stateSummatorMTL_flat_9
74+run_stateCombinerMTL_flat_9
69 (a1, a2, a3, a4, a5, a6, a7, a8, a9) =
75 (a1, a2, a3, a4, a5, a6, a7, a8, a9) =
70− M.runState stateSummatorMTL_flat_9 (a9, a8, a7, a6, a5, a4, a3, a2, a1)
76+ M.runState stateCombinerMTL_flat_9 (a9, a8, a7, a6, a5, a4, a3, a2, a1)
71
77
72−readerSummatorEther_sep_9
78+readerCombinerEther_sep_9
73 :: ( E.MonadReader 1 Int m
79 :: ( E.MonadReader 1 Int m
74 , E.MonadReader 2 Int m
80 , E.MonadReader 2 Int m
75 , E.MonadReader 3 Int m
81 , E.MonadReader 3 Int m
@@ -79,20 +85,20 @@ readerSummatorEther_sep_9
79 , E.MonadReader 7 Int m
85 , E.MonadReader 7 Int m
80 , E.MonadReader 8 Int m
86 , E.MonadReader 8 Int m
81 , E.MonadReader 9 Int m )
87 , E.MonadReader 9 Int m )
82− => m String
88+ => m ()
83−readerSummatorEther_sep_9 = concat <$> sequenceA
89+readerCombinerEther_sep_9 = rnf <$> sequenceA
84− [ show <$> E.ask @1
90+ [ E.ask @1
85− , show <$> E.ask @2
91+ , E.ask @2
86− , show <$> E.ask @3
92+ , E.ask @3
87− , show <$> E.ask @4
93+ , E.ask @4
88− , show <$> E.ask @5
94+ , E.ask @5
89− , show <$> E.ask @6
95+ , E.ask @6
90− , show <$> E.ask @7
96+ , E.ask @7
91− , show <$> E.ask @8
97+ , E.ask @8
92− , show <$> E.ask @9 ]
98+ , E.ask @9 ]
93−{-# NOINLINE readerSummatorEther_sep_9 #-}
99+{-# NOINLINE readerCombinerEther_sep_9 #-}
94−
100+
95−stateSummatorEther_sep_9
101+stateCombinerEther_sep_9
96 :: ( E.MonadState 1 Int m
102 :: ( E.MonadState 1 Int m
97 , E.MonadState 2 Int m
103 , E.MonadState 2 Int m
98 , E.MonadState 3 Int m
104 , E.MonadState 3 Int m
@@ -102,30 +108,30 @@ stateSummatorEther_sep_9
102 , E.MonadState 7 Int m
108 , E.MonadState 7 Int m
103 , E.MonadState 8 Int m
109 , E.MonadState 8 Int m
104 , E.MonadState 9 Int m )
110 , E.MonadState 9 Int m )
105− => m String
111+ => m ()
106−stateSummatorEther_sep_9 = do
112+stateCombinerEther_sep_9 = do
107− E.modify @1 (+1)
113+ E.modify @1 id'
108− E.modify @2 (+2)
114+ E.modify @2 id'
109− E.modify @3 (+3)
115+ E.modify @3 id'
110− E.modify @4 (+4)
116+ E.modify @4 id'
111− E.modify @5 (+5)
117+ E.modify @5 id'
112− E.modify @6 (+6)
118+ E.modify @6 id'
113− E.modify @7 (+7)
119+ E.modify @7 id'
114− E.modify @8 (+8)
120+ E.modify @8 id'
115− E.modify @9 (+9)
121+ E.modify @9 id'
116− concat <$> sequenceA
122+ rnf <$> sequenceA
117− [ show <$> E.get @1
123+ [ E.get @1
118− , show <$> E.get @2
124+ , E.get @2
119− , show <$> E.get @3
125+ , E.get @3
120− , show <$> E.get @4
126+ , E.get @4
121− , show <$> E.get @5
127+ , E.get @5
122− , show <$> E.get @6
128+ , E.get @6
123− , show <$> E.get @7
129+ , E.get @7
124− , show <$> E.get @8
130+ , E.get @8
125− , show <$> E.get @9 ]
131+ , E.get @9 ]
126−
132+
127−run_readerSummatorEther_nested_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> String
133+run_readerCombinerEther_nested_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> ()
128−run_readerSummatorEther_nested_9
134+run_readerCombinerEther_nested_9
129 (a1, a2, a3, a4, a5, a6, a7, a8, a9)
135 (a1, a2, a3, a4, a5, a6, a7, a8, a9)
130 = flip (E.runReader @9) a1
136 = flip (E.runReader @9) a1
131 . flip (E.runReaderT @8) a2
137 . flip (E.runReaderT @8) a2
@@ -136,36 +142,33 @@ run_readerSummatorEther_nested_9
136 . flip (E.runReaderT @3) a7
142 . flip (E.runReaderT @3) a7
137 . flip (E.runReaderT @2) a8
143 . flip (E.runReaderT @2) a8
138 . flip (E.runReaderT @1) a9
144 . flip (E.runReaderT @1) a9
139− $ readerSummatorEther_sep_9
145+ $ readerCombinerEther_sep_9
140
146
141−run_readerSummatorEther_flatten_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> String
147+run_readerCombinerEther_flatten_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> ()
142−run_readerSummatorEther_flatten_9
148+run_readerCombinerEther_flatten_9
143 (a1, a2, a3, a4, a5, a6, a7, a8, a9)
149 (a1, a2, a3, a4, a5, a6, a7, a8, a9)
144 =
150 =
145− E.F.runReader
151+ E.F.runReader @'[1,2,3,4,5,6,7,8,9]
146− readerSummatorEther_sep_9
152+ readerCombinerEther_sep_9
147− ( load @1 a9 <+> load @2 a8 <+> load @3 a7 <+> load @4 a6 <+>
153+ (P9 a9 a8 a7 a6 a5 a4 a3 a2 a1)
148− load @5 a5 <+> load @6 a4 <+> load @7 a3 <+> load @8 a2 <+>
154+
149− load @9 a1 )
155+
150−
151−run_readerSummatorEther_flattenhalf_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> String
156+run_readerCombinerEther_flattenhalf_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> ()
152−run_readerSummatorEther_flattenhalf_9
157+run_readerCombinerEther_flattenhalf_9
153 (a1, a2, a3, a4, a5, a6, a7, a8, a9)
158 (a1, a2, a3, a4, a5, a6, a7, a8, a9)
154− = flip E.F.runReader (load @1 a9 <+> load @2 a8 <+> load @3 a7 <+> load @4 a6)
159+ = flip (E.F.runReader @'[1,2,3,4]) (P4 a9 a8 a7 a6)
155− . flip E.F.runReaderT (load @5 a5 <+> load @6 a4 <+> load @7 a3 <+> load @8 a2 <+> load @9 a1)
160+ . flip (E.F.runReaderT @'[5,6,7,8,9]) (P5 a5 a4 a3 a2 a1)
156− $ readerSummatorEther_sep_9
161+ $ readerCombinerEther_sep_9
157
162
158−run_stateSummatorEther_flatten_9 ::
163+run_stateCombinerEther_flatten_9 ::
159 (Int, Int, Int, Int, Int, Int, Int, Int, Int) ->
164 (Int, Int, Int, Int, Int, Int, Int, Int, Int) ->
160− (String, Product '[1,2,3,4,5,6,7,8,9] '[Int,Int,Int,Int,Int,Int,Int,Int,Int])
165+ ((), Product '[1,2,3,4,5,6,7,8,9] '[Int,Int,Int,Int,Int,Int,Int,Int,Int])
161−run_stateSummatorEther_flatten_9
166+run_stateCombinerEther_flatten_9
162 (a1, a2, a3, a4, a5, a6, a7, a8, a9)
167 (a1, a2, a3, a4, a5, a6, a7, a8, a9)
163 =
168 =
164 E.F.runState
169 E.F.runState
165− stateSummatorEther_sep_9
170+ stateCombinerEther_sep_9
166− ( load @1 a9 <+> load @2 a8 <+> load @3 a7 <+> load @4 a6 <+>
171+ (P9 a9 a8 a7 a6 a5 a4 a3 a2 a1)
167− load @5 a5 <+> load @6 a4 <+> load @7 a3 <+> load @8 a2 <+>
168− load @9 a1 )
169
172
170tuple_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int)
173tuple_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int)
171tuple_9 = (1, -2, 3, -4, 5, -6, 7, -8, 9)
174tuple_9 = (1, -2, 3, -4, 5, -6, 7, -8, 9)
@@ -173,11 +176,11 @@ tuple_9 = (1, -2, 3, -4, 5, -6, 7, -8, 9)
173main :: IO ()
176main :: IO ()
174main = do
177main = do
175 defaultMain
178 defaultMain
176− [ bench "readerSummatorMTL_flat_9" $ nf run_readerSummatorMTL_flat_9 tuple_9
179+ [ bench "readerCombinerMTL_flat_9" $ nf run_readerCombinerMTL_flat_9 tuple_9
177− , bench "readerSummatorEther_nested_9" $ nf run_readerSummatorEther_nested_9 tuple_9
180+ , bench "readerCombinerEther_nested_9" $ nf run_readerCombinerEther_nested_9 tuple_9
178− , bench "readerSummatorEther_flatten_9" $ nf run_readerSummatorEther_flatten_9 tuple_9
181+ , bench "readerCombinerEther_flatten_9" $ nf run_readerCombinerEther_flatten_9 tuple_9
179− , bench "readerSummatorEther_flattenhalf_9" $
182+ , bench "readerCombinerEther_flattenhalf_9" $
180− nf run_readerSummatorEther_flattenhalf_9 tuple_9
183+ nf run_readerCombinerEther_flattenhalf_9 tuple_9
181− , bench "stateSummatorMTL_flat_9" $ nf run_stateSummatorMTL_flat_9 tuple_9
184+ , bench "stateCombinerMTL_flat_9" $ nf run_stateCombinerMTL_flat_9 tuple_9
182− , bench "stateSummatorEther_flatten_9" $ nf run_stateSummatorEther_flatten_9 tuple_9
185+ , bench "stateCombinerEther_flatten_9" $ nf run_stateCombinerEther_flatten_9 tuple_9
183 ]
186 ]
ether-suite/ether-suite.cabal+1
@@ -57,6 +57,7 @@ benchmark bench
57 , mtl >=2.2.1
57 , mtl >=2.2.1
58 , transformers >=0.4.2
58 , transformers >=0.4.2
59 , criterion >=1.1
59 , criterion >=1.1
60+ , deepseq >=1.4
60 , lens >=4.14
61 , lens >=4.14
61 , ether
62 , ether
62 , ether-flatten
63 , ether-flatten
ether-zoom/ether-zoom.cabal+1−1
@@ -37,4 +37,4 @@ library
37 TypeApplications
37 TypeApplications
38
38
39 hs-source-dirs: src
39 hs-source-dirs: src
40− ghc-options: -Wall
40+ ghc-options: -Wall -O2
ether-zoom/src/Control/Monad/Ether/State/Zoom.hs+12−7
@@ -16,15 +16,16 @@ module Control.Monad.Ether.State.Zoom
16
16
17import Control.Lens
17import Control.Lens
18import Data.Reflection
18import Data.Reflection
19−import Control.Monad.Trans.Ether.Dispatch
19+import Control.Monad.Trans.Ether.Handler
20import Control.Monad.Trans.Identity
20import Control.Monad.Trans.Identity
21import Control.Monad.Ether.State.Class
21import Control.Monad.Ether.State.Class
22import Data.Proxy
22import Data.Proxy
23+import Data.Coerce
23
24
24-- | Encode type-level information for 'tagZoom'.
25-- | Encode type-level information for 'tagZoom'.
25data TAG_ZOOM t z
26data TAG_ZOOM t z
26
27
27−type TagZoomT t (z :: *) = Dispatch (TAG_ZOOM t z) IdentityT
28+type TagZoomT t (z :: *) = Handler (TAG_ZOOM t z) IdentityT
28
29
29-- | Zoom into a part of a state using a lens.
30-- | Zoom into a part of a state using a lens.
30tagZoom
31tagZoom
@@ -32,14 +33,18 @@ tagZoom
32 . Lens' sOuter sInner
33 . Lens' sOuter sInner
33 -> (forall z . Reifies z (ReifiedLens' sOuter sInner) => TagZoomT tag z m a)
34 -> (forall z . Reifies z (ReifiedLens' sOuter sInner) => TagZoomT tag z m a)
34 -> m a
35 -> m a
35−tagZoom l m = reify (Lens l) (\(_ :: Proxy z) -> (runIdentityT . unpack) (m @z))
36+tagZoom l m = reify (Lens l) (\(_ :: Proxy z) -> coerce (m @z))
36
37
37instance
38instance
38 ( MonadState tag sOuter m
39 ( MonadState tag sOuter m
39 , Reifies z (ReifiedLens' sOuter sInner)
40 , Reifies z (ReifiedLens' sOuter sInner)
40 , trans ~ IdentityT
41 , trans ~ IdentityT
41− ) => MonadState tag sInner (Dispatch (TAG_ZOOM tag z) trans m)
42+ ) => MonadState tag sInner (Handler (TAG_ZOOM tag z) trans m)
42 where
43 where
43− state t =
44+ state =
45+ (coerce :: forall dp r a .
46+ (r -> m a) ->
47+ (r -> Handler dp trans m a))
48+ (state @tag . l)
49+ where
44− let Lens l = reflect (Proxy :: Proxy z)
50+ Lens l = reflect (Proxy :: Proxy z)
45− in pack . IdentityT . state t . l
ether/ether.cabal+2−3
@@ -28,7 +28,7 @@ library
28
28
29 exposed-modules: Control.Ether.Abbr
29 exposed-modules: Control.Ether.Abbr
30 Control.Ether.Implicit.Abbr
30 Control.Ether.Implicit.Abbr
31− Control.Monad.Trans.Ether.Dispatch
31+ Control.Monad.Trans.Ether.Handler
32 Control.Monad.Ether
32 Control.Monad.Ether
33 Control.Monad.Ether.TagAttach
33 Control.Monad.Ether.TagAttach
34 Control.Monad.Ether.TagReplace
34 Control.Monad.Ether.TagReplace
@@ -73,10 +73,9 @@ library
73 DeriveGeneric
73 DeriveGeneric
74 FlexibleInstances
74 FlexibleInstances
75 GeneralizedNewtypeDeriving
75 GeneralizedNewtypeDeriving
76− MagicHash
77 TypeFamilies
76 TypeFamilies
78 TypeOperators
77 TypeOperators
79 UndecidableInstances
78 UndecidableInstances
80
79
81 hs-source-dirs: src
80 hs-source-dirs: src
82− ghc-options: -Wall
81+ ghc-options: -Wall -O2
ether/src/Control/Monad/Ether.hs−1
@@ -1,4 +1,3 @@
1−
2-- | This module provides convenience exports of all
1-- | This module provides convenience exports of all
3-- tagged monad classes from Ether.
2-- tagged monad classes from Ether.
4
3
ether/src/Control/Monad/Ether/Except.hs+21−26
@@ -1,11 +1,8 @@
1−{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
2−
3{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE UndecidableInstances #-}
3{-# LANGUAGE UndecidableInstances #-}
6{-# LANGUAGE TypeFamilies #-}
4{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE AllowAmbiguousTypes #-}
5{-# LANGUAGE AllowAmbiguousTypes #-}
8−{-# LANGUAGE MagicHash #-}
9
6
10-- | See "Control.Monad.Except".
7-- | See "Control.Monad.Except".
11
8
@@ -27,21 +24,12 @@ module Control.Monad.Ether.Except
27 , handle
24 , handle
28 ) where
25 ) where
29
26
30−import GHC.Prim (Proxy#, proxy#)
31−import Control.Monad.Ether.Except.Class (MonadExcept)
27+import Control.Monad.Ether.Except.Class
32−import qualified Control.Monad.Ether.Except.Class as C
28+import qualified Control.Monad.Trans.Ether.Handler as D
33−import qualified Control.Monad.Trans.Ether.Dispatch as D
34−import qualified Control.Monad.Trans.Except as T
29+import qualified Control.Monad.Except as T
30+import Control.Monad.Signatures (Catch)
35import Data.Functor.Identity
31import Data.Functor.Identity
36−
32+import Data.Coerce
37−-- | Is used within a monadic computation to begin exception processing.
38−throw :: forall tag e m a . MonadExcept tag e m => e -> m a
39−throw = C.throw (proxy# :: Proxy# tag)
40−
41−-- | A handler function to handle previous exceptions and return to
42−-- normal execution.
43−catch :: forall tag e m a . MonadExcept tag e m => m a -> (e -> m a) -> m a
44−catch = C.catch (proxy# :: Proxy# tag)
45
33
46-- | Runs an 'Except' and handles the exception with the given function.
34-- | Runs an 'Except' and handles the exception with the given function.
47handle :: forall tag e a . (e -> a) -> Except tag e a -> a
35handle :: forall tag e a . (e -> a) -> Except tag e a -> a
@@ -52,7 +40,7 @@ handleT :: forall tag e m a . Functor m => (e -> a) -> ExceptT tag e m a -> m a
52handleT h m = fmap (either h id) (runExceptT @tag m)
40handleT h m = fmap (either h id) (runExceptT @tag m)
53
41
54-- | Encode type-level information for 'ExceptT'.
42-- | Encode type-level information for 'ExceptT'.
55−data EXCEPT t e
43+data EXCEPT
56
44
57-- | The parameterizable exception monad.
45-- | The parameterizable exception monad.
58--
46--
@@ -66,23 +54,30 @@ type Except tag e = ExceptT tag e Identity
66--
54--
67-- The 'return' function returns a normal value, while '>>=' exits on
55-- The 'return' function returns a normal value, while '>>=' exits on
68-- the first exception.
56-- the first exception.
69−type ExceptT tag e = D.Dispatch (EXCEPT tag e) (T.ExceptT e)
57+type ExceptT tag e = D.Handler '(EXCEPT, tag) (T.ExceptT e)
70
58
71-- | Runs an 'Except' and returns either an exception or a normal value.
59-- | Runs an 'Except' and returns either an exception or a normal value.
72runExcept :: forall tag e a . Except tag e a -> Either e a
60runExcept :: forall tag e a . Except tag e a -> Either e a
73−runExcept = T.runExcept . D.unpack
61+runExcept = coerce (T.runExcept @e @a)
74
62
75-- | Runs an 'ExceptT' and returns either an exception or a normal value.
63-- | Runs an 'ExceptT' and returns either an exception or a normal value.
76runExceptT :: forall tag e m a . ExceptT tag e m a -> m (Either e a)
64runExceptT :: forall tag e m a . ExceptT tag e m a -> m (Either e a)
77−runExceptT = T.runExceptT . D.unpack
65+runExceptT = coerce (T.runExceptT @e @m @a)
78
66
79-- | Constructor for computations in the exception monad transformer.
67-- | Constructor for computations in the exception monad transformer.
80exceptT :: forall tag e m a . m (Either e a) -> ExceptT tag e m a
68exceptT :: forall tag e m a . m (Either e a) -> ExceptT tag e m a
81−exceptT = D.pack . T.ExceptT
69+exceptT = coerce (T.ExceptT @e @m @a)
82
70
83instance
71instance
84− ( Monad m, e ~ e', trans ~ T.ExceptT e
72+ ( T.MonadError e (trans m) -- FIXME: (forall m . T.MonadError e (trans m))
85− ) => MonadExcept tag e (D.Dispatch (EXCEPT tag e') trans m)
73+ ) => MonadExcept tag e (D.Handler '(EXCEPT, tag) trans (m :: * -> *))
86 where
74 where
87− throw _ = D.pack . T.throwE
75+ throw =
88− catch _ m h = D.pack $ T.catchE (D.unpack m) (D.unpack . h)
76+ coerce (T.throwError @e @(trans m) @a) ::
77+ forall dp a . e -> D.Handler dp trans m a
78+ {-# INLINE throw #-}
79+
80+ catch =
81+ coerce (T.catchError @e @(trans m) @a) ::
82+ forall dp a . Catch e (D.Handler dp trans m) a
83+ {-# INLINE catch #-}
ether/src/Control/Monad/Ether/Except/Class.hs+5−6
@@ -1,7 +1,7 @@
1{-# LANGUAGE FlexibleInstances #-}
1{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE UndecidableInstances #-}
2{-# LANGUAGE UndecidableInstances #-}
3{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE TypeFamilies #-}
4−{-# LANGUAGE MagicHash #-}
4+{-# LANGUAGE AllowAmbiguousTypes #-}
5
5
6-- | See "Control.Monad.Except".
6-- | See "Control.Monad.Except".
7
7
@@ -9,23 +9,22 @@ module Control.Monad.Ether.Except.Class
9 ( MonadExcept(..)
9 ( MonadExcept(..)
10 ) where
10 ) where
11
11
12−import GHC.Prim (Proxy#)
13import qualified Control.Monad.Trans.Lift.Catch as Lift
12import qualified Control.Monad.Trans.Lift.Catch as Lift
14
13
15-- | See 'Control.Monad.Except.MonadError'.
14-- | See 'Control.Monad.Except.MonadError'.
16class Monad m => MonadExcept tag e m | m tag -> e where
15class Monad m => MonadExcept tag e m | m tag -> e where
17
16
18 -- | Is used within a monadic computation to begin exception processing.
17 -- | Is used within a monadic computation to begin exception processing.
19− throw :: Proxy# tag -> e -> m a
18+ throw :: e -> m a
20
19
21 -- | A handler function to handle previous exceptions and return to
20 -- | A handler function to handle previous exceptions and return to
22 -- normal execution.
21 -- normal execution.
23− catch :: Proxy# tag -> m a -> (e -> m a) -> m a
22+ catch :: m a -> (e -> m a) -> m a
24
23
25instance {-# OVERLAPPABLE #-}
24instance {-# OVERLAPPABLE #-}
26 ( Lift.LiftCatch t
25 ( Lift.LiftCatch t
27 , Monad (t m)
26 , Monad (t m)
28 , MonadExcept tag e m
27 , MonadExcept tag e m
29 ) => MonadExcept tag e (t m) where
28 ) => MonadExcept tag e (t m) where
30− throw t = Lift.lift . throw t
29+ throw = Lift.lift . throw @tag
31− catch t = Lift.liftCatch (catch t)
30+ catch = Lift.liftCatch (catch @tag)
ether/src/Control/Monad/Ether/Implicit.hs−1
@@ -1,4 +1,3 @@
1−
2-- | This module provides convenience exports of all
1-- | This module provides convenience exports of all
3-- implicitly tagged monad classes from Ether.
2-- implicitly tagged monad classes from Ether.
4
3
ether/src/Control/Monad/Ether/Implicit/State.hs−1
@@ -1,4 +1,3 @@
1−
2-- | See "Control.Monad.Ether.State".
1-- | See "Control.Monad.Ether.State".
3
2
4module Control.Monad.Ether.Implicit.State
3module Control.Monad.Ether.Implicit.State
ether/src/Control/Monad/Ether/Reader.hs+32−43
@@ -1,11 +1,8 @@
1−{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
2−
3{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE UndecidableInstances #-}
3{-# LANGUAGE UndecidableInstances #-}
6{-# LANGUAGE TypeFamilies #-}
4{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE AllowAmbiguousTypes #-}
5{-# LANGUAGE AllowAmbiguousTypes #-}
8−{-# LANGUAGE MagicHash #-}
9
6
10-- | See "Control.Monad.Reader".
7-- | See "Control.Monad.Reader".
11
8
@@ -26,36 +23,12 @@ module Control.Monad.Ether.Reader
26 , runReaderT
23 , runReaderT
27 ) where
24 ) where
28
25
29−import GHC.Prim (Proxy#, proxy#)
30−import Control.Monad.Ether.Reader.Class (MonadReader)
26+import Control.Monad.Ether.Reader.Class
31−import qualified Control.Monad.Ether.Reader.Class as C
27+import qualified Control.Monad.Trans.Ether.Handler as D
32−import qualified Control.Monad.Trans.Ether.Dispatch as D
28+import Control.Monad.Trans.Lift.Local (Local)
33−import qualified Control.Monad.Trans.Reader as T
29+import qualified Control.Monad.Reader as T
34import Data.Functor.Identity
30import Data.Functor.Identity
35−
31+import Data.Coerce
36−-- | Retrieves the monad environment.
37−ask :: forall tag r m . MonadReader tag r m => m r
38−ask = C.ask (proxy# :: Proxy# tag)
39−
40−-- | Executes a computation in a modified environment.
41−local
42− :: forall tag r m a
43− . MonadReader tag r m
44− => (r -> r)
45− -- ^ The function to modify the environment.
46− -> m a
47− -- ^ @Reader@ to run in the modified environment.
48− -> m a
49−local = C.local (proxy# :: Proxy# tag)
50−
51−-- | Retrieves a function of the current environment.
52−reader
53− :: forall tag r m a
54− . MonadReader tag r m
55− => (r -> a)
56− -- ^ The selector function to apply to the environment.
57− -> m a
58−reader = C.reader (proxy# :: Proxy# tag)
59
32
60-- | Retrieves a function of the current environment.
33-- | Retrieves a function of the current environment.
61asks
34asks
@@ -64,10 +37,11 @@ asks
64 => (r -> a)
37 => (r -> a)
65 -- ^ The selector function to apply to the environment.
38 -- ^ The selector function to apply to the environment.
66 -> m a
39 -> m a
67−asks = C.reader (proxy# :: Proxy# tag)
40+asks = reader @tag
41+{-# INLINE asks #-}
68
42
69-- | Encode type-level information for 'ReaderT'.
43-- | Encode type-level information for 'ReaderT'.
70−data READER t r
44+data READER
71
45
72-- | The parameterizable reader monad.
46-- | The parameterizable reader monad.
73--
47--
@@ -82,26 +56,41 @@ type Reader tag r = ReaderT tag r Identity
82--
56--
83-- The 'return' function ignores the environment, while '>>=' passes
57-- The 'return' function ignores the environment, while '>>=' passes
84-- the inherited environment to both subcomputations.
58-- the inherited environment to both subcomputations.
85−type ReaderT tag r = D.Dispatch (READER tag r) (T.ReaderT r)
59+type ReaderT tag r = D.Handler '(READER, tag) (T.ReaderT r)
86
60
87-- | Constructor for computations in the reader monad transformer.
61-- | Constructor for computations in the reader monad transformer.
88readerT :: forall tag r m a . (r -> m a) -> ReaderT tag r m a
62readerT :: forall tag r m a . (r -> m a) -> ReaderT tag r m a
89−readerT = D.pack . T.ReaderT
63+readerT = coerce (T.ReaderT @r @m @a)
64+{-# INLINE readerT #-}
90
65
91-- | Runs a 'ReaderT' with the given environment
66-- | Runs a 'ReaderT' with the given environment
92-- and returns the final value.
67-- and returns the final value.
93runReaderT :: forall tag r m a . ReaderT tag r m a -> r -> m a
68runReaderT :: forall tag r m a . ReaderT tag r m a -> r -> m a
94−runReaderT = T.runReaderT . D.unpack
69+runReaderT = coerce (T.runReaderT @r @_ @m @a)
70+{-# INLINE runReaderT #-}
95
71
96-- | Runs a 'ReaderT' with the given environment
72-- | Runs a 'ReaderT' with the given environment
97-- and returns the final value.
73-- and returns the final value.
98runReader :: forall tag r a . Reader tag r a -> r -> a
74runReader :: forall tag r a . Reader tag r a -> r -> a
99−runReader = T.runReader . D.unpack
75+runReader = coerce (T.runReader @r @a)
76+{-# INLINE runReader #-}
100
77
101instance
78instance
102− ( Monad m, r ~ r', trans ~ T.ReaderT r
79+ ( T.MonadReader r (trans m) -- FIXME: (forall m . T.MonadReader r (trans m))
80+ -- otherwise we can leak a MonadReader instance
81+ -- from 'm'
103− ) => MonadReader tag r (D.Dispatch (READER tag r') trans m)
82+ ) => MonadReader tag r (D.Handler '(READER, tag) trans (m :: * -> *))
104 where
83 where
84+
105− ask _ = D.pack T.ask
85+ ask = coerce (T.ask @r @(trans m))
106− local _ f = D.pack . T.withReaderT f . D.unpack
86+ {-# INLINE ask #-}
107− reader _ = D.pack . T.reader
87+
88+ local =
89+ coerce (T.local @r @(trans m) @a) ::
90+ forall dp a . Local r (D.Handler dp trans m) a
91+ {-# INLINE local #-}
92+
93+ reader =
94+ coerce (T.reader @r @(trans m) @a) ::
95+ forall dp a . (r -> a) -> D.Handler dp trans m a
96+ {-# INLINE reader #-}
ether/src/Control/Monad/Ether/Reader/Class.hs+37−15
@@ -1,7 +1,9 @@
1{-# LANGUAGE FlexibleInstances #-}
1{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE UndecidableInstances #-}
2{-# LANGUAGE UndecidableInstances #-}
3{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE TypeFamilies #-}
4−{-# LANGUAGE MagicHash #-}
4+{-# LANGUAGE TypeOperators #-}
5+{-# LANGUAGE DataKinds #-}
6+{-# LANGUAGE AllowAmbiguousTypes #-}
5
7
6-- | See "Control.Monad.Reader.Class".
8-- | See "Control.Monad.Reader.Class".
7
9
@@ -9,8 +11,9 @@ module Control.Monad.Ether.Reader.Class
9 ( MonadReader(..)
11 ( MonadReader(..)
10 ) where
12 ) where
11
13
12−import GHC.Prim (Proxy#)
14+import Control.Monad.Trans.Ether.Handler
13import qualified Control.Monad.Trans.Lift.Local as Lift
15import qualified Control.Monad.Trans.Lift.Local as Lift
16+import Data.Coerce
14
17
15-- | See 'Control.Monad.Reader.MonadReader'.
18-- | See 'Control.Monad.Reader.MonadReader'.
16class Monad m => MonadReader tag r m | m tag -> r where
19class Monad m => MonadReader tag r m | m tag -> r where
@@ -18,13 +21,12 @@ class Monad m => MonadReader tag r m | m tag -> r where
18 {-# MINIMAL (ask | reader), local #-}
21 {-# MINIMAL (ask | reader), local #-}
19
22
20 -- | Retrieves the monad environment.
23 -- | Retrieves the monad environment.
21− ask :: Proxy# tag -> m r
24+ ask :: m r
22− ask t = reader t id
25+ ask = reader @tag id
23
26
24 -- | Executes a computation in a modified environment.
27 -- | Executes a computation in a modified environment.
25 local
28 local
26− :: Proxy# tag
27− -> (r -> r)
29+ :: (r -> r)
28 -- ^ The function to modify the environment.
30 -- ^ The function to modify the environment.
29 -> m a
31 -> m a
30 -- ^ @Reader@ to run in the modified environment.
32 -- ^ @Reader@ to run in the modified environment.
@@ -32,16 +34,36 @@ class Monad m => MonadReader tag r m | m tag -> r where
32
34
33 -- | Retrieves a function of the current environment.
35 -- | Retrieves a function of the current environment.
34 reader
36 reader
35− :: Proxy# tag
36− -> (r -> a)
37+ :: (r -> a)
37 -- ^ The selector function to apply to the environment.
38 -- ^ The selector function to apply to the environment.
38 -> m a
39 -> m a
39− reader t f = fmap f (ask t)
40+ reader f = fmap f (ask @tag)
40
41
41instance {-# OVERLAPPABLE #-}
42instance {-# OVERLAPPABLE #-}
42− ( Lift.LiftLocal t
43+ ( Lift.LiftLocal t
43− , Monad (t m)
44+ , Monad (t m)
44− , MonadReader tag r m
45+ , MonadReader tag r m
45− ) => MonadReader tag r (t m) where
46+ ) => MonadReader tag r (t m)
47+ where
46− ask t = Lift.lift (ask t)
48+ ask = Lift.lift (ask @tag)
47− local t = Lift.liftLocal (ask t) (local t)
49+ local = Lift.liftLocal (ask @tag) (local @tag)
50+
51+instance {-# OVERLAPPABLE #-}
52+ ( Monad (trans m)
53+ , MonadReader tag r (Handler dps trans m)
54+ ) => MonadReader tag r (Handler (dp ': dps) trans (m :: * -> *))
55+ where
56+
57+ ask =
58+ (coerce ::
59+ Handler dps trans m r ->
60+ Handler (dp ': dps) trans m r)
61+ (ask @tag)
62+ {-# INLINE ask #-}
63+
64+ local =
65+ (coerce :: forall a .
66+ Lift.Local r (Handler dps trans m) a ->
67+ Lift.Local r (Handler (dp ': dps) trans m) a)
68+ (local @tag)
69+ {-# INLINE local #-}
ether/src/Control/Monad/Ether/State.hs−1
@@ -1,4 +1,3 @@
1−
2-- | See "Control.Monad.State".
1-- | See "Control.Monad.State".
3
2
4module Control.Monad.Ether.State
3module Control.Monad.Ether.State
ether/src/Control/Monad/Ether/State/Class.hs+50−19
@@ -1,7 +1,9 @@
1{-# LANGUAGE FlexibleInstances #-}
1{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE UndecidableInstances #-}
2{-# LANGUAGE UndecidableInstances #-}
3{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE TypeFamilies #-}
4−{-# LANGUAGE MagicHash #-}
4+{-# LANGUAGE TypeOperators #-}
5+{-# LANGUAGE DataKinds #-}
6+{-# LANGUAGE AllowAmbiguousTypes #-}
5
7
6-- | See "Control.Monad.State.Class".
8-- | See "Control.Monad.State.Class".
7
9
@@ -9,8 +11,9 @@ module Control.Monad.Ether.State.Class
9 ( MonadState(..)
11 ( MonadState(..)
10 ) where
12 ) where
11
13
12−import GHC.Prim (Proxy#)
14+import Control.Monad.Trans.Ether.Handler
13import qualified Control.Monad.Trans as Lift
15import qualified Control.Monad.Trans as Lift
16+import Data.Coerce
14
17
15-- | See 'Control.Monad.State.MonadState'.
18-- | See 'Control.Monad.State.MonadState'.
16class Monad m => MonadState tag s m | m tag -> s where
19class Monad m => MonadState tag s m | m tag -> s where
@@ -18,26 +21,54 @@ class Monad m => MonadState tag s m | m tag -> s where
18 {-# MINIMAL state | get, put #-}
21 {-# MINIMAL state | get, put #-}
19
22
20 -- | Return the state from the internals of the monad.
23 -- | Return the state from the internals of the monad.
21− get :: Proxy# tag -> m s
24+ get :: m s
22− get t = state t (\s -> (s, s))
25+ get = state @tag (\s -> (s, s))
23
26
24 -- | Replace the state inside the monad.
27 -- | Replace the state inside the monad.
25− put :: Proxy# tag -> s -> m ()
28+ put :: s -> m ()
26− put t s = state t (\_ -> ((), s))
29+ put s = state @tag (\_ -> ((), s))
27
30
28 -- | Embed a simple state action into the monad.
31 -- | Embed a simple state action into the monad.
29− state :: Proxy# tag -> (s -> (a, s)) -> m a
32+ state :: (s -> (a, s)) -> m a
30− state t f = do
33+ state f = do
31− s <- get t
34+ s <- get @tag
32− let ~(a, s') = f s
35+ let ~(a, s') = f s
33− put t s'
36+ put @tag s'
34− return a
37+ return a
35
38
36instance {-# OVERLAPPABLE #-}
39instance {-# OVERLAPPABLE #-}
37− ( Lift.MonadTrans t
40+ ( Lift.MonadTrans t
38− , Monad (t m)
41+ , Monad (t m)
39− , MonadState tag s m
42+ , MonadState tag s m
40− ) => MonadState tag s (t m) where
43+ ) => MonadState tag s (t m)
44+ where
41− get t = Lift.lift (get t)
45+ get = Lift.lift (get @tag)
42− put t = Lift.lift . put t
46+ put = Lift.lift . put @tag
43− state t = Lift.lift . state t
47+ state = Lift.lift . state @tag
48+
49+instance {-# OVERLAPPABLE #-}
50+ ( Monad (trans m)
51+ , MonadState tag s (Handler dps trans m)
52+ ) => MonadState tag s (Handler (dp ': dps) trans (m :: * -> *))
53+ where
54+
55+ get =
56+ (coerce ::
57+ Handler dps trans m s ->
58+ Handler (dp ': dps) trans m s)
59+ (get @tag)
60+ {-# INLINE get #-}
61+
62+ put =
63+ (coerce ::
64+ (s -> Handler dps trans m ()) ->
65+ (s -> Handler (dp ': dps) trans m ()))
66+ (put @tag)
67+ {-# INLINE put #-}
68+
69+ state =
70+ (coerce :: forall a .
71+ ((s -> (a, s)) -> Handler dps trans m a) ->
72+ ((s -> (a, s)) -> Handler (dp ': dps) trans m a))
73+ (state @tag)
74+ {-# INLINE state #-}
ether/src/Control/Monad/Ether/State/Common.hs+28−15
@@ -1,5 +1,7 @@
1+{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE MagicHash #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE UndecidableInstances #-}
3
5
4module Control.Monad.Ether.State.Common
6module Control.Monad.Ether.State.Common
5 ( MonadState
7 ( MonadState
@@ -8,28 +10,39 @@ module Control.Monad.Ether.State.Common
8 , state
10 , state
9 , modify
11 , modify
10 , gets
12 , gets
13+ , STATE
11 ) where
14 ) where
12
15
13−import GHC.Prim (Proxy#, proxy#)
14−import Control.Monad.Ether.State.Class (MonadState)
16+import Control.Monad.Ether.State.Class
17+import qualified Control.Monad.State as T
15−import qualified Control.Monad.Ether.State.Class as C
18+import qualified Control.Monad.Trans.Ether.Handler as D
19+import Data.Coerce
16
20
17−-- | Return the state from the internals of the monad.
21+-- | Encode type-level information for 'StateT'.
18−get :: forall tag s m . MonadState tag s m => m s
22+data STATE
19−get = C.get (proxy# :: Proxy# tag)
20−
21−-- | Replace the state inside the monad.
22−put :: forall tag s m . MonadState tag s m => s -> m ()
23−put = C.put (proxy# :: Proxy# tag)
24−
25−-- | Embed a simple state action into the monad.
26−state :: forall tag s m a . MonadState tag s m => (s -> (a, s)) -> m a
27−state = C.state (proxy# :: Proxy# tag)
28
23
29-- | Modifies the state inside a state monad.
24-- | Modifies the state inside a state monad.
30modify :: forall tag s m . MonadState tag s m => (s -> s) -> m ()
25modify :: forall tag s m . MonadState tag s m => (s -> s) -> m ()
31modify f = state @tag (\s -> ((), f s))
26modify f = state @tag (\s -> ((), f s))
27+{-# INLINABLE modify #-}
32
28
33-- | Gets specific component of the state, using a projection function supplied.
29-- | Gets specific component of the state, using a projection function supplied.
34gets :: forall tag s m a . MonadState tag s m => (s -> a) -> m a
30gets :: forall tag s m a . MonadState tag s m => (s -> a) -> m a
35gets f = fmap f (get @tag)
31gets f = fmap f (get @tag)
32+{-# INLINABLE gets #-}
33+
34+instance
35+ ( T.MonadState s (trans m) -- FIXME: (forall m . T.MonadState s (trans m))
36+ ) => MonadState tag s (D.Handler '(STATE, tag) trans (m :: * -> *))
37+ where
38+
39+ get = coerce (T.get @s @(trans m))
40+ {-# INLINE get #-}
41+
42+ put = coerce (T.put @s @(trans m))
43+ {-# INLINE put #-}
44+
45+ state =
46+ coerce (T.state @s @(trans m) @a) ::
47+ forall dp a . (s -> (a, s)) -> D.Handler dp trans m a
48+ {-# INLINE state #-}
ether/src/Control/Monad/Ether/State/Lazy.hs+17−23
@@ -1,5 +1,3 @@
1−{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
2−
3{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE UndecidableInstances #-}
3{-# LANGUAGE UndecidableInstances #-}
@@ -30,13 +28,10 @@ module Control.Monad.Ether.State.Lazy
30 ) where
28 ) where
31
29
32import Control.Monad.Ether.State.Common
30import Control.Monad.Ether.State.Common
33−import qualified Control.Monad.Ether.State.Class as C
31+import qualified Control.Monad.Trans.Ether.Handler as D
34−import qualified Control.Monad.Trans.Ether.Dispatch as D
35import qualified Control.Monad.Trans.State.Lazy as T
32import qualified Control.Monad.Trans.State.Lazy as T
36import Data.Functor.Identity
33import Data.Functor.Identity
37−
34+import Data.Coerce
38−-- | Encode type-level information for 'StateT'.
39−data STATE t s
40
35
41-- | The parametrizable state monad.
36-- | The parametrizable state monad.
42--
37--
@@ -50,46 +45,45 @@ type State tag r = StateT tag r Identity
50--
45--
51-- The 'return' function leaves the state unchanged, while '>>=' uses
46-- The 'return' function leaves the state unchanged, while '>>=' uses
52-- the final state of the first computation as the initial state of the second.
47-- the final state of the first computation as the initial state of the second.
53−type StateT tag s = D.Dispatch (STATE tag s) (T.StateT s)
48+type StateT tag s = D.Handler '(STATE, tag) (T.StateT s)
54
49
55-- | Constructor for computations in the state monad transformer.
50-- | Constructor for computations in the state monad transformer.
56stateT :: forall tag s m a . (s -> m (a, s)) -> StateT tag s m a
51stateT :: forall tag s m a . (s -> m (a, s)) -> StateT tag s m a
57−stateT = D.pack . T.StateT
52+stateT = coerce (T.StateT @s @m @a)
53+{-# INLINE stateT #-}
58
54
59-- | Runs a 'StateT' with the given initial state
55-- | Runs a 'StateT' with the given initial state
60-- and returns both the final value and the final state.
56-- and returns both the final value and the final state.
61runStateT :: forall tag s m a . StateT tag s m a -> s -> m (a, s)
57runStateT :: forall tag s m a . StateT tag s m a -> s -> m (a, s)
62−runStateT = T.runStateT . D.unpack
58+runStateT = coerce (T.runStateT @s @m @a)
59+{-# INLINE runStateT #-}
63
60
64-- | Runs a 'StateT' with the given initial state
61-- | Runs a 'StateT' with the given initial state
65-- and returns the final value, discarding the final state.
62-- and returns the final value, discarding the final state.
66evalStateT :: forall tag s m a . Monad m => StateT tag s m a -> s -> m a
63evalStateT :: forall tag s m a . Monad m => StateT tag s m a -> s -> m a
67−evalStateT = T.evalStateT . D.unpack
64+evalStateT = coerce (T.evalStateT @m @s @a)
65+{-# INLINE evalStateT #-}
68
66
69-- | Runs a 'StateT' with the given initial state
67-- | Runs a 'StateT' with the given initial state
70-- and returns the final state, discarding the final value.
68-- and returns the final state, discarding the final value.
71execStateT :: forall tag s m a . Monad m => StateT tag s m a -> s -> m s
69execStateT :: forall tag s m a . Monad m => StateT tag s m a -> s -> m s
72−execStateT = T.execStateT . D.unpack
70+execStateT = coerce (T.execStateT @m @s @a)
71+{-# INLINE execStateT #-}
73
72
74-- | Runs a 'State' with the given initial state
73-- | Runs a 'State' with the given initial state
75-- and returns both the final value and the final state.
74-- and returns both the final value and the final state.
76runState :: forall tag s a . State tag s a -> s -> (a, s)
75runState :: forall tag s a . State tag s a -> s -> (a, s)
77−runState = T.runState . D.unpack
76+runState = coerce (T.runState @s @a)
77+{-# INLINE runState #-}
78
78
79-- | Runs a 'State' with the given initial state
79-- | Runs a 'State' with the given initial state
80-- and returns the final value, discarding the final state.
80-- and returns the final value, discarding the final state.
81evalState :: forall tag s a . State tag s a -> s -> a
81evalState :: forall tag s a . State tag s a -> s -> a
82−evalState = T.evalState . D.unpack
82+evalState = coerce (T.evalState @s @a)
83+{-# INLINE evalState #-}
83
84
84-- | Runs a 'State' with the given initial state
85-- | Runs a 'State' with the given initial state
85-- and returns the final state, discarding the final value.
86-- and returns the final state, discarding the final value.
86execState :: forall tag s a . State tag s a -> s -> s
87execState :: forall tag s a . State tag s a -> s -> s
87−execState = T.execState . D.unpack
88+execState = coerce (T.execState @s @a)
88−
89+{-# INLINE execState #-}
89−instance
90− ( Monad m, s ~ s', trans ~ T.StateT s
91− ) => MonadState tag s (D.Dispatch (STATE tag s') trans m)
92− where
93− get _ = D.pack T.get
94− put _ = D.pack . T.put
95− state _ = D.pack . T.state
ether/src/Control/Monad/Ether/State/Strict.hs+17−23
@@ -1,5 +1,3 @@
1−{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
2−
3{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE UndecidableInstances #-}
3{-# LANGUAGE UndecidableInstances #-}
@@ -30,13 +28,10 @@ module Control.Monad.Ether.State.Strict
30 ) where
28 ) where
31
29
32import Control.Monad.Ether.State.Common
30import Control.Monad.Ether.State.Common
33−import qualified Control.Monad.Ether.State.Class as C
31+import qualified Control.Monad.Trans.Ether.Handler as D
34−import qualified Control.Monad.Trans.Ether.Dispatch as D
35import qualified Control.Monad.Trans.State.Strict as T
32import qualified Control.Monad.Trans.State.Strict as T
36import Data.Functor.Identity
33import Data.Functor.Identity
37−
34+import Data.Coerce
38−-- | Encode type-level information for 'StateT'.
39−data STATE t s
40
35
41-- | The parametrizable state monad.
36-- | The parametrizable state monad.
42--
37--
@@ -50,46 +45,45 @@ type State tag r = StateT tag r Identity
50--
45--
51-- The 'return' function leaves the state unchanged, while '>>=' uses
46-- The 'return' function leaves the state unchanged, while '>>=' uses
52-- the final state of the first computation as the initial state of the second.
47-- the final state of the first computation as the initial state of the second.
53−type StateT tag s = D.Dispatch (STATE tag s) (T.StateT s)
48+type StateT tag s = D.Handler '(STATE, tag) (T.StateT s)
54
49
55-- | Constructor for computations in the state monad transformer.
50-- | Constructor for computations in the state monad transformer.
56stateT :: forall tag s m a . (s -> m (a, s)) -> StateT tag s m a
51stateT :: forall tag s m a . (s -> m (a, s)) -> StateT tag s m a
57−stateT = D.pack . T.StateT
52+stateT = coerce (T.StateT @s @m @a)
53+{-# INLINE stateT #-}
58
54
59-- | Runs a 'StateT' with the given initial state
55-- | Runs a 'StateT' with the given initial state
60-- and returns both the final value and the final state.
56-- and returns both the final value and the final state.
61runStateT :: forall tag s m a . StateT tag s m a -> s -> m (a, s)
57runStateT :: forall tag s m a . StateT tag s m a -> s -> m (a, s)
62−runStateT = T.runStateT . D.unpack
58+runStateT = coerce (T.runStateT @s @m @a)
59+{-# INLINE runStateT #-}
63
60
64-- | Runs a 'StateT' with the given initial state
61-- | Runs a 'StateT' with the given initial state
65-- and returns the final value, discarding the final state.
62-- and returns the final value, discarding the final state.
66evalStateT :: forall tag s m a . Monad m => StateT tag s m a -> s -> m a
63evalStateT :: forall tag s m a . Monad m => StateT tag s m a -> s -> m a
67−evalStateT = T.evalStateT . D.unpack
64+evalStateT = coerce (T.evalStateT @m @s @a)
65+{-# INLINE evalStateT #-}
68
66
69-- | Runs a 'StateT' with the given initial state
67-- | Runs a 'StateT' with the given initial state
70-- and returns the final state, discarding the final value.
68-- and returns the final state, discarding the final value.
71execStateT :: forall tag s m a . Monad m => StateT tag s m a -> s -> m s
69execStateT :: forall tag s m a . Monad m => StateT tag s m a -> s -> m s
72−execStateT = T.execStateT . D.unpack
70+execStateT = coerce (T.execStateT @m @s @a)
71+{-# INLINE execStateT #-}
73
72
74-- | Runs a 'State' with the given initial state
73-- | Runs a 'State' with the given initial state
75-- and returns both the final value and the final state.
74-- and returns both the final value and the final state.
76runState :: forall tag s a . State tag s a -> s -> (a, s)
75runState :: forall tag s a . State tag s a -> s -> (a, s)
77−runState = T.runState . D.unpack
76+runState = coerce (T.runState @s @a)
77+{-# INLINE runState #-}
78
78
79-- | Runs a 'State' with the given initial state
79-- | Runs a 'State' with the given initial state
80-- and returns the final value, discarding the final state.
80-- and returns the final value, discarding the final state.
81evalState :: forall tag s a . State tag s a -> s -> a
81evalState :: forall tag s a . State tag s a -> s -> a
82−evalState = T.evalState . D.unpack
82+evalState = coerce (T.evalState @s @a)
83+{-# INLINE evalState #-}
83
84
84-- | Runs a 'State' with the given initial state
85-- | Runs a 'State' with the given initial state
85-- and returns the final state, discarding the final value.
86-- and returns the final state, discarding the final value.
86execState :: forall tag s a . State tag s a -> s -> s
87execState :: forall tag s a . State tag s a -> s -> s
87−execState = T.execState . D.unpack
88+execState = coerce (T.execState @s @a)
88−
89+{-# INLINE execState #-}
89−instance
90− ( Monad m, s ~ s', trans ~ T.StateT s
91− ) => MonadState tag s (D.Dispatch (STATE tag s') trans m)
92− where
93− get _ = D.pack T.get
94− put _ = D.pack . T.put
95− state _ = D.pack . T.state
ether/src/Control/Monad/Ether/TagAttach.hs+15−14
@@ -1,5 +1,3 @@
1−{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
2−
3{-# LANGUAGE DeriveGeneric #-}
1{-# LANGUAGE DeriveGeneric #-}
4{-# LANGUAGE TypeFamilies #-}
2{-# LANGUAGE TypeFamilies #-}
5{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleInstances #-}
@@ -8,7 +6,7 @@
8{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9
7
10module Control.Monad.Ether.TagAttach
8module Control.Monad.Ether.TagAttach
11− ( TAG_ATTACH(..)
9+ ( TAG_ATTACH
12 , TagAttachT
10 , TagAttachT
13 , tagAttach
11 , tagAttach
14 ) where
12 ) where
@@ -30,43 +28,46 @@ import qualified Control.Monad.State.Class as Class
30import qualified Control.Monad.Writer.Class as Class
28import qualified Control.Monad.Writer.Class as Class
31import qualified Control.Monad.Error.Class as Class
29import qualified Control.Monad.Error.Class as Class
32
30
33−import Control.Monad.Trans.Ether.Dispatch
31+import Control.Monad.Trans.Ether.Handler
32+
33+import Data.Coerce
34
34
35-- | Encode type-level information for 'tagAttach'.
35-- | Encode type-level information for 'tagAttach'.
36−data TAG_ATTACH t = TAG_ATTACH t
36+data TAG_ATTACH t
37
37
38−type TagAttachT t = Dispatch (TAG_ATTACH t) IdentityT
38+type TagAttachT t = Handler (TAG_ATTACH t) IdentityT
39
39
40-- | Attach a tag to untagged transformers.
40-- | Attach a tag to untagged transformers.
41tagAttach :: forall tag m a . TagAttachT tag m a -> m a
41tagAttach :: forall tag m a . TagAttachT tag m a -> m a
42−tagAttach = runIdentityT . unpack
42+tagAttach = coerce (runIdentityT @_ @m @a)
43+{-# INLINE tagAttach #-}
43
44
44instance
45instance
45 ( MonadReader tag r m, trans ~ IdentityT
46 ( MonadReader tag r m, trans ~ IdentityT
46− ) => Class.MonadReader r (Dispatch (TAG_ATTACH tag) trans m)
47+ ) => Class.MonadReader r (Handler (TAG_ATTACH tag) trans m)
47 where
48 where
48− ask = A.ask @tag
49+ ask = A.ask @tag
49 local = A.local @tag
50 local = A.local @tag
50
51
51instance
52instance
52 ( MonadState tag s m, trans ~ IdentityT
53 ( MonadState tag s m, trans ~ IdentityT
53− ) => Class.MonadState s (Dispatch (TAG_ATTACH tag) trans m)
54+ ) => Class.MonadState s (Handler (TAG_ATTACH tag) trans m)
54 where
55 where
55 get = A.get @tag
56 get = A.get @tag
56 put = A.put @tag
57 put = A.put @tag
57
58
58instance
59instance
59 ( MonadExcept tag e m, trans ~ IdentityT
60 ( MonadExcept tag e m, trans ~ IdentityT
60− ) => Class.MonadError e (Dispatch (TAG_ATTACH tag) trans m)
61+ ) => Class.MonadError e (Handler (TAG_ATTACH tag) trans m)
61 where
62 where
62 throwError = A.throw @tag
63 throwError = A.throw @tag
63 catchError = A.catch @tag
64 catchError = A.catch @tag
64
65
65instance
66instance
66 ( MonadWriter tag w m, trans ~ IdentityT
67 ( MonadWriter tag w m, trans ~ IdentityT
67− ) => Class.MonadWriter w (Dispatch (TAG_ATTACH tag) trans m)
68+ ) => Class.MonadWriter w (Handler (TAG_ATTACH tag) trans m)
68 where
69 where
69 writer = A.writer @tag
70 writer = A.writer @tag
70− tell = A.tell @tag
71+ tell = A.tell @tag
71 listen = A.listen @tag
72 listen = A.listen @tag
72− pass = A.pass @tag
73+ pass = A.pass @tag
ether/src/Control/Monad/Ether/TagReplace.hs+20−19
@@ -1,5 +1,3 @@
1−{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
2−
3{-# LANGUAGE DeriveGeneric #-}
1{-# LANGUAGE DeriveGeneric #-}
4{-# LANGUAGE TypeFamilies #-}
2{-# LANGUAGE TypeFamilies #-}
5{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleInstances #-}
@@ -25,43 +23,46 @@ import Control.Monad.Ether.State.Common as A
25import Control.Monad.Ether.Except as A
23import Control.Monad.Ether.Except as A
26import Control.Monad.Ether.Writer as A
24import Control.Monad.Ether.Writer as A
27
25
28−import Control.Monad.Trans.Ether.Dispatch
26+import Control.Monad.Trans.Ether.Handler
27+
28+import Data.Coerce
29
29
30-- | Encode type-level information for 'tagReplace'.
30-- | Encode type-level information for 'tagReplace'.
31data TAG_REPLACE tOld tNew
31data TAG_REPLACE tOld tNew
32
32
33−type TagReplaceT tOld tNew = Dispatch (TAG_REPLACE tOld tNew) IdentityT
33+type TagReplaceT tOld tNew = Handler (TAG_REPLACE tOld tNew) IdentityT
34
34
35-- | Replace a tag with another tag.
35-- | Replace a tag with another tag.
36tagReplace :: forall tOld tNew m a . TagReplaceT tOld tNew m a -> m a
36tagReplace :: forall tOld tNew m a . TagReplaceT tOld tNew m a -> m a
37−tagReplace = runIdentityT . unpack
37+tagReplace = coerce (runIdentityT @_ @m @a)
38+{-# INLINE tagReplace #-}
38
39
39instance
40instance
40 ( MonadReader tNew r m, trans ~ IdentityT
41 ( MonadReader tNew r m, trans ~ IdentityT
41− ) => MonadReader tOld r (Dispatch (TAG_REPLACE tOld tNew) trans m)
42+ ) => MonadReader tOld r (Handler (TAG_REPLACE tOld tNew) trans m)
42 where
43 where
43− ask _ = A.ask @tNew
44+ ask = A.ask @tNew
44− local _ = A.local @tNew
45+ local = A.local @tNew
45
46
46instance
47instance
47 ( MonadState tNew s m, trans ~ IdentityT
48 ( MonadState tNew s m, trans ~ IdentityT
48− ) => MonadState tOld s (Dispatch (TAG_REPLACE tOld tNew) trans m)
49+ ) => MonadState tOld s (Handler (TAG_REPLACE tOld tNew) trans m)
49 where
50 where
50− get _ = A.get @tNew
51+ get = A.get @tNew
51− put _ = A.put @tNew
52+ put = A.put @tNew
52
53
53instance
54instance
54 ( MonadExcept tNew e m, trans ~ IdentityT
55 ( MonadExcept tNew e m, trans ~ IdentityT
55− ) => MonadExcept tOld e (Dispatch (TAG_REPLACE tOld tNew) trans m)
56+ ) => MonadExcept tOld e (Handler (TAG_REPLACE tOld tNew) trans m)
56 where
57 where
57− throw _ = A.throw @tNew
58+ throw = A.throw @tNew
58− catch _ = A.catch @tNew
59+ catch = A.catch @tNew
59
60
60instance
61instance
61 ( MonadWriter tNew w m, trans ~ IdentityT
62 ( MonadWriter tNew w m, trans ~ IdentityT
62− ) => MonadWriter tOld w (Dispatch (TAG_REPLACE tOld tNew) trans m)
63+ ) => MonadWriter tOld w (Handler (TAG_REPLACE tOld tNew) trans m)
63 where
64 where
64− writer _ = A.writer @tNew
65+ writer = A.writer @tNew
65− tell _ = A.tell @tNew
66+ tell = A.tell @tNew
66− listen _ = A.listen @tNew
67+ listen = A.listen @tNew
67− pass _ = A.pass @tNew
68+ pass = A.pass @tNew
ether/src/Control/Monad/Ether/Writer.hs+32−39
@@ -1,11 +1,8 @@
1−{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
2−
3{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE UndecidableInstances #-}
3{-# LANGUAGE UndecidableInstances #-}
6{-# LANGUAGE TypeFamilies #-}
4{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE AllowAmbiguousTypes #-}
5{-# LANGUAGE AllowAmbiguousTypes #-}
8−{-# LANGUAGE MagicHash #-}
9
6
10-- | See "Control.Monad.Writer".
7-- | See "Control.Monad.Writer".
11
8
@@ -30,30 +27,12 @@ module Control.Monad.Ether.Writer
30 , execWriterT
27 , execWriterT
31 ) where
28 ) where
32
29
33−import GHC.Prim (Proxy#, proxy#)
34−import Control.Monad.Ether.Writer.Class (MonadWriter)
30+import Control.Monad.Ether.Writer.Class
35−import qualified Control.Monad.Ether.Writer.Class as C
31+import qualified Control.Monad.Trans.Ether.Handler as D
36−import qualified Control.Monad.Trans.Ether.Dispatch as D
37−import qualified Control.Monad.Trans.Writer as T
32+import qualified Control.Monad.Writer as T
38import Data.Functor.Identity
33import Data.Functor.Identity
39−
34+import Control.Monad.Signatures (Listen, Pass)
40−-- | Embed a simple writer action.
35+import Data.Coerce
41−writer :: forall tag w m a . MonadWriter tag w m => (a, w) -> m a
42−writer = C.writer (proxy# :: Proxy# tag)
43−
44−-- | Append a value to the accumulator within the monad.
45−tell :: forall tag w m . MonadWriter tag w m => w -> m ()
46−tell = C.tell (proxy# :: Proxy# tag)
47−
48−-- | Execute an action and add its accumulator
49−-- to the value of the computation.
50−listen :: forall tag w m a . MonadWriter tag w m => m a -> m (a, w)
51−listen = C.listen (proxy# :: Proxy# tag)
52−
53−-- | Execute an action which returns a value and a function,
54−-- and return the value, applying the function to the accumulator.
55−pass :: forall tag w m a . MonadWriter tag w m => m (a, w -> w) -> m a
56−pass = C.pass (proxy# :: Proxy# tag)
57
36
58-- | Execute an action and add the result of applying the given function to
37-- | Execute an action and add the result of applying the given function to
59-- its accumulator to the value of the computation.
38-- its accumulator to the value of the computation.
@@ -69,7 +48,7 @@ censor f m = pass @tag $ do
69 return (a, f)
48 return (a, f)
70
49
71-- | Encode type-level information for 'WriterT'.
50-- | Encode type-level information for 'WriterT'.
72−data WRITER t w
51+data WRITER
73
52
74-- | The parametrizable writer monad.
53-- | The parametrizable writer monad.
75--
54--
@@ -83,37 +62,51 @@ type Writer tag w = WriterT tag w Identity
83--
62--
84-- The 'return' function produces the output 'mempty', while '>>=' combines
63-- The 'return' function produces the output 'mempty', while '>>=' combines
85-- the outputs of the subcomputations using 'mappend'.
64-- the outputs of the subcomputations using 'mappend'.
86−type WriterT tag w = D.Dispatch (WRITER tag w) (T.WriterT w)
65+type WriterT tag w = D.Handler '(WRITER, tag) (T.WriterT w)
87
66
88-- | Constructor for computations in the writer monad transformer.
67-- | Constructor for computations in the writer monad transformer.
89writerT :: forall tag w m a . m (a, w) -> WriterT tag w m a
68writerT :: forall tag w m a . m (a, w) -> WriterT tag w m a
90−writerT = D.pack . T.WriterT
69+writerT = coerce (T.WriterT @w @m @a)
91
70
92-- | Runs a 'WriterT' and returns both the normal value
71-- | Runs a 'WriterT' and returns both the normal value
93-- and the final accumulator.
72-- and the final accumulator.
94runWriterT :: forall tag w m a . WriterT tag w m a -> m (a, w)
73runWriterT :: forall tag w m a . WriterT tag w m a -> m (a, w)
95−runWriterT = T.runWriterT . D.unpack
74+runWriterT = coerce (T.runWriterT @w @m @a)
96
75
97-- | Runs a 'Writer' and returns both the normal value
76-- | Runs a 'Writer' and returns both the normal value
98-- and the final accumulator.
77-- and the final accumulator.
99runWriter :: forall tag w a . Writer tag w a -> (a, w)
78runWriter :: forall tag w a . Writer tag w a -> (a, w)
100−runWriter = T.runWriter . D.unpack
79+runWriter = coerce (T.runWriter @w @a)
101
80
102-- | Runs a 'WriterT' and returns the final accumulator,
81-- | Runs a 'WriterT' and returns the final accumulator,
103-- discarding the normal value.
82-- discarding the normal value.
104execWriterT :: forall tag w m a . Monad m => WriterT tag w m a -> m w
83execWriterT :: forall tag w m a . Monad m => WriterT tag w m a -> m w
105−execWriterT = T.execWriterT . D.unpack
84+execWriterT = coerce (T.execWriterT @m @w @a)
106
85
107-- | Runs a 'Writer' and returns the final accumulator,
86-- | Runs a 'Writer' and returns the final accumulator,
108-- discarding the normal value.
87-- discarding the normal value.
109execWriter :: forall tag w a . Writer tag w a -> w
88execWriter :: forall tag w a . Writer tag w a -> w
110−execWriter = T.execWriter . D.unpack
89+execWriter = coerce (T.execWriter @w @a)
111
90
112instance
91instance
113− ( Monoid w, Monad m, w ~ w', trans ~ T.WriterT w
92+ ( T.MonadWriter w (trans m) -- FIXME: (forall m . T.MonadWriter w (trans m))
114− ) => MonadWriter tag w (D.Dispatch (WRITER tag w') trans m)
93+ ) => MonadWriter tag w (D.Handler '(WRITER, tag) trans (m :: * -> *))
115 where
94 where
95+
116− writer _ = D.pack . T.writer
96+ writer =
97+ coerce (T.writer @w @(trans m) @a) ::
98+ forall dp a . (a, w) -> D.Handler dp trans m a
99+ {-# INLINE writer #-}
100+
117− tell _ = D.pack . T.tell
101+ tell = coerce (T.tell @w @(trans m))
118− listen _ = D.pack . T.listen . D.unpack
102+ {-# INLINE tell #-}
119− pass _ = D.pack . T.pass . D.unpack
103+
104+ listen =
105+ coerce (T.listen @w @(trans m) @a) ::
106+ forall dp a . Listen w (D.Handler dp trans m) a
107+ {-# INLINE listen #-}
108+
109+ pass =
110+ coerce (T.pass @w @(trans m) @a) ::
111+ forall dp a . Pass w (D.Handler dp trans m) a
112+ {-# INLINE pass #-}
ether/src/Control/Monad/Ether/Writer/Class.hs+12−13
@@ -1,7 +1,7 @@
1{-# LANGUAGE FlexibleInstances #-}
1{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE UndecidableInstances #-}
2{-# LANGUAGE UndecidableInstances #-}
3{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE TypeFamilies #-}
4−{-# LANGUAGE MagicHash #-}
4+{-# LANGUAGE AllowAmbiguousTypes #-}
5
5
6-- | See "Control.Monad.Writer.Class".
6-- | See "Control.Monad.Writer.Class".
7
7
@@ -9,7 +9,6 @@ module Control.Monad.Ether.Writer.Class
9 ( MonadWriter(..)
9 ( MonadWriter(..)
10 ) where
10 ) where
11
11
12−import GHC.Prim (Proxy#)
13import qualified Control.Monad.Trans.Lift.Listen as Lift
12import qualified Control.Monad.Trans.Lift.Listen as Lift
14import qualified Control.Monad.Trans.Lift.Pass as Lift
13import qualified Control.Monad.Trans.Lift.Pass as Lift
15
14
@@ -19,22 +18,22 @@ class (Monoid w, Monad m) => MonadWriter tag w m | m tag -> w where
19 {-# MINIMAL (writer | tell), listen, pass #-}
18 {-# MINIMAL (writer | tell), listen, pass #-}
20
19
21 -- | Embed a simple writer action.
20 -- | Embed a simple writer action.
22− writer :: Proxy# tag -> (a, w) -> m a
21+ writer :: (a, w) -> m a
23− writer t ~(a, w) = do
22+ writer ~(a, w) = do
24− tell t w
23+ tell @tag w
25 return a
24 return a
26
25
27 -- | Append a value to the accumulator within the monad.
26 -- | Append a value to the accumulator within the monad.
28− tell :: Proxy# tag -> w -> m ()
27+ tell :: w -> m ()
29− tell t w = writer t ((),w)
28+ tell w = writer @tag ((),w)
30
29
31 -- | Execute an action and add its accumulator
30 -- | Execute an action and add its accumulator
32 -- to the value of the computation.
31 -- to the value of the computation.
33− listen :: Proxy# tag -> m a -> m (a, w)
32+ listen :: m a -> m (a, w)
34
33
35 -- | Execute an action which returns a value and a function,
34 -- | Execute an action which returns a value and a function,
36 -- and return the value, applying the function to the accumulator.
35 -- and return the value, applying the function to the accumulator.
37− pass :: Proxy# tag -> m (a, w -> w) -> m a
36+ pass :: m (a, w -> w) -> m a
38
37
39instance {-# OVERLAPPABLE #-}
38instance {-# OVERLAPPABLE #-}
40 ( Lift.LiftListen t
39 ( Lift.LiftListen t
@@ -43,7 +42,7 @@ instance {-# OVERLAPPABLE #-}
43 , MonadWriter tag w m
42 , MonadWriter tag w m
44 , Monoid w
43 , Monoid w
45 ) => MonadWriter tag w (t m) where
44 ) => MonadWriter tag w (t m) where
46− writer t = Lift.lift . writer t
45+ writer = Lift.lift . writer @tag
47− tell t = Lift.lift . tell t
46+ tell = Lift.lift . tell @tag
48− listen t = Lift.liftListen (listen t)
47+ listen = Lift.liftListen (listen @tag)
49− pass t = Lift.liftPass (pass t)
48+ pass = Lift.liftPass (pass @tag)
ether/src/Control/Monad/Trans/Ether/Dispatch.hsdeleted−150
@@ -1,150 +0,0 @@
1−{-# LANGUAGE DeriveGeneric #-}
2−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE UndecidableInstances #-}
5−{-# LANGUAGE ConstraintKinds #-}
6−{-# LANGUAGE TypeFamilies #-}
7−
8−module Control.Monad.Trans.Ether.Dispatch where
9−
10−import Control.Applicative
11−import Control.Monad (MonadPlus)
12−import Control.Monad.Fix (MonadFix)
13−import Control.Monad.Trans.Class (MonadTrans, lift)
14−import Control.Monad.IO.Class (MonadIO)
15−import Control.Monad.Morph (MFunctor, MMonad)
16−import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask)
17−
18−import qualified Control.Monad.Base as MB
19−import qualified Control.Monad.Trans.Control as MC
20−
21−import qualified Control.Monad.Trans.Lift.StT as Lift
22−import qualified Control.Monad.Trans.Lift.Local as Lift
23−import qualified Control.Monad.Trans.Lift.Catch as Lift
24−import qualified Control.Monad.Trans.Lift.Listen as Lift
25−import qualified Control.Monad.Trans.Lift.Pass as Lift
26−import qualified Control.Monad.Trans.Lift.CallCC as Lift
27−
28−import qualified Control.Monad.Cont.Class as Class
29−import qualified Control.Monad.Reader.Class as Class
30−import qualified Control.Monad.State.Class as Class
31−import qualified Control.Monad.Writer.Class as Class
32−import qualified Control.Monad.Error.Class as Class
33−
34−import GHC.Generics (Generic)
35−import Data.Coerce (coerce)
36−
37−newtype Dispatch dp trans m a = Dispatch (trans m a)
38− deriving
39− ( Generic
40− , Functor, Applicative, Alternative, Monad, MonadPlus
41− , MonadFix, MonadTrans, MonadIO, MFunctor, MMonad
42− , MonadThrow, MonadCatch, MonadMask )
43−
44−pack :: forall dp trans m a . trans m a -> Dispatch dp trans m a
45−pack = coerce
46−{-# INLINE pack #-}
47−
48−unpack :: forall dp trans m a . Dispatch dp trans m a -> trans m a
49−unpack = coerce
50−{-# INLINE unpack #-}
51−
52−repack :: forall dp dp' trans m a . Dispatch dp trans m a -> Dispatch dp' trans m a
53−repack = coerce
54−{-# INLINE repack #-}
55−
56−instance
57− ( MB.MonadBase b m
58− , MonadTrans trans
59− , Monad (trans m)
60− ) => MB.MonadBase b (Dispatch dp trans m)
61− where
62− liftBase = MB.liftBaseDefault
63−
64−instance
65− ( MC.MonadTransControl trans
66− ) => MC.MonadTransControl (Dispatch dp trans)
67− where
68− type StT (Dispatch dp trans) a = MC.StT trans a
69− liftWith = MC.defaultLiftWith pack unpack
70− restoreT = MC.defaultRestoreT pack
71−
72−instance
73− ( MC.MonadBaseControl b m
74− , MC.MonadTransControl trans
75− , Monad (trans m)
76− ) => MC.MonadBaseControl b (Dispatch dp trans m)
77− where
78− type StM (Dispatch dp trans m) a = MC.ComposeSt trans m a
79− liftBaseWith = MC.defaultLiftBaseWith
80− restoreM = MC.defaultRestoreM
81−
82−type instance Lift.StT (Dispatch dp trans) a = Lift.StT trans a
83−
84−instance Lift.LiftLocal trans => Lift.LiftLocal (Dispatch dp trans) where
85− liftLocal = Lift.defaultLiftLocal pack unpack
86−
87−instance Lift.LiftCatch trans => Lift.LiftCatch (Dispatch dp trans) where
88− liftCatch = Lift.defaultLiftCatch pack unpack
89−
90−instance Lift.LiftListen trans => Lift.LiftListen (Dispatch dp trans) where
91− liftListen = Lift.defaultLiftListen pack unpack
92−
93−instance Lift.LiftPass trans => Lift.LiftPass (Dispatch dp trans) where
94− liftPass = Lift.defaultLiftPass pack unpack
95−
96−instance Lift.LiftCallCC trans => Lift.LiftCallCC (Dispatch dp trans) where
97− liftCallCC = Lift.defaultLiftCallCC pack unpack
98− liftCallCC' = Lift.defaultLiftCallCC' pack unpack
99−
100−
101−-- Instances for mtl classes
102−
103−instance {-# OVERLAPPABLE #-}
104− ( Class.MonadCont m
105− , Lift.LiftCallCC trans
106− , Monad (trans m)
107− ) => Class.MonadCont (Dispatch dp trans m)
108− where
109− callCC = Lift.liftCallCC' Class.callCC
110−
111−instance {-# OVERLAPPABLE #-}
112− ( Class.MonadReader r m
113− , Lift.LiftLocal trans
114− , Monad (trans m)
115− ) => Class.MonadReader r (Dispatch dp trans m)
116− where
117− ask = lift Class.ask
118− local = Lift.liftLocal Class.ask Class.local
119− reader = lift . Class.reader
120−
121−instance {-# OVERLAPPABLE #-}
122− ( Class.MonadState s m
123− , MonadTrans trans
124− , Monad (trans m)
125− ) => Class.MonadState s (Dispatch dp trans m)
126− where
127− get = lift Class.get
128− put = lift . Class.put
129− state = lift . Class.state
130−
131−instance {-# OVERLAPPABLE #-}
132− ( Class.MonadWriter w m
133− , Lift.LiftListen trans
134− , Lift.LiftPass trans
135− , Monad (trans m)
136− ) => Class.MonadWriter w (Dispatch dp trans m)
137− where
138− writer = lift . Class.writer
139− tell = lift . Class.tell
140− listen = Lift.liftListen Class.listen
141− pass = Lift.liftPass Class.pass
142−
143−instance {-# OVERLAPPABLE #-}
144− ( Class.MonadError e m
145− , Lift.LiftCatch trans
146− , Monad (trans m)
147− ) => Class.MonadError e (Dispatch dp trans m)
148− where
149− throwError = lift . Class.throwError
150− catchError = Lift.liftCatch Class.catchError
ether/src/Control/Monad/Trans/Ether/Handler.hsnew file+186
@@ -0,0 +1,186 @@
1+{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE UndecidableInstances #-}
5+{-# LANGUAGE ConstraintKinds #-}
6+{-# LANGUAGE RankNTypes #-}
7+{-# LANGUAGE GADTs #-}
8+{-# LANGUAGE TypeFamilies #-}
9+
10+module Control.Monad.Trans.Ether.Handler
11+ ( Handler(..)
12+ ) where
13+
14+import Control.Applicative
15+import Control.Monad (MonadPlus)
16+import Control.Monad.Fix (MonadFix)
17+import Control.Monad.Trans.Class (MonadTrans, lift)
18+import Control.Monad.IO.Class (MonadIO)
19+import Control.Monad.Morph (MFunctor, MMonad)
20+import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask)
21+
22+import qualified Control.Monad.Base as MB
23+import qualified Control.Monad.Trans.Control as MC
24+
25+import qualified Control.Monad.Trans.Lift.StT as Lift
26+import qualified Control.Monad.Trans.Lift.Local as Lift
27+import qualified Control.Monad.Trans.Lift.Catch as Lift
28+import qualified Control.Monad.Trans.Lift.Listen as Lift
29+import qualified Control.Monad.Trans.Lift.Pass as Lift
30+import qualified Control.Monad.Trans.Lift.CallCC as Lift
31+
32+import qualified Control.Monad.Cont.Class as Class
33+import qualified Control.Monad.Reader.Class as Class
34+import qualified Control.Monad.State.Class as Class
35+import qualified Control.Monad.Writer.Class as Class
36+import qualified Control.Monad.Error.Class as Class
37+
38+import GHC.Generics (Generic)
39+import Data.Coerce (coerce)
40+
41+newtype Handler dp trans m a = Handler (trans m a)
42+ deriving
43+ ( Generic
44+ , Functor, Applicative, Alternative, Monad, MonadPlus
45+ , MonadFix, MonadTrans, MonadIO, MFunctor, MMonad
46+ , MonadThrow, MonadCatch, MonadMask )
47+
48+type Pack dp trans m a = trans m a -> Handler dp trans m a
49+
50+type Unpack dp trans m a = Handler dp trans m a -> trans m a
51+
52+instance
53+ ( MB.MonadBase b (trans m)
54+ ) => MB.MonadBase b (Handler dp trans m)
55+ where
56+ liftBase =
57+ (coerce :: forall a .
58+ (b a -> trans m a) ->
59+ (b a -> Handler dp trans m a))
60+ MB.liftBase
61+
62+instance
63+ ( MC.MonadTransControl trans
64+ ) => MC.MonadTransControl (Handler dp trans)
65+ where
66+ type StT (Handler dp trans) a = MC.StT trans a
67+ liftWith = MC.defaultLiftWith
68+ (coerce :: Pack dp trans m a)
69+ (coerce :: Unpack dp trans m a)
70+ restoreT = MC.defaultRestoreT
71+ (coerce :: Pack dp trans m a)
72+
73+type LiftBaseWith b m a = (MC.RunInBase m b -> b a) -> m a
74+
75+newtype LiftBaseWith' b m a = LBW { unLBW :: LiftBaseWith b m a }
76+
77+coerceLiftBaseWith ::
78+ LiftBaseWith b (trans m) a ->
79+ LiftBaseWith b (Handler dp trans m) a
80+coerceLiftBaseWith lbw =
81+ unLBW (coerce (LBW lbw))
82+{-# INLINE coerceLiftBaseWith #-}
83+
84+instance
85+ ( MC.MonadBaseControl b (trans m)
86+ ) => MC.MonadBaseControl b (Handler dp trans m)
87+ where
88+ type StM (Handler dp trans m) a = MC.StM (trans m) a
89+
90+ liftBaseWith = coerceLiftBaseWith MC.liftBaseWith
91+ {-# INLINE liftBaseWith #-}
92+
93+ restoreM =
94+ (coerce :: forall a .
95+ (MC.StM (trans m) a -> trans m a) ->
96+ (MC.StM (trans m) a -> Handler dp trans m a))
97+ MC.restoreM
98+ {-# INLINE restoreM #-}
99+
100+type instance Lift.StT (Handler dp trans) a = Lift.StT trans a
101+
102+instance Lift.LiftLocal trans => Lift.LiftLocal (Handler dp trans) where
103+ liftLocal =
104+ Lift.defaultLiftLocal
105+ (coerce :: Pack dp trans m a)
106+ (coerce :: Unpack dp trans m a)
107+
108+instance Lift.LiftCatch trans => Lift.LiftCatch (Handler dp trans) where
109+ liftCatch =
110+ Lift.defaultLiftCatch
111+ (coerce :: Pack dp trans m a)
112+ (coerce :: Unpack dp trans m a)
113+
114+instance Lift.LiftListen trans => Lift.LiftListen (Handler dp trans) where
115+ liftListen =
116+ Lift.defaultLiftListen
117+ (coerce :: Pack dp trans m a)
118+ (coerce :: Unpack dp trans m a)
119+
120+instance Lift.LiftPass trans => Lift.LiftPass (Handler dp trans) where
121+ liftPass =
122+ Lift.defaultLiftPass
123+ (coerce :: Pack dp trans m a)
124+ (coerce :: Unpack dp trans m a)
125+
126+instance Lift.LiftCallCC trans => Lift.LiftCallCC (Handler dp trans) where
127+ liftCallCC =
128+ Lift.defaultLiftCallCC
129+ (coerce :: Pack dp trans m a)
130+ (coerce :: Unpack dp trans m a)
131+ liftCallCC' =
132+ Lift.defaultLiftCallCC'
133+ (coerce :: Pack dp trans m a)
134+ (coerce :: Unpack dp trans m a)
135+
136+
137+-- Instances for mtl classes
138+
139+instance {-# OVERLAPPABLE #-}
140+ ( Class.MonadCont m
141+ , Lift.LiftCallCC trans
142+ , Monad (trans m)
143+ ) => Class.MonadCont (Handler dp trans m)
144+ where
145+ callCC = Lift.liftCallCC' Class.callCC
146+
147+instance {-# OVERLAPPABLE #-}
148+ ( Class.MonadReader r m
149+ , Lift.LiftLocal trans
150+ , Monad (trans m)
151+ ) => Class.MonadReader r (Handler dp trans m)
152+ where
153+ ask = lift Class.ask
154+ local = Lift.liftLocal Class.ask Class.local
155+ reader = lift . Class.reader
156+
157+instance {-# OVERLAPPABLE #-}
158+ ( Class.MonadState s m
159+ , MonadTrans trans
160+ , Monad (trans m)
161+ ) => Class.MonadState s (Handler dp trans m)
162+ where
163+ get = lift Class.get
164+ put = lift . Class.put
165+ state = lift . Class.state
166+
167+instance {-# OVERLAPPABLE #-}
168+ ( Class.MonadWriter w m
169+ , Lift.LiftListen trans
170+ , Lift.LiftPass trans
171+ , Monad (trans m)
172+ ) => Class.MonadWriter w (Handler dp trans m)
173+ where
174+ writer = lift . Class.writer
175+ tell = lift . Class.tell
176+ listen = Lift.liftListen Class.listen
177+ pass = Lift.liftPass Class.pass
178+
179+instance {-# OVERLAPPABLE #-}
180+ ( Class.MonadError e m
181+ , Lift.LiftCatch trans
182+ , Monad (trans m)
183+ ) => Class.MonadError e (Handler dp trans m)
184+ where
185+ throwError = lift . Class.throwError
186+ catchError = Lift.liftCatch Class.catchError