git.iko.soy/typeable/ether
on master help sign in
Remove Proxy# and rename Dispatch to Handler
commit9de2a972806b0a32c13e9d129c74b8c8e468558d authorVladislav Zavialov <vlad.z.4096@gmail.com> dateThu 30 Mar 2017, 23:09 (10 years ago) parentf9f16d0
27 files changed+887−693
compare with master
unifiedsplit
ether-flatten/ether-flatten.cabal+2−1 ether-flatten/src/Control/Ether/Flatten.hs+217−69 ether-flatten/src/Control/Monad/Ether/Reader/Flatten.hs+33−48 ether-flatten/src/Control/Monad/Ether/State/Flatten.hs+31−42 ether-suite/bench/Bench.hs+116−113 ether-suite/ether-suite.cabal+1 ether-zoom/ether-zoom.cabal+1−1 ether-zoom/src/Control/Monad/Ether/State/Zoom.hs+12−7 ether/ether.cabal+2−3 ether/src/Control/Monad/Ether.hs−1 ether/src/Control/Monad/Ether/Except.hs+21−26 ether/src/Control/Monad/Ether/Except/Class.hs+5−6 ether/src/Control/Monad/Ether/Implicit.hs−1 ether/src/Control/Monad/Ether/Implicit/State.hs−1 ether/src/Control/Monad/Ether/Reader.hs+32−43 ether/src/Control/Monad/Ether/Reader/Class.hs+37−15 ether/src/Control/Monad/Ether/State.hs−1 ether/src/Control/Monad/Ether/State/Class.hs+50−19 ether/src/Control/Monad/Ether/State/Common.hs+28−15 ether/src/Control/Monad/Ether/State/Lazy.hs+17−23 ether/src/Control/Monad/Ether/State/Strict.hs+17−23 ether/src/Control/Monad/Ether/TagAttach.hs+15−14 ether/src/Control/Monad/Ether/TagReplace.hs+20−19 ether/src/Control/Monad/Ether/Writer.hs+32−39 ether/src/Control/Monad/Ether/Writer/Class.hs+12−13 ether/src/Control/Monad/Trans/Ether/Dispatch.hs−150 ether/src/Control/Monad/Trans/Ether/Handler.hs+186
ether-flatten/ether-flatten.cabal+2−1
@@ -28,6 +28,7 @@ library
2828 , Control.Ether.Flatten
2929 build-depends: base >=4.9 && <4.10
3030 , ether >=0.5 && <0.6
31+ , mtl >=2.2.1
3132 , transformers >=0.4.2
3233 , transformers-lift >=0.1.0.1
3334 , ghc-prim >=0.3
@@ -41,4 +42,4 @@ library
4142 TypeApplications
4243
4344 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 @@
66{-# LANGUAGE FlexibleInstances #-}
77{-# LANGUAGE GADTs #-}
88{-# LANGUAGE TypeFamilies #-}
9−{-# LANGUAGE MagicHash #-}
9+{-# LANGUAGE TemplateHaskell #-}
10+{-# LANGUAGE StandaloneDeriving #-}
11+{-# LANGUAGE AllowAmbiguousTypes #-}
12+{-# LANGUAGE DeriveGeneric #-}
13+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
1014
1115module Control.Ether.Flatten
1216 ( HasLens(..)
13− , Product
14− , load
15− , type (++)
16− , (<+>)
17+ , Product(..)
1718 ) where
1819
19−import Control.Lens
2020import Control.DeepSeq
21−import GHC.Prim (Proxy#)
21+import Control.Lens
22+import GHC.Generics (Generic)
2223
2324class 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 #-}
2578
26−data Product (ts :: [k]) (as :: [*]) where
27− Nil :: Product '[] '[]
28− Cons :: a -> !(Product ts as) -> Product (t ': ts) (a ': as)
79+data instance Product ts '[a1, a2, a3, a4, a5] =
80+ P5
81+ { p5_1 :: !a1
82+ , p5_2 :: !a2
83+ , p5_3 :: !a3
84+ , p5_4 :: !a4
85+ , p5_5 :: !a5
86+ } deriving (Generic)
2987
30−instance NFData (Product '[] '[]) where
31− rnf Nil = ()
88+deriving instance
89+ ( Show a1
90+ , Show a2
91+ , Show a3
92+ , Show a4
93+ , Show a5
94+ ) => Show (Product ts '[a1, a2, a3, a4, a5])
3295
3396instance
34− ( NFData a
35− , NFData (Product ts as)
36− ) => NFData (Product (t ': ts) (a ': as))
37− where
38− rnf (Cons a as) = rnf a `seq` rnf as
39−
40−load :: forall tag a . a -> Product '[tag] '[a]
41−load a = Cons a Nil
42−{-# INLINE load #-}
43−
44−type family (xs1 :: [k]) ++ (xs2 :: [k]) :: [k] where
45− '[] ++ xs2 = xs2
46− (a ': xs1) ++ xs2 = a ': (xs1 ++ xs2)
47−
48−(<+>)
49− :: Product ts1 as1
50− -> Product ts2 as2
51− -> Product (ts1 ++ ts2) (as1 ++ as2)
52−Nil <+> as2 = as2
53−Cons a as1 <+> as2 = Cons a (as1 <+> as2)
54−{-# INLINE (<+>) #-}
55−
56−productHead ::
57− Lens
58− (Product (t1 ': ts) (a ': as))
59− (Product (t2 ': ts) (b ': as))
60− a
61− b
62−productHead =
63− lens
64− (\(Cons a _) -> a)
65− (\(Cons _ as) a -> Cons a as)
66−{-# INLINE productHead #-}
67−
68−productTail ::
69− Lens
70− (Product (t ': ts1) (a ': as))
71− (Product (t ': ts2) (a ': bs))
72− (Product ts1 as)
73− (Product ts2 bs)
74−productTail =
75− lens
76− (\(Cons _ as) -> as)
77− (\(Cons a _) as -> Cons a as)
78−{-# INLINE productTail #-}
79−
80−instance a ~ b => HasLens tag (Product (tag ': tags) (a ': as)) b where
81− lensOf _ = productHead
82− {-# INLINE lensOf #-}
83−
84−instance {-# OVERLAPPABLE #-}
85− ( HasLens tag (Product tags as) a
86− ) => HasLens tag (Product (t ': tags) (b ': as)) a
87− where
88− lensOf t = productTail . lensOf t
89− {-# INLINE lensOf #-}
97+ ( NFData a1
98+ , NFData a2
99+ , NFData a3
100+ , NFData a4
101+ , NFData a5
102+ ) => NFData (Product ts '[a1, a2, a3, a4, a5])
103+
104+instance a ~ a1 => HasLens t1
105+ (Product
106+ '[t1, t2, t3, t4, t5]
107+ '[a1, a2, a3, a4, a5]) a where
108+ lensOf = lens p5_1 (\p a -> p{ p5_1 = a })
109+ {-# INLINE lensOf #-}
110+
111+instance a ~ a2 => HasLens t2
112+ (Product
113+ '[t1, t2, t3, t4, t5]
114+ '[a1, a2, a3, a4, a5]) a where
115+ lensOf = lens p5_2 (\p a -> p{ p5_2 = a })
116+ {-# INLINE lensOf #-}
117+
118+instance a ~ a3 => HasLens t3
119+ (Product
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 })
123+ {-# INLINE lensOf #-}
124+
125+instance a ~ a4 => HasLens t4
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
133+ (Product
134+ '[t1, t2, t3, t4, t5]
135+ '[a1, a2, a3, a4, a5]) a where
136+ lensOf = lens p5_5 (\p a -> p{ p5_5 = a })
137+ {-# INLINE lensOf #-}
138+
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 })
216+ {-# INLINE lensOf #-}
217+
218+instance a ~ a7 => HasLens t7
219+ (Product
220+ '[t1, t2, t3, t4, t5, t6, t7, t8, t9]
221+ '[a1, a2, a3, a4, a5, a6, a7, a8, a9]) a where
222+ lensOf = lens p9_7 (\p a -> p{ p9_7 = a })
223+ {-# INLINE lensOf #-}
224+
225+instance a ~ a8 => HasLens t8
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 })
230+ {-# INLINE lensOf #-}
231+
232+instance a ~ a9 => HasLens t9
233+ (Product
234+ '[t1, t2, t3, t4, t5, t6, t7, t8, t9]
235+ '[a1, a2, a3, a4, a5, a6, a7, a8, a9]) a where
236+ lensOf = lens p9_9 (\p a -> p{ p9_9 = a })
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−
31{-# LANGUAGE RankNTypes #-}
42{-# LANGUAGE TypeSynonymInstances #-}
53{-# LANGUAGE DataKinds #-}
@@ -8,71 +6,58 @@
86{-# LANGUAGE FlexibleInstances #-}
97{-# LANGUAGE GADTs #-}
108{-# LANGUAGE TypeFamilies #-}
11−{-# LANGUAGE MagicHash #-}
129
1310module Control.Monad.Ether.Reader.Flatten
1411 ( runReader
1512 , runReaderT
1613 ) where
1714
18−import qualified Control.Monad.Trans.Lift.Local as Lift
19−
2015import Data.Functor.Identity
2116import Control.Monad.Ether.Reader.Class as C
22−import Control.Monad.Trans.Ether.Dispatch
23−import qualified Control.Monad.Trans.Reader as T
17+import Control.Monad.Trans.Ether.Handler
18+import qualified Control.Monad.Reader as T
2419import Control.Lens
2520import Control.Ether.Flatten
21+import Data.Coerce
2622
27−data READER (ts :: [k])
23+data READER
2824
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
3028
31−type Reader ts r = ReaderT ts r Identity
29+type ReaderT ts r = Handler (READERS ts) (T.ReaderT r)
3230
33−reflatten
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 #-}
31+type Reader ts r = ReaderT ts r Identity
3932
4033instance
41− ( Monad m, Monad (trans m)
42− , Lift.MonadTrans trans
43− , Lift.LiftLocal trans
44− , C.MonadReader tag r m
45− ) => C.MonadReader tag r (Dispatch (READER '[]) trans m)
34+ ( HasLens tag payload r
35+ , T.MonadReader payload (trans m) -- FIXME: (forall m . T.MonadReader payload (trans m))
36+ ) => C.MonadReader tag r (Handler ('(READER, tag) ': dps) trans (m :: * -> *))
4637 where
47− ask t = Lift.lift (ask t)
48− local t = Lift.liftLocal (ask t) (local t)
4938
50−instance
51− ( Monad m, HasLens tag payload r
52− , trans ~ T.ReaderT payload
53− ) => C.MonadReader tag r (Dispatch (READER (tag ': tags)) trans m)
54− where
55− ask t = pack $ view (lensOf t)
39+ ask =
40+ (coerce :: forall dp a .
41+ trans m a ->
42+ Handler dp trans m a)
43+ (view (lensOf @tag))
5644 {-# INLINE ask #-}
57− local t f = pack . T.local (over (lensOf t) f) . unpack
58− {-# INLINE local #-}
5945
60−instance {-# OVERLAPPABLE #-}
61− ( Monad m
62− , C.MonadReader tag r (Dispatch (READER tags) trans m)
63− , trans ~ T.ReaderT payload
64− ) => C.MonadReader tag r (Dispatch (READER (t ': tags)) trans m)
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
46+ local f =
47+ (coerce :: forall dp a .
48+ (trans m a -> trans m a) ->
49+ (Handler dp trans m a -> Handler dp trans m a))
50+ (T.local (lensOf @tag %~ f))
7251 {-# INLINE local #-}
7352
74−runReaderT :: ReaderT tags (Product tags as) m a -> Product tags as -> m a
75−runReaderT m = T.runReaderT (unpack m)
76−
77−runReader :: Reader tags (Product tags as) a -> Product tags as -> a
78−runReader m = T.runReader (unpack m)
53+runReaderT
54+ :: ReaderT tags (Product tags as) m a
55+ -> Product tags as
56+ -> m a
57+runReaderT m = T.runReaderT (coerce m)
58+
59+runReader
60+ :: Reader tags (Product tags as) a
61+ -> Product tags as
62+ -> a
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−
31{-# LANGUAGE RankNTypes #-}
42{-# LANGUAGE TypeSynonymInstances #-}
53{-# LANGUAGE DataKinds #-}
@@ -8,74 +6,65 @@
86{-# LANGUAGE FlexibleInstances #-}
97{-# LANGUAGE GADTs #-}
108{-# LANGUAGE TypeFamilies #-}
11−{-# LANGUAGE MagicHash #-}
129
1310module Control.Monad.Ether.State.Flatten
1411 ( runState
1512 , runStateT
1613 ) where
1714
18−import qualified Control.Monad.Trans.Class as Lift
19−
2015import Data.Functor.Identity
2116import Control.Monad.Ether.State.Class as C
22−import Control.Monad.Trans.Ether.Dispatch
23−import qualified Control.Monad.Trans.State as T
17+import Control.Monad.Trans.Ether.Handler
18+import qualified Control.Monad.State as T
2419import Control.Lens
2520import Control.Ether.Flatten
21+import Data.Coerce
2622
27−data STATE (ts :: [k])
28−
29−type StateT ts s = Dispatch (STATE ts) (T.StateT s)
23+data STATE
3024
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
3228
33−reflatten
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 #-}
29+type StateT ts s = Handler (STATES ts) (T.StateT s)
3930
40−instance
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
31+type State ts s = StateT ts s Identity
4932
5033instance
5134 ( Monad m, HasLens tag payload s
52− , trans ~ T.StateT payload
53− ) => C.MonadState tag s (Dispatch (STATE (tag ': tags)) trans m)
35+ , T.MonadState payload (trans m) -- FIXME: (forall m . T.MonadState payload (trans m))
36+ ) => C.MonadState tag s (Handler ('(STATE, tag) ': dps) trans m)
5437 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 #-}
5938
60−instance {-# OVERLAPPABLE #-}
61− ( Monad m
62− , C.MonadState tag s (Dispatch (STATE tags) trans m)
63− , trans ~ T.StateT payload
64− ) => C.MonadState tag s (Dispatch (STATE (t ': tags)) trans m)
65− where
66− get t = reflatten @tags @(t ': tags) (C.get t)
39+ get =
40+ (coerce :: forall dp a .
41+ trans m a ->
42+ Handler dp trans m a)
43+ (use (lensOf @tag))
6744 {-# 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))
6951 {-# INLINE put #-}
7052
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+
7160runStateT
7261 :: StateT tags (Product tags as) m a
7362 -> Product tags as
7463 -> m (a, Product tags as)
75−runStateT m = T.runStateT (unpack m)
64+runStateT m = T.runStateT (coerce m)
7665
7766runState
7867 :: State tags (Product tags as) a
7968 -> Product tags as
8069 -> (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 @@
33{-# LANGUAGE FunctionalDependencies #-}
44{-# LANGUAGE FlexibleContexts #-}
55{-# LANGUAGE DataKinds #-}
6+{-# LANGUAGE TypeOperators #-}
67
78module Main (main) where
89
@@ -15,61 +16,66 @@ import qualified Control.Monad.Ether.Reader.Flatten as E.F
1516import qualified Control.Monad.Ether.State.Flatten as E.F
1617import Control.Ether.Flatten
1718import qualified Control.Lens as L
19+import Control.DeepSeq
1820
19−readerSummatorMTL_flat_9
21+id' :: a -> a
22+id' = id
23+{-# NOINLINE id' #-}
24+
25+readerCombinerMTL_flat_9
2026 :: M.MonadReader (Int, Int, Int, Int, Int, Int, Int, Int, Int) m
21− => m String
22−readerSummatorMTL_flat_9 = do
23− concat <$> sequenceA
24− [ show <$> L.view L._1
25− , show <$> L.view L._2
26− , show <$> L.view L._3
27− , show <$> L.view L._4
28− , show <$> L.view L._5
29− , show <$> L.view L._6
30− , show <$> L.view L._7
31− , show <$> L.view L._8
32− , show <$> L.view L._9 ]
33−{-# NOINLINE readerSummatorMTL_flat_9 #-}
34−
35−stateSummatorMTL_flat_9
27+ => m ()
28+readerCombinerMTL_flat_9 = do
29+ rnf <$> sequenceA
30+ [ L.view L._1
31+ , L.view L._2
32+ , L.view L._3
33+ , L.view L._4
34+ , L.view L._5
35+ , L.view L._6
36+ , L.view L._7
37+ , L.view L._8
38+ , L.view L._9 ]
39+{-# NOINLINE readerCombinerMTL_flat_9 #-}
40+
41+stateCombinerMTL_flat_9
3642 :: M.MonadState (Int, Int, Int, Int, Int, Int, Int, Int, Int) m
37− => m String
38−stateSummatorMTL_flat_9 = do
39− M.modify (L.over L._1 (+1))
40− M.modify (L.over L._2 (+2))
41− M.modify (L.over L._3 (+3))
42− M.modify (L.over L._4 (+4))
43− M.modify (L.over L._5 (+5))
44− M.modify (L.over L._6 (+6))
45− M.modify (L.over L._7 (+7))
46− M.modify (L.over L._8 (+8))
47− M.modify (L.over L._9 (+9))
48− concat <$> sequenceA
49− [ show <$> L.use L._1
50− , show <$> L.use L._2
51− , show <$> L.use L._3
52− , show <$> L.use L._4
53− , show <$> L.use L._5
54− , show <$> L.use L._6
55− , show <$> L.use L._7
56− , show <$> L.use L._8
57− , show <$> L.use L._9 ]
58−{-# NOINLINE stateSummatorMTL_flat_9 #-}
59−
60−run_readerSummatorMTL_flat_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> String
61−run_readerSummatorMTL_flat_9
43+ => m ()
44+stateCombinerMTL_flat_9 = do
45+ M.modify (L.over L._1 id')
46+ M.modify (L.over L._2 id')
47+ M.modify (L.over L._3 id')
48+ M.modify (L.over L._4 id')
49+ M.modify (L.over L._5 id')
50+ M.modify (L.over L._6 id')
51+ M.modify (L.over L._7 id')
52+ M.modify (L.over L._8 id')
53+ M.modify (L.over L._9 id')
54+ rnf <$> sequenceA
55+ [ L.use L._1
56+ , L.use L._2
57+ , L.use L._3
58+ , L.use L._4
59+ , L.use L._5
60+ , L.use L._6
61+ , L.use L._7
62+ , L.use L._8
63+ , L.use L._9 ]
64+{-# NOINLINE stateCombinerMTL_flat_9 #-}
65+
66+run_readerCombinerMTL_flat_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> ()
67+run_readerCombinerMTL_flat_9
6268 (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)
6470
65−run_stateSummatorMTL_flat_9 ::
71+run_stateCombinerMTL_flat_9 ::
6672 (Int, Int, Int, Int, Int, Int, Int, Int, Int) ->
67− (String, (Int, Int, Int, Int, Int, Int, Int, Int, Int))
68−run_stateSummatorMTL_flat_9
73+ ((), (Int, Int, Int, Int, Int, Int, Int, Int, Int))
74+run_stateCombinerMTL_flat_9
6975 (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)
7177
72−readerSummatorEther_sep_9
78+readerCombinerEther_sep_9
7379 :: ( E.MonadReader 1 Int m
7480 , E.MonadReader 2 Int m
7581 , E.MonadReader 3 Int m
@@ -79,20 +85,20 @@ readerSummatorEther_sep_9
7985 , E.MonadReader 7 Int m
8086 , E.MonadReader 8 Int m
8187 , E.MonadReader 9 Int m )
82− => m String
83−readerSummatorEther_sep_9 = concat <$> sequenceA
84− [ show <$> E.ask @1
85− , show <$> E.ask @2
86− , show <$> E.ask @3
87− , show <$> E.ask @4
88− , show <$> E.ask @5
89− , show <$> E.ask @6
90− , show <$> E.ask @7
91− , show <$> E.ask @8
92− , show <$> E.ask @9 ]
93−{-# NOINLINE readerSummatorEther_sep_9 #-}
94−
95−stateSummatorEther_sep_9
88+ => m ()
89+readerCombinerEther_sep_9 = rnf <$> sequenceA
90+ [ E.ask @1
91+ , E.ask @2
92+ , E.ask @3
93+ , E.ask @4
94+ , E.ask @5
95+ , E.ask @6
96+ , E.ask @7
97+ , E.ask @8
98+ , E.ask @9 ]
99+{-# NOINLINE readerCombinerEther_sep_9 #-}
100+
101+stateCombinerEther_sep_9
96102 :: ( E.MonadState 1 Int m
97103 , E.MonadState 2 Int m
98104 , E.MonadState 3 Int m
@@ -102,30 +108,30 @@ stateSummatorEther_sep_9
102108 , E.MonadState 7 Int m
103109 , E.MonadState 8 Int m
104110 , E.MonadState 9 Int m )
105− => m String
106−stateSummatorEther_sep_9 = do
107− E.modify @1 (+1)
108− E.modify @2 (+2)
109− E.modify @3 (+3)
110− E.modify @4 (+4)
111− E.modify @5 (+5)
112− E.modify @6 (+6)
113− E.modify @7 (+7)
114− E.modify @8 (+8)
115− E.modify @9 (+9)
116− concat <$> sequenceA
117− [ show <$> E.get @1
118− , show <$> E.get @2
119− , show <$> E.get @3
120− , show <$> E.get @4
121− , show <$> E.get @5
122− , show <$> E.get @6
123− , show <$> E.get @7
124− , show <$> E.get @8
125− , show <$> E.get @9 ]
126−
127−run_readerSummatorEther_nested_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> String
128−run_readerSummatorEther_nested_9
111+ => m ()
112+stateCombinerEther_sep_9 = do
113+ E.modify @1 id'
114+ E.modify @2 id'
115+ E.modify @3 id'
116+ E.modify @4 id'
117+ E.modify @5 id'
118+ E.modify @6 id'
119+ E.modify @7 id'
120+ E.modify @8 id'
121+ E.modify @9 id'
122+ rnf <$> sequenceA
123+ [ E.get @1
124+ , E.get @2
125+ , E.get @3
126+ , E.get @4
127+ , E.get @5
128+ , E.get @6
129+ , E.get @7
130+ , E.get @8
131+ , E.get @9 ]
132+
133+run_readerCombinerEther_nested_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> ()
134+run_readerCombinerEther_nested_9
129135 (a1, a2, a3, a4, a5, a6, a7, a8, a9)
130136 = flip (E.runReader @9) a1
131137 . flip (E.runReaderT @8) a2
@@ -136,36 +142,33 @@ run_readerSummatorEther_nested_9
136142 . flip (E.runReaderT @3) a7
137143 . flip (E.runReaderT @2) a8
138144 . flip (E.runReaderT @1) a9
139− $ readerSummatorEther_sep_9
145+ $ readerCombinerEther_sep_9
140146
141−run_readerSummatorEther_flatten_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> String
142−run_readerSummatorEther_flatten_9
147+run_readerCombinerEther_flatten_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> ()
148+run_readerCombinerEther_flatten_9
143149 (a1, a2, a3, a4, a5, a6, a7, a8, a9)
144150 =
145− E.F.runReader
146− readerSummatorEther_sep_9
147− ( load @1 a9 <+> load @2 a8 <+> load @3 a7 <+> load @4 a6 <+>
148− load @5 a5 <+> load @6 a4 <+> load @7 a3 <+> load @8 a2 <+>
149− load @9 a1 )
150−
151−run_readerSummatorEther_flattenhalf_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> String
152−run_readerSummatorEther_flattenhalf_9
151+ E.F.runReader @'[1,2,3,4,5,6,7,8,9]
152+ readerCombinerEther_sep_9
153+ (P9 a9 a8 a7 a6 a5 a4 a3 a2 a1)
154+
155+
156+run_readerCombinerEther_flattenhalf_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> ()
157+run_readerCombinerEther_flattenhalf_9
153158 (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)
155− . flip E.F.runReaderT (load @5 a5 <+> load @6 a4 <+> load @7 a3 <+> load @8 a2 <+> load @9 a1)
156− $ readerSummatorEther_sep_9
159+ = flip (E.F.runReader @'[1,2,3,4]) (P4 a9 a8 a7 a6)
160+ . flip (E.F.runReaderT @'[5,6,7,8,9]) (P5 a5 a4 a3 a2 a1)
161+ $ readerCombinerEther_sep_9
157162
158−run_stateSummatorEther_flatten_9 ::
163+run_stateCombinerEther_flatten_9 ::
159164 (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])
161−run_stateSummatorEther_flatten_9
165+ ((), Product '[1,2,3,4,5,6,7,8,9] '[Int,Int,Int,Int,Int,Int,Int,Int,Int])
166+run_stateCombinerEther_flatten_9
162167 (a1, a2, a3, a4, a5, a6, a7, a8, a9)
163168 =
164169 E.F.runState
165− stateSummatorEther_sep_9
166− ( load @1 a9 <+> load @2 a8 <+> load @3 a7 <+> load @4 a6 <+>
167− load @5 a5 <+> load @6 a4 <+> load @7 a3 <+> load @8 a2 <+>
168− load @9 a1 )
170+ stateCombinerEther_sep_9
171+ (P9 a9 a8 a7 a6 a5 a4 a3 a2 a1)
169172
170173tuple_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int)
171174tuple_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)
173176main :: IO ()
174177main = do
175178 defaultMain
176− [ bench "readerSummatorMTL_flat_9" $ nf run_readerSummatorMTL_flat_9 tuple_9
177− , bench "readerSummatorEther_nested_9" $ nf run_readerSummatorEther_nested_9 tuple_9
178− , bench "readerSummatorEther_flatten_9" $ nf run_readerSummatorEther_flatten_9 tuple_9
179− , bench "readerSummatorEther_flattenhalf_9" $
180− nf run_readerSummatorEther_flattenhalf_9 tuple_9
181− , bench "stateSummatorMTL_flat_9" $ nf run_stateSummatorMTL_flat_9 tuple_9
182− , bench "stateSummatorEther_flatten_9" $ nf run_stateSummatorEther_flatten_9 tuple_9
179+ [ bench "readerCombinerMTL_flat_9" $ nf run_readerCombinerMTL_flat_9 tuple_9
180+ , bench "readerCombinerEther_nested_9" $ nf run_readerCombinerEther_nested_9 tuple_9
181+ , bench "readerCombinerEther_flatten_9" $ nf run_readerCombinerEther_flatten_9 tuple_9
182+ , bench "readerCombinerEther_flattenhalf_9" $
183+ nf run_readerCombinerEther_flattenhalf_9 tuple_9
184+ , bench "stateCombinerMTL_flat_9" $ nf run_stateCombinerMTL_flat_9 tuple_9
185+ , bench "stateCombinerEther_flatten_9" $ nf run_stateCombinerEther_flatten_9 tuple_9
183186 ]
ether-suite/ether-suite.cabal+1
@@ -57,6 +57,7 @@ benchmark bench
5757 , mtl >=2.2.1
5858 , transformers >=0.4.2
5959 , criterion >=1.1
60+ , deepseq >=1.4
6061 , lens >=4.14
6162 , ether
6263 , ether-flatten
ether-zoom/ether-zoom.cabal+1−1
@@ -37,4 +37,4 @@ library
3737 TypeApplications
3838
3939 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
1616
1717import Control.Lens
1818import Data.Reflection
19−import Control.Monad.Trans.Ether.Dispatch
19+import Control.Monad.Trans.Ether.Handler
2020import Control.Monad.Trans.Identity
2121import Control.Monad.Ether.State.Class
2222import Data.Proxy
23+import Data.Coerce
2324
2425-- | Encode type-level information for 'tagZoom'.
2526data TAG_ZOOM t z
2627
27−type TagZoomT t (z :: *) = Dispatch (TAG_ZOOM t z) IdentityT
28+type TagZoomT t (z :: *) = Handler (TAG_ZOOM t z) IdentityT
2829
2930-- | Zoom into a part of a state using a lens.
3031tagZoom
@@ -32,14 +33,18 @@ tagZoom
3233 . Lens' sOuter sInner
3334 -> (forall z . Reifies z (ReifiedLens' sOuter sInner) => TagZoomT tag z m a)
3435 -> 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))
3637
3738instance
3839 ( MonadState tag sOuter m
3940 , Reifies z (ReifiedLens' sOuter sInner)
4041 , trans ~ IdentityT
41− ) => MonadState tag sInner (Dispatch (TAG_ZOOM tag z) trans m)
42+ ) => MonadState tag sInner (Handler (TAG_ZOOM tag z) trans m)
4243 where
43− state t =
44− let Lens l = reflect (Proxy :: Proxy z)
45− in pack . IdentityT . state t . l
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
50+ Lens l = reflect (Proxy :: Proxy z)
ether/ether.cabal+2−3
@@ -28,7 +28,7 @@ library
2828
2929 exposed-modules: Control.Ether.Abbr
3030 Control.Ether.Implicit.Abbr
31− Control.Monad.Trans.Ether.Dispatch
31+ Control.Monad.Trans.Ether.Handler
3232 Control.Monad.Ether
3333 Control.Monad.Ether.TagAttach
3434 Control.Monad.Ether.TagReplace
@@ -73,10 +73,9 @@ library
7373 DeriveGeneric
7474 FlexibleInstances
7575 GeneralizedNewtypeDeriving
76− MagicHash
7776 TypeFamilies
7877 TypeOperators
7978 UndecidableInstances
8079
8180 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−
21-- | This module provides convenience exports of all
32-- tagged monad classes from Ether.
43
ether/src/Control/Monad/Ether/Except.hs+21−26
@@ -1,11 +1,8 @@
1−{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
2−
31{-# LANGUAGE DataKinds #-}
42{-# LANGUAGE FlexibleInstances #-}
53{-# LANGUAGE UndecidableInstances #-}
64{-# LANGUAGE TypeFamilies #-}
75{-# LANGUAGE AllowAmbiguousTypes #-}
8−{-# LANGUAGE MagicHash #-}
96
107-- | See "Control.Monad.Except".
118
@@ -27,21 +24,12 @@ module Control.Monad.Ether.Except
2724 , handle
2825 ) where
2926
30−import GHC.Prim (Proxy#, proxy#)
31−import Control.Monad.Ether.Except.Class (MonadExcept)
32−import qualified Control.Monad.Ether.Except.Class as C
33−import qualified Control.Monad.Trans.Ether.Dispatch as D
34−import qualified Control.Monad.Trans.Except as T
27+import Control.Monad.Ether.Except.Class
28+import qualified Control.Monad.Trans.Ether.Handler as D
29+import qualified Control.Monad.Except as T
30+import Control.Monad.Signatures (Catch)
3531import Data.Functor.Identity
36−
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)
32+import Data.Coerce
4533
4634-- | Runs an 'Except' and handles the exception with the given function.
4735handle :: 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
5240handleT h m = fmap (either h id) (runExceptT @tag m)
5341
5442-- | Encode type-level information for 'ExceptT'.
55−data EXCEPT t e
43+data EXCEPT
5644
5745-- | The parameterizable exception monad.
5846--
@@ -66,23 +54,30 @@ type Except tag e = ExceptT tag e Identity
6654--
6755-- The 'return' function returns a normal value, while '>>=' exits on
6856-- 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)
7058
7159-- | Runs an 'Except' and returns either an exception or a normal value.
7260runExcept :: forall tag e a . Except tag e a -> Either e a
73−runExcept = T.runExcept . D.unpack
61+runExcept = coerce (T.runExcept @e @a)
7462
7563-- | Runs an 'ExceptT' and returns either an exception or a normal value.
7664runExceptT :: 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)
7866
7967-- | Constructor for computations in the exception monad transformer.
8068exceptT :: 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)
8270
8371instance
84− ( Monad m, e ~ e', trans ~ T.ExceptT e
85− ) => MonadExcept tag e (D.Dispatch (EXCEPT tag e') trans m)
72+ ( T.MonadError e (trans m) -- FIXME: (forall m . T.MonadError e (trans m))
73+ ) => MonadExcept tag e (D.Handler '(EXCEPT, tag) trans (m :: * -> *))
8674 where
87− throw _ = D.pack . T.throwE
88− catch _ m h = D.pack $ T.catchE (D.unpack m) (D.unpack . h)
75+ throw =
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 @@
11{-# LANGUAGE FlexibleInstances #-}
22{-# LANGUAGE UndecidableInstances #-}
33{-# LANGUAGE TypeFamilies #-}
4−{-# LANGUAGE MagicHash #-}
4+{-# LANGUAGE AllowAmbiguousTypes #-}
55
66-- | See "Control.Monad.Except".
77
@@ -9,23 +9,22 @@ module Control.Monad.Ether.Except.Class
99 ( MonadExcept(..)
1010 ) where
1111
12−import GHC.Prim (Proxy#)
1312import qualified Control.Monad.Trans.Lift.Catch as Lift
1413
1514-- | See 'Control.Monad.Except.MonadError'.
1615class Monad m => MonadExcept tag e m | m tag -> e where
1716
1817 -- | Is used within a monadic computation to begin exception processing.
19− throw :: Proxy# tag -> e -> m a
18+ throw :: e -> m a
2019
2120 -- | A handler function to handle previous exceptions and return to
2221 -- normal execution.
23− catch :: Proxy# tag -> m a -> (e -> m a) -> m a
22+ catch :: m a -> (e -> m a) -> m a
2423
2524instance {-# OVERLAPPABLE #-}
2625 ( Lift.LiftCatch t
2726 , Monad (t m)
2827 , MonadExcept tag e m
2928 ) => MonadExcept tag e (t m) where
30− throw t = Lift.lift . throw t
31− catch t = Lift.liftCatch (catch t)
29+ throw = Lift.lift . throw @tag
30+ catch = Lift.liftCatch (catch @tag)
ether/src/Control/Monad/Ether/Implicit.hs−1
@@ -1,4 +1,3 @@
1−
21-- | This module provides convenience exports of all
32-- implicitly tagged monad classes from Ether.
43
ether/src/Control/Monad/Ether/Implicit/State.hs−1
@@ -1,4 +1,3 @@
1−
21-- | See "Control.Monad.Ether.State".
32
43module 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−
31{-# LANGUAGE DataKinds #-}
42{-# LANGUAGE FlexibleInstances #-}
53{-# LANGUAGE UndecidableInstances #-}
64{-# LANGUAGE TypeFamilies #-}
75{-# LANGUAGE AllowAmbiguousTypes #-}
8−{-# LANGUAGE MagicHash #-}
96
107-- | See "Control.Monad.Reader".
118
@@ -26,36 +23,12 @@ module Control.Monad.Ether.Reader
2623 , runReaderT
2724 ) where
2825
29−import GHC.Prim (Proxy#, proxy#)
30−import Control.Monad.Ether.Reader.Class (MonadReader)
31−import qualified Control.Monad.Ether.Reader.Class as C
32−import qualified Control.Monad.Trans.Ether.Dispatch as D
33−import qualified Control.Monad.Trans.Reader as T
26+import Control.Monad.Ether.Reader.Class
27+import qualified Control.Monad.Trans.Ether.Handler as D
28+import Control.Monad.Trans.Lift.Local (Local)
29+import qualified Control.Monad.Reader as T
3430import Data.Functor.Identity
35−
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)
31+import Data.Coerce
5932
6033-- | Retrieves a function of the current environment.
6134asks
@@ -64,10 +37,11 @@ asks
6437 => (r -> a)
6538 -- ^ The selector function to apply to the environment.
6639 -> m a
67−asks = C.reader (proxy# :: Proxy# tag)
40+asks = reader @tag
41+{-# INLINE asks #-}
6842
6943-- | Encode type-level information for 'ReaderT'.
70−data READER t r
44+data READER
7145
7246-- | The parameterizable reader monad.
7347--
@@ -82,26 +56,41 @@ type Reader tag r = ReaderT tag r Identity
8256--
8357-- The 'return' function ignores the environment, while '>>=' passes
8458-- 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)
8660
8761-- | Constructor for computations in the reader monad transformer.
8862readerT :: 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 #-}
9065
9166-- | Runs a 'ReaderT' with the given environment
9267-- and returns the final value.
9368runReaderT :: 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 #-}
9571
9672-- | Runs a 'ReaderT' with the given environment
9773-- and returns the final value.
9874runReader :: 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 #-}
10077
10178instance
102− ( Monad m, r ~ r', trans ~ T.ReaderT r
103− ) => MonadReader tag r (D.Dispatch (READER tag r') trans m)
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'
82+ ) => MonadReader tag r (D.Handler '(READER, tag) trans (m :: * -> *))
10483 where
105− ask _ = D.pack T.ask
106− local _ f = D.pack . T.withReaderT f . D.unpack
107− reader _ = D.pack . T.reader
84+
85+ ask = coerce (T.ask @r @(trans m))
86+ {-# INLINE ask #-}
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 @@
11{-# LANGUAGE FlexibleInstances #-}
22{-# LANGUAGE UndecidableInstances #-}
33{-# LANGUAGE TypeFamilies #-}
4−{-# LANGUAGE MagicHash #-}
4+{-# LANGUAGE TypeOperators #-}
5+{-# LANGUAGE DataKinds #-}
6+{-# LANGUAGE AllowAmbiguousTypes #-}
57
68-- | See "Control.Monad.Reader.Class".
79
@@ -9,8 +11,9 @@ module Control.Monad.Ether.Reader.Class
911 ( MonadReader(..)
1012 ) where
1113
12−import GHC.Prim (Proxy#)
14+import Control.Monad.Trans.Ether.Handler
1315import qualified Control.Monad.Trans.Lift.Local as Lift
16+import Data.Coerce
1417
1518-- | See 'Control.Monad.Reader.MonadReader'.
1619class 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
1821 {-# MINIMAL (ask | reader), local #-}
1922
2023 -- | Retrieves the monad environment.
21− ask :: Proxy# tag -> m r
22− ask t = reader t id
24+ ask :: m r
25+ ask = reader @tag id
2326
2427 -- | Executes a computation in a modified environment.
2528 local
26− :: Proxy# tag
27− -> (r -> r)
29+ :: (r -> r)
2830 -- ^ The function to modify the environment.
2931 -> m a
3032 -- ^ @Reader@ to run in the modified environment.
@@ -32,16 +34,36 @@ class Monad m => MonadReader tag r m | m tag -> r where
3234
3335 -- | Retrieves a function of the current environment.
3436 reader
35− :: Proxy# tag
36− -> (r -> a)
37+ :: (r -> a)
3738 -- ^ The selector function to apply to the environment.
3839 -> m a
39− reader t f = fmap f (ask t)
40+ reader f = fmap f (ask @tag)
4041
4142instance {-# OVERLAPPABLE #-}
42− ( Lift.LiftLocal t
43− , Monad (t m)
44− , MonadReader tag r m
45− ) => MonadReader tag r (t m) where
46− ask t = Lift.lift (ask t)
47− local t = Lift.liftLocal (ask t) (local t)
43+ ( Lift.LiftLocal t
44+ , Monad (t m)
45+ , MonadReader tag r m
46+ ) => MonadReader tag r (t m)
47+ where
48+ ask = Lift.lift (ask @tag)
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−
21-- | See "Control.Monad.State".
32
43module Control.Monad.Ether.State
ether/src/Control/Monad/Ether/State/Class.hs+50−19
@@ -1,7 +1,9 @@
11{-# LANGUAGE FlexibleInstances #-}
22{-# LANGUAGE UndecidableInstances #-}
33{-# LANGUAGE TypeFamilies #-}
4−{-# LANGUAGE MagicHash #-}
4+{-# LANGUAGE TypeOperators #-}
5+{-# LANGUAGE DataKinds #-}
6+{-# LANGUAGE AllowAmbiguousTypes #-}
57
68-- | See "Control.Monad.State.Class".
79
@@ -9,8 +11,9 @@ module Control.Monad.Ether.State.Class
911 ( MonadState(..)
1012 ) where
1113
12−import GHC.Prim (Proxy#)
14+import Control.Monad.Trans.Ether.Handler
1315import qualified Control.Monad.Trans as Lift
16+import Data.Coerce
1417
1518-- | See 'Control.Monad.State.MonadState'.
1619class 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
1821 {-# MINIMAL state | get, put #-}
1922
2023 -- | Return the state from the internals of the monad.
21− get :: Proxy# tag -> m s
22− get t = state t (\s -> (s, s))
24+ get :: m s
25+ get = state @tag (\s -> (s, s))
2326
2427 -- | Replace the state inside the monad.
25− put :: Proxy# tag -> s -> m ()
26− put t s = state t (\_ -> ((), s))
28+ put :: s -> m ()
29+ put s = state @tag (\_ -> ((), s))
2730
2831 -- | Embed a simple state action into the monad.
29− state :: Proxy# tag -> (s -> (a, s)) -> m a
30− state t f = do
31− s <- get t
32− let ~(a, s') = f s
33− put t s'
34− return a
32+ state :: (s -> (a, s)) -> m a
33+ state f = do
34+ s <- get @tag
35+ let ~(a, s') = f s
36+ put @tag s'
37+ return a
3538
3639instance {-# OVERLAPPABLE #-}
37− ( Lift.MonadTrans t
38− , Monad (t m)
39− , MonadState tag s m
40− ) => MonadState tag s (t m) where
41− get t = Lift.lift (get t)
42− put t = Lift.lift . put t
43− state t = Lift.lift . state t
40+ ( Lift.MonadTrans t
41+ , Monad (t m)
42+ , MonadState tag s m
43+ ) => MonadState tag s (t m)
44+ where
45+ get = Lift.lift (get @tag)
46+ put = Lift.lift . put @tag
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 #-}
12{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE MagicHash #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE UndecidableInstances #-}
35
46module Control.Monad.Ether.State.Common
57 ( MonadState
@@ -8,28 +10,39 @@ module Control.Monad.Ether.State.Common
810 , state
911 , modify
1012 , gets
13+ , STATE
1114 ) where
1215
13−import GHC.Prim (Proxy#, proxy#)
14−import Control.Monad.Ether.State.Class (MonadState)
15−import qualified Control.Monad.Ether.State.Class as C
16+import Control.Monad.Ether.State.Class
17+import qualified Control.Monad.State as T
18+import qualified Control.Monad.Trans.Ether.Handler as D
19+import Data.Coerce
1620
17−-- | Return the state from the internals of the monad.
18−get :: forall tag s m . MonadState tag s m => m s
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)
21+-- | Encode type-level information for 'StateT'.
22+data STATE
2823
2924-- | Modifies the state inside a state monad.
3025modify :: forall tag s m . MonadState tag s m => (s -> s) -> m ()
3126modify f = state @tag (\s -> ((), f s))
27+{-# INLINABLE modify #-}
3228
3329-- | Gets specific component of the state, using a projection function supplied.
3430gets :: forall tag s m a . MonadState tag s m => (s -> a) -> m a
3531gets 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−
31{-# LANGUAGE DataKinds #-}
42{-# LANGUAGE FlexibleInstances #-}
53{-# LANGUAGE UndecidableInstances #-}
@@ -30,13 +28,10 @@ module Control.Monad.Ether.State.Lazy
3028 ) where
3129
3230import Control.Monad.Ether.State.Common
33−import qualified Control.Monad.Ether.State.Class as C
34−import qualified Control.Monad.Trans.Ether.Dispatch as D
31+import qualified Control.Monad.Trans.Ether.Handler as D
3532import qualified Control.Monad.Trans.State.Lazy as T
3633import Data.Functor.Identity
37−
38−-- | Encode type-level information for 'StateT'.
39−data STATE t s
34+import Data.Coerce
4035
4136-- | The parametrizable state monad.
4237--
@@ -50,46 +45,45 @@ type State tag r = StateT tag r Identity
5045--
5146-- The 'return' function leaves the state unchanged, while '>>=' uses
5247-- 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)
5449
5550-- | Constructor for computations in the state monad transformer.
5651stateT :: 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 #-}
5854
5955-- | Runs a 'StateT' with the given initial state
6056-- and returns both the final value and the final state.
6157runStateT :: 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 #-}
6360
6461-- | Runs a 'StateT' with the given initial state
6562-- and returns the final value, discarding the final state.
6663evalStateT :: 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 #-}
6866
6967-- | Runs a 'StateT' with the given initial state
7068-- and returns the final state, discarding the final value.
7169execStateT :: 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 #-}
7372
7473-- | Runs a 'State' with the given initial state
7574-- and returns both the final value and the final state.
7675runState :: 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 #-}
7878
7979-- | Runs a 'State' with the given initial state
8080-- and returns the final value, discarding the final state.
8181evalState :: 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 #-}
8384
8485-- | Runs a 'State' with the given initial state
8586-- and returns the final state, discarding the final value.
8687execState :: forall tag s a . State tag s a -> s -> s
87−execState = T.execState . D.unpack
88−
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
88+execState = coerce (T.execState @s @a)
89+{-# INLINE execState #-}
ether/src/Control/Monad/Ether/State/Strict.hs+17−23
@@ -1,5 +1,3 @@
1−{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
2−
31{-# LANGUAGE DataKinds #-}
42{-# LANGUAGE FlexibleInstances #-}
53{-# LANGUAGE UndecidableInstances #-}
@@ -30,13 +28,10 @@ module Control.Monad.Ether.State.Strict
3028 ) where
3129
3230import Control.Monad.Ether.State.Common
33−import qualified Control.Monad.Ether.State.Class as C
34−import qualified Control.Monad.Trans.Ether.Dispatch as D
31+import qualified Control.Monad.Trans.Ether.Handler as D
3532import qualified Control.Monad.Trans.State.Strict as T
3633import Data.Functor.Identity
37−
38−-- | Encode type-level information for 'StateT'.
39−data STATE t s
34+import Data.Coerce
4035
4136-- | The parametrizable state monad.
4237--
@@ -50,46 +45,45 @@ type State tag r = StateT tag r Identity
5045--
5146-- The 'return' function leaves the state unchanged, while '>>=' uses
5247-- 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)
5449
5550-- | Constructor for computations in the state monad transformer.
5651stateT :: 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 #-}
5854
5955-- | Runs a 'StateT' with the given initial state
6056-- and returns both the final value and the final state.
6157runStateT :: 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 #-}
6360
6461-- | Runs a 'StateT' with the given initial state
6562-- and returns the final value, discarding the final state.
6663evalStateT :: 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 #-}
6866
6967-- | Runs a 'StateT' with the given initial state
7068-- and returns the final state, discarding the final value.
7169execStateT :: 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 #-}
7372
7473-- | Runs a 'State' with the given initial state
7574-- and returns both the final value and the final state.
7675runState :: 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 #-}
7878
7979-- | Runs a 'State' with the given initial state
8080-- and returns the final value, discarding the final state.
8181evalState :: 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 #-}
8384
8485-- | Runs a 'State' with the given initial state
8586-- and returns the final state, discarding the final value.
8687execState :: forall tag s a . State tag s a -> s -> s
87−execState = T.execState . D.unpack
88−
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
88+execState = coerce (T.execState @s @a)
89+{-# INLINE execState #-}
ether/src/Control/Monad/Ether/TagAttach.hs+15−14
@@ -1,5 +1,3 @@
1−{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
2−
31{-# LANGUAGE DeriveGeneric #-}
42{-# LANGUAGE TypeFamilies #-}
53{-# LANGUAGE FlexibleInstances #-}
@@ -8,7 +6,7 @@
86{-# LANGUAGE GeneralizedNewtypeDeriving #-}
97
108module Control.Monad.Ether.TagAttach
11− ( TAG_ATTACH(..)
9+ ( TAG_ATTACH
1210 , TagAttachT
1311 , tagAttach
1412 ) where
@@ -30,43 +28,46 @@ import qualified Control.Monad.State.Class as Class
3028import qualified Control.Monad.Writer.Class as Class
3129import qualified Control.Monad.Error.Class as Class
3230
33−import Control.Monad.Trans.Ether.Dispatch
31+import Control.Monad.Trans.Ether.Handler
32+
33+import Data.Coerce
3434
3535-- | Encode type-level information for 'tagAttach'.
36−data TAG_ATTACH t = TAG_ATTACH t
36+data TAG_ATTACH t
3737
38−type TagAttachT t = Dispatch (TAG_ATTACH t) IdentityT
38+type TagAttachT t = Handler (TAG_ATTACH t) IdentityT
3939
4040-- | Attach a tag to untagged transformers.
4141tagAttach :: forall tag m a . TagAttachT tag m a -> m a
42−tagAttach = runIdentityT . unpack
42+tagAttach = coerce (runIdentityT @_ @m @a)
43+{-# INLINE tagAttach #-}
4344
4445instance
4546 ( 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)
4748 where
48− ask = A.ask @tag
49+ ask = A.ask @tag
4950 local = A.local @tag
5051
5152instance
5253 ( 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)
5455 where
5556 get = A.get @tag
5657 put = A.put @tag
5758
5859instance
5960 ( 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)
6162 where
6263 throwError = A.throw @tag
6364 catchError = A.catch @tag
6465
6566instance
6667 ( 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)
6869 where
6970 writer = A.writer @tag
70− tell = A.tell @tag
71+ tell = A.tell @tag
7172 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−
31{-# LANGUAGE DeriveGeneric #-}
42{-# LANGUAGE TypeFamilies #-}
53{-# LANGUAGE FlexibleInstances #-}
@@ -25,43 +23,46 @@ import Control.Monad.Ether.State.Common as A
2523import Control.Monad.Ether.Except as A
2624import Control.Monad.Ether.Writer as A
2725
28−import Control.Monad.Trans.Ether.Dispatch
26+import Control.Monad.Trans.Ether.Handler
27+
28+import Data.Coerce
2929
3030-- | Encode type-level information for 'tagReplace'.
3131data TAG_REPLACE tOld tNew
3232
33−type TagReplaceT tOld tNew = Dispatch (TAG_REPLACE tOld tNew) IdentityT
33+type TagReplaceT tOld tNew = Handler (TAG_REPLACE tOld tNew) IdentityT
3434
3535-- | Replace a tag with another tag.
3636tagReplace :: 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 #-}
3839
3940instance
4041 ( 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)
4243 where
43− ask _ = A.ask @tNew
44− local _ = A.local @tNew
44+ ask = A.ask @tNew
45+ local = A.local @tNew
4546
4647instance
4748 ( 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)
4950 where
50− get _ = A.get @tNew
51− put _ = A.put @tNew
51+ get = A.get @tNew
52+ put = A.put @tNew
5253
5354instance
5455 ( 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)
5657 where
57− throw _ = A.throw @tNew
58− catch _ = A.catch @tNew
58+ throw = A.throw @tNew
59+ catch = A.catch @tNew
5960
6061instance
6162 ( 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)
6364 where
64− writer _ = A.writer @tNew
65− tell _ = A.tell @tNew
66− listen _ = A.listen @tNew
67− pass _ = A.pass @tNew
65+ writer = A.writer @tNew
66+ tell = A.tell @tNew
67+ listen = A.listen @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−
31{-# LANGUAGE DataKinds #-}
42{-# LANGUAGE FlexibleInstances #-}
53{-# LANGUAGE UndecidableInstances #-}
64{-# LANGUAGE TypeFamilies #-}
75{-# LANGUAGE AllowAmbiguousTypes #-}
8−{-# LANGUAGE MagicHash #-}
96
107-- | See "Control.Monad.Writer".
118
@@ -30,30 +27,12 @@ module Control.Monad.Ether.Writer
3027 , execWriterT
3128 ) where
3229
33−import GHC.Prim (Proxy#, proxy#)
34−import Control.Monad.Ether.Writer.Class (MonadWriter)
35−import qualified Control.Monad.Ether.Writer.Class as C
36−import qualified Control.Monad.Trans.Ether.Dispatch as D
37−import qualified Control.Monad.Trans.Writer as T
30+import Control.Monad.Ether.Writer.Class
31+import qualified Control.Monad.Trans.Ether.Handler as D
32+import qualified Control.Monad.Writer as T
3833import Data.Functor.Identity
39−
40−-- | Embed a simple writer action.
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)
34+import Control.Monad.Signatures (Listen, Pass)
35+import Data.Coerce
5736
5837-- | Execute an action and add the result of applying the given function to
5938-- its accumulator to the value of the computation.
@@ -69,7 +48,7 @@ censor f m = pass @tag $ do
6948 return (a, f)
7049
7150-- | Encode type-level information for 'WriterT'.
72−data WRITER t w
51+data WRITER
7352
7453-- | The parametrizable writer monad.
7554--
@@ -83,37 +62,51 @@ type Writer tag w = WriterT tag w Identity
8362--
8463-- The 'return' function produces the output 'mempty', while '>>=' combines
8564-- 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)
8766
8867-- | Constructor for computations in the writer monad transformer.
8968writerT :: 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)
9170
9271-- | Runs a 'WriterT' and returns both the normal value
9372-- and the final accumulator.
9473runWriterT :: 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)
9675
9776-- | Runs a 'Writer' and returns both the normal value
9877-- and the final accumulator.
9978runWriter :: forall tag w a . Writer tag w a -> (a, w)
100−runWriter = T.runWriter . D.unpack
79+runWriter = coerce (T.runWriter @w @a)
10180
10281-- | Runs a 'WriterT' and returns the final accumulator,
10382-- discarding the normal value.
10483execWriterT :: 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)
10685
10786-- | Runs a 'Writer' and returns the final accumulator,
10887-- discarding the normal value.
10988execWriter :: forall tag w a . Writer tag w a -> w
110−execWriter = T.execWriter . D.unpack
89+execWriter = coerce (T.execWriter @w @a)
11190
11291instance
113− ( Monoid w, Monad m, w ~ w', trans ~ T.WriterT w
114− ) => MonadWriter tag w (D.Dispatch (WRITER tag w') trans m)
92+ ( T.MonadWriter w (trans m) -- FIXME: (forall m . T.MonadWriter w (trans m))
93+ ) => MonadWriter tag w (D.Handler '(WRITER, tag) trans (m :: * -> *))
11594 where
116− writer _ = D.pack . T.writer
117− tell _ = D.pack . T.tell
118− listen _ = D.pack . T.listen . D.unpack
119− pass _ = D.pack . T.pass . D.unpack
95+
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+
101+ tell = coerce (T.tell @w @(trans m))
102+ {-# INLINE tell #-}
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 @@
11{-# LANGUAGE FlexibleInstances #-}
22{-# LANGUAGE UndecidableInstances #-}
33{-# LANGUAGE TypeFamilies #-}
4−{-# LANGUAGE MagicHash #-}
4+{-# LANGUAGE AllowAmbiguousTypes #-}
55
66-- | See "Control.Monad.Writer.Class".
77
@@ -9,7 +9,6 @@ module Control.Monad.Ether.Writer.Class
99 ( MonadWriter(..)
1010 ) where
1111
12−import GHC.Prim (Proxy#)
1312import qualified Control.Monad.Trans.Lift.Listen as Lift
1413import qualified Control.Monad.Trans.Lift.Pass as Lift
1514
@@ -19,22 +18,22 @@ class (Monoid w, Monad m) => MonadWriter tag w m | m tag -> w where
1918 {-# MINIMAL (writer | tell), listen, pass #-}
2019
2120 -- | Embed a simple writer action.
22− writer :: Proxy# tag -> (a, w) -> m a
23− writer t ~(a, w) = do
24− tell t w
21+ writer :: (a, w) -> m a
22+ writer ~(a, w) = do
23+ tell @tag w
2524 return a
2625
2726 -- | Append a value to the accumulator within the monad.
28− tell :: Proxy# tag -> w -> m ()
29− tell t w = writer t ((),w)
27+ tell :: w -> m ()
28+ tell w = writer @tag ((),w)
3029
3130 -- | Execute an action and add its accumulator
3231 -- to the value of the computation.
33− listen :: Proxy# tag -> m a -> m (a, w)
32+ listen :: m a -> m (a, w)
3433
3534 -- | Execute an action which returns a value and a function,
3635 -- 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
3837
3938instance {-# OVERLAPPABLE #-}
4039 ( Lift.LiftListen t
@@ -43,7 +42,7 @@ instance {-# OVERLAPPABLE #-}
4342 , MonadWriter tag w m
4443 , Monoid w
4544 ) => MonadWriter tag w (t m) where
46− writer t = Lift.lift . writer t
47− tell t = Lift.lift . tell t
48− listen t = Lift.liftListen (listen t)
49− pass t = Lift.liftPass (pass t)
45+ writer = Lift.lift . writer @tag
46+ tell = Lift.lift . tell @tag
47+ listen = Lift.liftListen (listen @tag)
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