git.iko.soy/typeable/ether
on master help sign in
Handle class & tuple-based flattening
0b0b8bbVladislav Zavialov
ether-flatten/ether-flatten.cabal+1−2
compare with master
unifiedsplit
@@ -25,8 +25,7 @@ library
25
25
26 exposed-modules: Control.Monad.Ether.Reader.Flatten
26 exposed-modules: Control.Monad.Ether.Reader.Flatten
27 , Control.Monad.Ether.State.Flatten
27 , Control.Monad.Ether.State.Flatten
28− , Control.Ether.Flatten
29− build-depends: base >=4.9 && <4.10
28+ build-depends: base >=4.9 && <4.11
30 , ether >=0.5 && <0.6
29 , ether >=0.5 && <0.6
31 , mtl >=2.2.1
30 , mtl >=2.2.1
32 , transformers >=0.4.2
31 , transformers >=0.4.2
ether-flatten/src/Control/Ether/Flatten.hsdeleted−237
@@ -1,237 +0,0 @@
1−{-# LANGUAGE RankNTypes #-}
2−{-# LANGUAGE TypeSynonymInstances #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE TypeOperators #-}
5−{-# LANGUAGE UndecidableInstances #-}
6−{-# LANGUAGE FlexibleInstances #-}
7−{-# LANGUAGE GADTs #-}
8−{-# LANGUAGE TypeFamilies #-}
9−{-# LANGUAGE TemplateHaskell #-}
10−{-# LANGUAGE StandaloneDeriving #-}
11−{-# LANGUAGE AllowAmbiguousTypes #-}
12−{-# LANGUAGE DeriveGeneric #-}
13−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
14−
15−module Control.Ether.Flatten
16− ( HasLens(..)
17− , Product(..)
18− ) where
19−
20−import Control.DeepSeq
21−import Control.Lens
22−import GHC.Generics (Generic)
23−
24−class HasLens tag outer inner | tag outer -> inner where
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 #-}
78−
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)
87−
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])
95−
96−instance
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+18−42
@@ -6,58 +6,34 @@
6{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE FlexibleInstances #-}
7{-# LANGUAGE GADTs #-}
7{-# LANGUAGE GADTs #-}
8{-# LANGUAGE TypeFamilies #-}
8{-# LANGUAGE TypeFamilies #-}
9+{-# LANGUAGE AllowAmbiguousTypes #-}
10+{-# LANGUAGE TypeInType #-}
11+{-# LANGUAGE ConstraintKinds #-}
9
12
10module Control.Monad.Ether.Reader.Flatten
13module Control.Monad.Ether.Reader.Flatten
11 ( runReader
14 ( runReader
12 , runReaderT
15 , runReaderT
13 ) where
16 ) where
14
17
15−import Data.Functor.Identity
16−import Control.Monad.Ether.Reader.Class as C
18+import Control.Ether.Optic
17−import Control.Monad.Trans.Ether.Handler
18−import qualified Control.Monad.Reader as T
19import Control.Lens
19import Control.Lens
20−import Control.Ether.Flatten
20+import Control.Monad.Ether.Handle
21+import Control.Monad.Ether.Reader (READER)
22+import qualified Control.Monad.Reader as T
23+import Control.Monad.Trans.Ether.Handler
21import Data.Coerce
24import Data.Coerce
25+import Data.Kind
22
26
23−data READER
24−
25−type family READERS ts where
27+type family READERS (ts :: HList xs) :: [Type] where
26− READERS '[] = '[]
28+ READERS 'HNil = '[]
27− READERS (t ': ts) = '(READER, t) ': READERS ts
29+ READERS ('HCons t ts) = TAGGED READER t ': READERS ts
28−
29−type ReaderT ts r = Handler (READERS ts) (T.ReaderT r)
30−
31−type Reader ts r = ReaderT ts r Identity
32−
33−instance
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 :: * -> *))
37− where
38
30
39− ask =
31+type ReaderT r = Handler (READERS (Tags r)) (T.ReaderT r)
40− (coerce :: forall dp a .
41− trans m a ->
42− Handler dp trans m a)
43− (view (lensOf @tag))
44− {-# INLINE ask #-}
45
32
46− local f =
33+type Reader r = ReaderT r Identity
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))
51− {-# INLINE local #-}
52
34
53−runReaderT
35+runReaderT :: forall p m a . ReaderT p m a -> p -> m a
54− :: ReaderT tags (Product tags as) m a
55− -> Product tags as
56− -> m a
57−runReaderT m = T.runReaderT (coerce m)
36+runReaderT = coerce (T.runReaderT @p @_ @m @a)
58
37
59−runReader
38+runReader :: forall p a . Reader p a -> p -> a
60− :: Reader tags (Product tags as) a
61− -> Product tags as
62− -> a
63−runReader m = T.runReader (coerce m)
39+runReader = coerce (T.runReader @p @a)
ether-flatten/src/Control/Monad/Ether/State/Flatten.hs+17−49
@@ -6,65 +6,33 @@
6{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE FlexibleInstances #-}
7{-# LANGUAGE GADTs #-}
7{-# LANGUAGE GADTs #-}
8{-# LANGUAGE TypeFamilies #-}
8{-# LANGUAGE TypeFamilies #-}
9+{-# LANGUAGE AllowAmbiguousTypes #-}
10+{-# LANGUAGE TypeInType #-}
9
11
10module Control.Monad.Ether.State.Flatten
12module Control.Monad.Ether.State.Flatten
11 ( runState
13 ( runState
12 , runStateT
14 , runStateT
13 ) where
15 ) where
14
16
15−import Data.Functor.Identity
16−import Control.Monad.Ether.State.Class as C
17+import Control.Ether.Optic
17−import Control.Monad.Trans.Ether.Handler
18−import qualified Control.Monad.State as T
19import Control.Lens
18import Control.Lens
20−import Control.Ether.Flatten
19+import Control.Monad.Ether.Handle
20+import Control.Monad.Ether.State (STATE)
21+import qualified Control.Monad.State as T
22+import Control.Monad.Trans.Ether.Handler
21import Data.Coerce
23import Data.Coerce
24+import Data.Kind
22
25
23−data STATE
24−
25−type family STATES ts where
26+type family STATES (ts :: HList xs) :: [Type] where
26− STATES '[] = '[]
27+ STATES 'HNil = '[]
27− STATES (t ': ts) = '(STATE, t) ': STATES ts
28+ STATES ('HCons t ts) = TAGGED STATE t ': STATES ts
28−
29−type StateT ts s = Handler (STATES ts) (T.StateT s)
30−
31−type State ts s = StateT ts s Identity
32−
33−instance
34− ( Monad m, HasLens tag payload s
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)
37− where
38−
39− get =
40− (coerce :: forall dp a .
41− trans m a ->
42− Handler dp trans m a)
43− (use (lensOf @tag))
44− {-# INLINE get #-}
45
29
46− put s =
30+type StateT s = Handler (STATES (Tags s)) (T.StateT s)
47− (coerce :: forall dp a .
48− trans m a ->
49− Handler dp trans m a)
50− (T.modify (lensOf @tag .~ s))
51− {-# INLINE put #-}
52
31
53− state f =
32+type State s = StateT s Identity
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
33
60−runStateT
34+runStateT :: forall p m a . StateT p m a -> p -> m (a, p)
61− :: StateT tags (Product tags as) m a
62− -> Product tags as
63− -> m (a, Product tags as)
64−runStateT m = T.runStateT (coerce m)
35+runStateT = coerce (T.runStateT @p @m @a)
65
36
66−runState
37+runState :: forall p a . State p a -> p -> (a, p)
67− :: State tags (Product tags as) a
68− -> Product tags as
69− -> (a, Product tags as)
70−runState m = T.runState (coerce m)
38+runState = coerce (T.runState @p @a)
ether-suite/bench/Bench.hs+38−10
@@ -1,9 +1,12 @@
1+{-# OPTIONS -fno-warn-partial-type-signatures #-}
2+
1{-# LANGUAGE TypeApplications #-}
3{-# LANGUAGE TypeApplications #-}
2{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FunctionalDependencies #-}
5{-# LANGUAGE FunctionalDependencies #-}
4{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE DataKinds #-}
7{-# LANGUAGE DataKinds #-}
6{-# LANGUAGE TypeOperators #-}
8{-# LANGUAGE TypeOperators #-}
9+{-# LANGUAGE PartialTypeSignatures #-}
7
10
8module Main (main) where
11module Main (main) where
9
12
@@ -14,8 +17,8 @@ import qualified Control.Monad.Ether.Reader as E
14import qualified Control.Monad.Ether.State as E
17import qualified Control.Monad.Ether.State as E
15import qualified Control.Monad.Ether.Reader.Flatten as E.F
18import qualified Control.Monad.Ether.Reader.Flatten as E.F
16import qualified Control.Monad.Ether.State.Flatten as E.F
19import qualified Control.Monad.Ether.State.Flatten as E.F
17−import Control.Ether.Flatten
18import qualified Control.Lens as L
20import qualified Control.Lens as L
21+import Control.Ether.Optic
19import Control.DeepSeq
22import Control.DeepSeq
20
23
21id' :: a -> a
24id' :: a -> a
@@ -129,6 +132,7 @@ stateCombinerEther_sep_9 = do
129 , E.get @7
132 , E.get @7
130 , E.get @8
133 , E.get @8
131 , E.get @9 ]
134 , E.get @9 ]
135+{-# NOINLINE stateCombinerEther_sep_9 #-}
132
136
133run_readerCombinerEther_nested_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> ()
137run_readerCombinerEther_nested_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> ()
134run_readerCombinerEther_nested_9
138run_readerCombinerEther_nested_9
@@ -148,27 +152,51 @@ run_readerCombinerEther_flatten_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, In
148run_readerCombinerEther_flatten_9
152run_readerCombinerEther_flatten_9
149 (a1, a2, a3, a4, a5, a6, a7, a8, a9)
153 (a1, a2, a3, a4, a5, a6, a7, a8, a9)
150 =
154 =
151− E.F.runReader @'[1,2,3,4,5,6,7,8,9]
155+ E.F.runReader
152 readerCombinerEther_sep_9
156 readerCombinerEther_sep_9
153− (P9 a9 a8 a7 a6 a5 a4 a3 a2 a1)
157+ ( Tagged @1 a9,
154−
158+ Tagged @2 a8,
159+ Tagged @3 a7,
160+ Tagged @4 a6,
161+ Tagged @5 a5,
162+ Tagged @6 a4,
163+ Tagged @7 a3,
164+ Tagged @8 a2,
165+ Tagged @9 a1 )
155
166
156run_readerCombinerEther_flattenhalf_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> ()
167run_readerCombinerEther_flattenhalf_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> ()
157run_readerCombinerEther_flattenhalf_9
168run_readerCombinerEther_flattenhalf_9
158− (a1, a2, a3, a4, a5, a6, a7, a8, a9)
169+ (a1, a2, a3, a4, a5, a6, a7, a8, a9) =
159− = flip (E.F.runReader @'[1,2,3,4]) (P4 a9 a8 a7 a6)
170+ flip E.F.runReader
171+ ( Tagged @1 a9,
172+ Tagged @2 a8,
173+ Tagged @3 a7,
174+ Tagged @4 a6 ) .
160− . flip (E.F.runReaderT @'[5,6,7,8,9]) (P5 a5 a4 a3 a2 a1)
175+ flip E.F.runReaderT
176+ ( Tagged @5 a5,
177+ Tagged @6 a4,
178+ Tagged @7 a3,
179+ Tagged @8 a2,
180+ Tagged @9 a1 ) $
161− $ readerCombinerEther_sep_9
181+ readerCombinerEther_sep_9
162
182
163run_stateCombinerEther_flatten_9 ::
183run_stateCombinerEther_flatten_9 ::
164 (Int, Int, Int, Int, Int, Int, Int, Int, Int) ->
184 (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])
185+ ((), _)
166run_stateCombinerEther_flatten_9
186run_stateCombinerEther_flatten_9
167 (a1, a2, a3, a4, a5, a6, a7, a8, a9)
187 (a1, a2, a3, a4, a5, a6, a7, a8, a9)
168 =
188 =
169 E.F.runState
189 E.F.runState
170 stateCombinerEther_sep_9
190 stateCombinerEther_sep_9
171− (P9 a9 a8 a7 a6 a5 a4 a3 a2 a1)
191+ ( Tagged @1 a9,
192+ Tagged @2 a8,
193+ Tagged @3 a7,
194+ Tagged @4 a6,
195+ Tagged @5 a5,
196+ Tagged @6 a4,
197+ Tagged @7 a3,
198+ Tagged @8 a2,
199+ Tagged @9 a1 )
172
200
173tuple_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int)
201tuple_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int)
174tuple_9 = (1, -2, 3, -4, 5, -6, 7, -8, 9)
202tuple_9 = (1, -2, 3, -4, 5, -6, 7, -8, 9)
ether-suite/ether-suite.cabal+2−2
@@ -9,7 +9,7 @@ library
9
9
10test-suite regression
10test-suite regression
11
11
12− build-depends: base >=4.9 && <4.10
12+ build-depends: base >=4.9 && <4.11
13 , transformers >=0.4.2
13 , transformers >=0.4.2
14 , mtl >=2.2.1
14 , mtl >=2.2.1
15 , tasty >=0.10
15 , tasty >=0.10
@@ -53,7 +53,7 @@ test-suite regression
53
53
54benchmark bench
54benchmark bench
55
55
56− build-depends: base >=4.9 && <4.10
56+ build-depends: base >=4.9 && <4.11
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
ether-zoom/ether-zoom.cabal+1−1
@@ -24,7 +24,7 @@ source-repository head
24library
24library
25
25
26 exposed-modules: Control.Monad.Ether.State.Zoom
26 exposed-modules: Control.Monad.Ether.State.Zoom
27− build-depends: base >=4.9 && <4.10
27+ build-depends: base >=4.9 && <4.11
28 , ether >=0.5 && <0.6
28 , ether >=0.5 && <0.6
29 , transformers >=0.5
29 , transformers >=0.5
30 , lens >=4.14
30 , lens >=4.14
ether/ether.cabal+5−2
@@ -28,8 +28,10 @@ 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.Ether.Optic
31 Control.Monad.Trans.Ether.Handler
32 Control.Monad.Trans.Ether.Handler
32 Control.Monad.Ether
33 Control.Monad.Ether
34+ Control.Monad.Ether.Handle
33 Control.Monad.Ether.TagAttach
35 Control.Monad.Ether.TagAttach
34 Control.Monad.Ether.TagReplace
36 Control.Monad.Ether.TagReplace
35 Control.Monad.Ether.Reader
37 Control.Monad.Ether.Reader
@@ -52,7 +54,7 @@ library
52
54
53 other-modules: Control.Monad.Ether.State.Common
55 other-modules: Control.Monad.Ether.State.Common
54
56
55− build-depends: base >=4.9 && <4.10
57+ build-depends: base >=4.9 && <4.11
56 , transformers >=0.4.2
58 , transformers >=0.4.2
57 , transformers-lift >=0.1.0.1
59 , transformers-lift >=0.1.0.1
58 , mtl >=2.2.1
60 , mtl >=2.2.1
@@ -60,7 +62,8 @@ library
60 , monad-control >=1.0.0.4
62 , monad-control >=1.0.0.4
61 , transformers-base >=0.4.4
63 , transformers-base >=0.4.4
62 , exceptions >=0.8
64 , exceptions >=0.8
63− , ghc-prim >=0.3
65+ , template-haskell >=2.11
66+ , tagged >=0.8.5
64
67
65 default-language: Haskell2010
68 default-language: Haskell2010
66 default-extensions: PolyKinds
69 default-extensions: PolyKinds
ether/src/Control/Ether/Optic.hsnew file+151
@@ -0,0 +1,151 @@
1+{-# LANGUAGE RankNTypes #-}
2+{-# LANGUAGE AllowAmbiguousTypes #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE TupleSections #-}
5+{-# LANGUAGE TemplateHaskell #-}
6+{-# LANGUAGE DataKinds #-}
7+{-# LANGUAGE FlexibleContexts #-}
8+{-# LANGUAGE UndecidableInstances #-}
9+{-# LANGUAGE TypeOperators #-}
10+{-# LANGUAGE GADTs #-}
11+{-# LANGUAGE TypeInType #-}
12+{-# LANGUAGE TypeFamilies #-}
13+
14+module Control.Ether.Optic
15+ ( Tagged(..)
16+ , Tags
17+ , HasLens(..)
18+ , view
19+ , over
20+ , HList(..)
21+ ) where
22+
23+import Control.Applicative
24+import Control.Monad
25+import Data.Functor.Identity
26+import Data.Kind as K
27+import Data.List as List
28+import Data.Tagged
29+import Data.Traversable
30+import Language.Haskell.TH
31+import Data.Coerce
32+
33+type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t
34+
35+type Lens' s a = Lens s s a a
36+
37+class HasLens tag outer inner | tag outer -> inner where
38+ lensOf :: Lens' outer inner
39+
40+instance HasLens a a a where
41+ lensOf = id
42+ {-# INLINE lensOf #-}
43+
44+(#.) :: Coercible c b => (b -> c) -> (a -> b) -> (a -> c)
45+(#.) _ = coerce (\x -> x :: b) :: forall a b. Coercible b a => a -> b
46+
47+infixr 9 #.
48+
49+view :: Lens s t a b -> s -> a
50+view l = getConst #. l Const
51+{-# INLINE view #-}
52+
53+over :: Lens s t a b -> (a -> b) -> s -> t
54+over l f = runIdentity #. l (Identity #. f)
55+{-# INLINE over #-}
56+
57+data HList xs where
58+ HNil :: HList '[]
59+ HCons :: x -> HList xs -> HList (x ': xs)
60+
61+type KindOf (a :: k) = k
62+
63+type family TagsK (p :: K.Type) :: [K.Type]
64+type family Tags (p :: K.Type) :: HList (TagsK p)
65+
66+return []
67+
68+type instance TagsK () = '[]
69+type instance TagsK (Tagged t0 a, Tagged t1 b) = '[KindOf t0, KindOf t1]
70+
71+return []
72+
73+type instance Tags () = 'HNil
74+type instance Tags (Tagged t0 a, Tagged t1 b) = 'HCons t0 ('HCons t1 'HNil)
75+
76+do
77+ let
78+ tupCount = 62
79+ names = [1..] >>= flip replicateM ['a'..'z']
80+ varNames <- traverse newName (take tupCount names)
81+ fmap List.concat $
82+ for (List.drop 2 (List.inits varNames)) $
83+ \varNames' -> do
84+ let n = List.length varNames'
85+ tagsInstances <- for [() | n > 2] $ \() -> do
86+ tag <- newName "tag"
87+ let
88+ (cur:rest) = varNames'
89+ tupTy = foldl AppT (ConT (tupleTypeName n))
90+ ( ConT ''Tagged `AppT` VarT tag `AppT` VarT cur :
91+ map VarT rest )
92+ tupTy' = foldl AppT (ConT (tupleTypeName (n-1)))
93+ (map VarT rest)
94+ return $
95+ TySynInstD ''TagsK (TySynEqn [tupTy]
96+ ( PromotedConsT `AppT` (ConT ''KindOf `AppT` VarT tag) `AppT`
97+ (ConT ''TagsK `AppT` tupTy') ))
98+ return tagsInstances
99+do
100+ let
101+ tupCount = 62
102+ names = [1..] >>= flip replicateM ['a'..'z']
103+ varNames <- traverse newName (take tupCount names)
104+ fmap List.concat $
105+ for (List.drop 2 (List.inits varNames)) $
106+ \varNames' -> do
107+ let n = List.length varNames'
108+ tagsInstances <- for [() | n > 2] $ \() -> do
109+ tag <- newName "tag"
110+ let
111+ (cur:rest) = varNames'
112+ tupTy = foldl AppT (ConT (tupleTypeName n))
113+ ( ConT ''Tagged `AppT` VarT tag `AppT` VarT cur :
114+ map VarT rest )
115+ tupTy' = foldl AppT (ConT (tupleTypeName (n-1)))
116+ (map VarT rest)
117+ tagsInst =
118+ TySynInstD ''Tags (TySynEqn [tupTy]
119+ ( PromotedT 'HCons `AppT` VarT tag `AppT`
120+ (ConT ''Tags `AppT` tupTy') ))
121+ return tagsInst
122+ hasLensInstances <- for [0..n-1] $ \k -> do
123+ tag <- newName "tag"
124+ let
125+ (prev, cur:next) = List.splitAt k varNames'
126+ tupTy = foldl AppT (ConT (tupleTypeName n))
127+ ( map VarT prev ++
128+ [ConT ''Tagged `AppT` VarT tag `AppT` VarT cur] ++
129+ map VarT next )
130+ cur' <- newName "x"
131+ f <- newName "f"
132+ return $
133+ InstanceD Nothing []
134+ (ConT ''HasLens `AppT` VarT tag `AppT` tupTy `AppT` VarT cur)
135+ [ FunD 'lensOf
136+ [ Clause
137+ [VarP f, TupP
138+ ( map VarP prev ++
139+ [ConP 'Tagged [VarP cur]] ++
140+ map VarP next )]
141+ (NormalB $
142+ VarE 'fmap `AppE`
143+ (LamE [VarP cur']
144+ (TupE
145+ ( map VarE prev ++
146+ [ConE 'Tagged `AppE` VarE cur'] ++
147+ map VarE next ))) `AppE`
148+ (VarE f `AppE` VarE cur) )
149+ [] ],
150+ PragmaD (InlineP 'lensOf Inline FunLike AllPhases) ]
151+ return $ tagsInstances ++ hasLensInstances
ether/src/Control/Monad/Ether/Except.hs+18−6
@@ -24,8 +24,9 @@ module Control.Monad.Ether.Except
24 , handle
24 , handle
25 ) where
25 ) where
26
26
27+import Control.Monad.Ether.Handle
27import Control.Monad.Ether.Except.Class
28import Control.Monad.Ether.Except.Class
28−import qualified Control.Monad.Trans.Ether.Handler as D
29+import Control.Monad.Trans.Ether.Handler
29import qualified Control.Monad.Except as T
30import qualified Control.Monad.Except as T
30import Control.Monad.Signatures (Catch)
31import Control.Monad.Signatures (Catch)
31import Data.Functor.Identity
32import Data.Functor.Identity
@@ -54,7 +55,7 @@ type Except tag e = ExceptT tag e Identity
54--
55--
55-- The 'return' function returns a normal value, while '>>=' exits on
56-- The 'return' function returns a normal value, while '>>=' exits on
56-- the first exception.
57-- the first exception.
57−type ExceptT tag e = D.Handler '(EXCEPT, tag) (T.ExceptT e)
58+type ExceptT tag e = Handler (TAGGED EXCEPT tag) (T.ExceptT e)
58
59
59-- | Runs an 'Except' and returns either an exception or a normal value.
60-- | Runs an 'Except' and returns either an exception or a normal value.
60runExcept :: forall tag e a . Except tag e a -> Either e a
61runExcept :: forall tag e a . Except tag e a -> Either e a
@@ -68,16 +69,27 @@ runExceptT = coerce (T.runExceptT @e @m @a)
68exceptT :: forall tag e m a . m (Either e a) -> ExceptT tag e m a
69exceptT :: forall tag e m a . m (Either e a) -> ExceptT tag e m a
69exceptT = coerce (T.ExceptT @e @m @a)
70exceptT = coerce (T.ExceptT @e @m @a)
70
71
72+type instance HandleSuper EXCEPT e trans = ()
73+type instance HandleConstraint EXCEPT e trans m =
74+ T.MonadError e (trans m)
75+
76+instance Handle EXCEPT e (T.ExceptT e) where
77+ handling r = r
78+ {-# INLINE handling #-}
79+
71instance
80instance
72− ( T.MonadError e (trans m) -- FIXME: (forall m . T.MonadError e (trans m))
81+ ( Handle EXCEPT e trans
82+ , Monad m, Monad (trans m)
73− ) => MonadExcept tag e (D.Handler '(EXCEPT, tag) trans (m :: * -> *))
83+ ) => MonadExcept tag e (Handler (TAGGED EXCEPT tag) trans m)
74 where
84 where
75 throw =
85 throw =
86+ handling @EXCEPT @e @trans @m $
76 coerce (T.throwError @e @(trans m) @a) ::
87 coerce (T.throwError @e @(trans m) @a) ::
77− forall dp a . e -> D.Handler dp trans m a
88+ forall dp a . e -> Handler dp trans m a
78 {-# INLINE throw #-}
89 {-# INLINE throw #-}
79
90
80 catch =
91 catch =
92+ handling @EXCEPT @e @trans @m $
81 coerce (T.catchError @e @(trans m) @a) ::
93 coerce (T.catchError @e @(trans m) @a) ::
82− forall dp a . Catch e (D.Handler dp trans m) a
94+ forall dp a . Catch e (Handler dp trans m) a
83 {-# INLINE catch #-}
95 {-# INLINE catch #-}
ether/src/Control/Monad/Ether/Handle.hsnew file+38
@@ -0,0 +1,38 @@
1+{-# LANGUAGE RankNTypes #-}
2+{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE AllowAmbiguousTypes #-}
4+{-# LANGUAGE TypeFamilies #-}
5+{-# LANGUAGE PolyKinds #-}
6+{-# LANGUAGE UndecidableInstances #-}
7+{-# LANGUAGE UndecidableSuperClasses #-}
8+
9+module Control.Monad.Ether.Handle
10+ ( Handle(..)
11+ , HandleSuper
12+ , HandleConstraint
13+ , TAGGED
14+ ) where
15+
16+import GHC.Exts (Constraint)
17+
18+data TAGGED e t
19+
20+type family
21+ HandleSuper
22+ (eff :: keff)
23+ (p :: kp)
24+ (trans :: (* -> *) -> * -> *)
25+ :: Constraint
26+
27+type family
28+ HandleConstraint
29+ (eff :: keff)
30+ (p :: kp)
31+ (trans :: (* -> *) -> * -> *) (m :: * -> *)
32+ :: Constraint
33+
34+class
35+ HandleSuper eff p trans =>
36+ Handle eff p (trans :: (* -> *) -> * -> *) | eff trans -> p
37+ where
38+ handling :: Monad m => (HandleConstraint eff p trans m => r) -> r
ether/src/Control/Monad/Ether/Reader.hs+48−9
@@ -3,6 +3,7 @@
3{-# LANGUAGE UndecidableInstances #-}
3{-# LANGUAGE UndecidableInstances #-}
4{-# LANGUAGE TypeFamilies #-}
4{-# LANGUAGE TypeFamilies #-}
5{-# LANGUAGE AllowAmbiguousTypes #-}
5{-# LANGUAGE AllowAmbiguousTypes #-}
6+{-# LANGUAGE TypeOperators #-}
6
7
7-- | See "Control.Monad.Reader".
8-- | See "Control.Monad.Reader".
8
9
@@ -21,10 +22,14 @@ module Control.Monad.Ether.Reader
21 , ReaderT
22 , ReaderT
22 , readerT
23 , readerT
23 , runReaderT
24 , runReaderT
25+ -- *
26+ , READER
24 ) where
27 ) where
25
28
29+import Control.Monad.Ether.Handle
26import Control.Monad.Ether.Reader.Class
30import Control.Monad.Ether.Reader.Class
31+import Control.Ether.Optic
27−import qualified Control.Monad.Trans.Ether.Handler as D
32+import Control.Monad.Trans.Ether.Handler
28import Control.Monad.Trans.Lift.Local (Local)
33import Control.Monad.Trans.Lift.Local (Local)
29import qualified Control.Monad.Reader as T
34import qualified Control.Monad.Reader as T
30import Data.Functor.Identity
35import Data.Functor.Identity
@@ -56,7 +61,7 @@ type Reader tag r = ReaderT tag r Identity
56--
61--
57-- The 'return' function ignores the environment, while '>>=' passes
62-- The 'return' function ignores the environment, while '>>=' passes
58-- the inherited environment to both subcomputations.
63-- the inherited environment to both subcomputations.
59−type ReaderT tag r = D.Handler '(READER, tag) (T.ReaderT r)
64+type ReaderT tag r = Handler (TAGGED READER tag) (T.ReaderT r)
60
65
61-- | Constructor for computations in the reader monad transformer.
66-- | Constructor for computations in the reader monad transformer.
62readerT :: forall tag r m a . (r -> m a) -> ReaderT tag r m a
67readerT :: forall tag r m a . (r -> m a) -> ReaderT tag r m a
@@ -75,22 +80,56 @@ runReader :: forall tag r a . Reader tag r a -> r -> a
75runReader = coerce (T.runReader @r @a)
80runReader = coerce (T.runReader @r @a)
76{-# INLINE runReader #-}
81{-# INLINE runReader #-}
77
82
83+type instance HandleSuper READER r trans = ()
84+type instance HandleConstraint READER r trans m =
85+ T.MonadReader r (trans m)
86+
87+instance Handle READER r (T.ReaderT r) where
88+ handling r = r
89+ {-# INLINE handling #-}
90+
78instance
91instance
79− ( T.MonadReader r (trans m) -- FIXME: (forall m . T.MonadReader r (trans m))
92+ ( Handle READER r trans
80− -- otherwise we can leak a MonadReader instance
93+ , Monad m, Monad (trans m)
81− -- from 'm'
82− ) => MonadReader tag r (D.Handler '(READER, tag) trans (m :: * -> *))
94+ ) => MonadReader tag r (Handler (TAGGED READER tag) trans m)
83 where
95 where
84
96
97+ ask =
98+ handling @READER @r @trans @m $
85− ask = coerce (T.ask @r @(trans m))
99+ coerce (T.ask @r @(trans m))
86 {-# INLINE ask #-}
100 {-# INLINE ask #-}
87
101
88 local =
102 local =
103+ handling @READER @r @trans @m $
89 coerce (T.local @r @(trans m) @a) ::
104 coerce (T.local @r @(trans m) @a) ::
90− forall dp a . Local r (D.Handler dp trans m) a
105+ forall dp a . Local r (Handler dp trans m) a
91 {-# INLINE local #-}
106 {-# INLINE local #-}
92
107
93 reader =
108 reader =
109+ handling @READER @r @trans @m $
94 coerce (T.reader @r @(trans m) @a) ::
110 coerce (T.reader @r @(trans m) @a) ::
95− forall dp a . (r -> a) -> D.Handler dp trans m a
111+ forall dp a . (r -> a) -> Handler dp trans m a
96 {-# INLINE reader #-}
112 {-# INLINE reader #-}
113+
114+instance
115+ ( HasLens tag payload r
116+ , Handle READER payload trans
117+ , Monad m, Monad (trans m)
118+ ) => MonadReader tag r (Handler (TAGGED READER tag ': dps) trans m)
119+ where
120+
121+ ask =
122+ handling @READER @payload @trans @m $
123+ (coerce :: forall dp a .
124+ trans m a ->
125+ Handler dp trans m a)
126+ (T.asks (view (lensOf @tag @payload @r)))
127+ {-# INLINE ask #-}
128+
129+ local f =
130+ handling @READER @payload @trans @m $
131+ (coerce :: forall dp a .
132+ (trans m a -> trans m a) ->
133+ (Handler dp trans m a -> Handler dp trans m a))
134+ (T.local (over (lensOf @tag @payload @r) f))
135+ {-# INLINE local #-}
ether/src/Control/Monad/Ether/State/Common.hs+55−6
@@ -2,6 +2,8 @@
2{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE AllowAmbiguousTypes #-}
3{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE UndecidableInstances #-}
4{-# LANGUAGE UndecidableInstances #-}
5+{-# LANGUAGE TypeFamilies #-}
6+{-# LANGUAGE TypeOperators #-}
5
7
6module Control.Monad.Ether.State.Common
8module Control.Monad.Ether.State.Common
7 ( MonadState
9 ( MonadState
@@ -13,9 +15,11 @@ module Control.Monad.Ether.State.Common
13 , STATE
15 , STATE
14 ) where
16 ) where
15
17
18+import Control.Ether.Optic
19+import Control.Monad.Ether.Handle
16import Control.Monad.Ether.State.Class
20import Control.Monad.Ether.State.Class
17import qualified Control.Monad.State as T
21import qualified Control.Monad.State as T
18−import qualified Control.Monad.Trans.Ether.Handler as D
22+import Control.Monad.Trans.Ether.Handler
19import Data.Coerce
23import Data.Coerce
20
24
21-- | Encode type-level information for 'StateT'.
25-- | Encode type-level information for 'StateT'.
@@ -31,18 +35,63 @@ gets :: forall tag s m a . MonadState tag s m => (s -> a) -> m a
31gets f = fmap f (get @tag)
35gets f = fmap f (get @tag)
32{-# INLINABLE gets #-}
36{-# INLINABLE gets #-}
33
37
38+type instance HandleSuper STATE s trans = ()
39+type instance HandleConstraint STATE s trans m =
40+ T.MonadState s (trans m)
41+
42+instance Handle STATE s (T.StateT s) where
43+ handling r = r
44+ {-# INLINE handling #-}
45+
34instance
46instance
35− ( T.MonadState s (trans m) -- FIXME: (forall m . T.MonadState s (trans m))
47+ ( Handle STATE s trans
48+ , Monad m, Monad (trans m)
36− ) => MonadState tag s (D.Handler '(STATE, tag) trans (m :: * -> *))
49+ ) => MonadState tag s (Handler (TAGGED STATE tag) trans m)
37 where
50 where
38
51
52+ get =
53+ handling @STATE @s @trans @m $
39− get = coerce (T.get @s @(trans m))
54+ coerce (T.get @s @(trans m))
40 {-# INLINE get #-}
55 {-# INLINE get #-}
41
56
57+ put =
58+ handling @STATE @s @trans @m $
42− put = coerce (T.put @s @(trans m))
59+ coerce (T.put @s @(trans m))
43 {-# INLINE put #-}
60 {-# INLINE put #-}
44
61
45 state =
62 state =
63+ handling @STATE @s @trans @m $
46 coerce (T.state @s @(trans m) @a) ::
64 coerce (T.state @s @(trans m) @a) ::
65+ forall dp a . (s -> (a, s)) -> Handler dp trans m a
66+ {-# INLINE state #-}
67+
68+instance
69+ ( HasLens tag payload s
70+ , Handle STATE payload trans
71+ , Monad m, Monad (trans m)
72+ ) => MonadState tag s (Handler (TAGGED STATE tag ': dps) trans m)
73+ where
74+
75+ get =
76+ handling @STATE @payload @trans @m $
77+ (coerce :: forall dp a .
78+ trans m a ->
47− forall dp a . (s -> (a, s)) -> D.Handler dp trans m a
79+ Handler dp trans m a)
80+ (T.gets (view (lensOf @tag @payload @s)))
81+ {-# INLINE get #-}
82+
83+ put s =
84+ handling @STATE @payload @trans @m $
85+ (coerce :: forall dp a .
86+ trans m a ->
87+ Handler dp trans m a)
88+ (T.modify (over (lensOf @tag @payload @s) (const s)))
89+ {-# INLINE put #-}
90+
91+ state f =
92+ handling @STATE @payload @trans @m $
93+ (coerce :: forall dp a .
94+ trans m a ->
95+ Handler dp trans m a)
96+ (T.state (lensOf @tag @payload @s f))
48 {-# INLINE state #-}
97 {-# INLINE state #-}
ether/src/Control/Monad/Ether/State/Lazy.hs+4−1
@@ -25,8 +25,11 @@ module Control.Monad.Ether.State.Lazy
25 , runStateT
25 , runStateT
26 , evalStateT
26 , evalStateT
27 , execStateT
27 , execStateT
28+ -- *
29+ , STATE
28 ) where
30 ) where
29
31
32+import Control.Monad.Ether.Handle
30import Control.Monad.Ether.State.Common
33import Control.Monad.Ether.State.Common
31import qualified Control.Monad.Trans.Ether.Handler as D
34import qualified Control.Monad.Trans.Ether.Handler as D
32import qualified Control.Monad.Trans.State.Lazy as T
35import qualified Control.Monad.Trans.State.Lazy as T
@@ -45,7 +48,7 @@ type State tag r = StateT tag r Identity
45--
48--
46-- The 'return' function leaves the state unchanged, while '>>=' uses
49-- The 'return' function leaves the state unchanged, while '>>=' uses
47-- the final state of the first computation as the initial state of the second.
50-- the final state of the first computation as the initial state of the second.
48−type StateT tag s = D.Handler '(STATE, tag) (T.StateT s)
51+type StateT tag s = D.Handler (TAGGED STATE tag) (T.StateT s)
49
52
50-- | Constructor for computations in the state monad transformer.
53-- | Constructor for computations in the state monad transformer.
51stateT :: forall tag s m a . (s -> m (a, s)) -> StateT tag s m a
54stateT :: forall tag s m a . (s -> m (a, s)) -> StateT tag s m a
ether/src/Control/Monad/Ether/State/Strict.hs+4−1
@@ -25,8 +25,11 @@ module Control.Monad.Ether.State.Strict
25 , runStateT
25 , runStateT
26 , evalStateT
26 , evalStateT
27 , execStateT
27 , execStateT
28+ -- *
29+ , STATE
28 ) where
30 ) where
29
31
32+import Control.Monad.Ether.Handle
30import Control.Monad.Ether.State.Common
33import Control.Monad.Ether.State.Common
31import qualified Control.Monad.Trans.Ether.Handler as D
34import qualified Control.Monad.Trans.Ether.Handler as D
32import qualified Control.Monad.Trans.State.Strict as T
35import qualified Control.Monad.Trans.State.Strict as T
@@ -45,7 +48,7 @@ type State tag r = StateT tag r Identity
45--
48--
46-- The 'return' function leaves the state unchanged, while '>>=' uses
49-- The 'return' function leaves the state unchanged, while '>>=' uses
47-- the final state of the first computation as the initial state of the second.
50-- the final state of the first computation as the initial state of the second.
48−type StateT tag s = D.Handler '(STATE, tag) (T.StateT s)
51+type StateT tag s = D.Handler (TAGGED STATE tag) (T.StateT s)
49
52
50-- | Constructor for computations in the state monad transformer.
53-- | Constructor for computations in the state monad transformer.
51stateT :: forall tag s m a . (s -> m (a, s)) -> StateT tag s m a
54stateT :: forall tag s m a . (s -> m (a, s)) -> StateT tag s m a
ether/src/Control/Monad/Ether/Writer.hs+23−8
@@ -27,8 +27,9 @@ module Control.Monad.Ether.Writer
27 , execWriterT
27 , execWriterT
28 ) where
28 ) where
29
29
30+import Control.Monad.Ether.Handle
30import Control.Monad.Ether.Writer.Class
31import Control.Monad.Ether.Writer.Class
31−import qualified Control.Monad.Trans.Ether.Handler as D
32+import Control.Monad.Trans.Ether.Handler
32import qualified Control.Monad.Writer as T
33import qualified Control.Monad.Writer as T
33import Data.Functor.Identity
34import Data.Functor.Identity
34import Control.Monad.Signatures (Listen, Pass)
35import Control.Monad.Signatures (Listen, Pass)
@@ -62,7 +63,7 @@ type Writer tag w = WriterT tag w Identity
62--
63--
63-- The 'return' function produces the output 'mempty', while '>>=' combines
64-- The 'return' function produces the output 'mempty', while '>>=' combines
64-- the outputs of the subcomputations using 'mappend'.
65-- the outputs of the subcomputations using 'mappend'.
65−type WriterT tag w = D.Handler '(WRITER, tag) (T.WriterT w)
66+type WriterT tag w = Handler (TAGGED WRITER tag) (T.WriterT w)
66
67
67-- | Constructor for computations in the writer monad transformer.
68-- | Constructor for computations in the writer monad transformer.
68writerT :: forall tag w m a . m (a, w) -> WriterT tag w m a
69writerT :: forall tag w m a . m (a, w) -> WriterT tag w m a
@@ -88,25 +89,39 @@ execWriterT = coerce (T.execWriterT @m @w @a)
88execWriter :: forall tag w a . Writer tag w a -> w
89execWriter :: forall tag w a . Writer tag w a -> w
89execWriter = coerce (T.execWriter @w @a)
90execWriter = coerce (T.execWriter @w @a)
90
91
92+type instance HandleSuper WRITER w trans = Monoid w
93+type instance HandleConstraint WRITER w trans m =
94+ T.MonadWriter w (trans m)
95+
96+instance Monoid w => Handle WRITER w (T.WriterT w) where
97+ handling r = r
98+ {-# INLINE handling #-}
99+
91instance
100instance
92− ( T.MonadWriter w (trans m) -- FIXME: (forall m . T.MonadWriter w (trans m))
101+ ( Handle WRITER w trans
102+ , Monad m, Monad (trans m)
93− ) => MonadWriter tag w (D.Handler '(WRITER, tag) trans (m :: * -> *))
103+ ) => MonadWriter tag w (Handler (TAGGED WRITER tag) trans m)
94 where
104 where
95
105
96 writer =
106 writer =
107+ handling @WRITER @w @trans @m $
97 coerce (T.writer @w @(trans m) @a) ::
108 coerce (T.writer @w @(trans m) @a) ::
98− forall dp a . (a, w) -> D.Handler dp trans m a
109+ forall dp a . (a, w) -> Handler dp trans m a
99 {-# INLINE writer #-}
110 {-# INLINE writer #-}
100
111
112+ tell =
113+ handling @WRITER @w @trans @m $
101− tell = coerce (T.tell @w @(trans m))
114+ coerce (T.tell @w @(trans m))
102 {-# INLINE tell #-}
115 {-# INLINE tell #-}
103
116
104 listen =
117 listen =
118+ handling @WRITER @w @trans @m $
105 coerce (T.listen @w @(trans m) @a) ::
119 coerce (T.listen @w @(trans m) @a) ::
106− forall dp a . Listen w (D.Handler dp trans m) a
120+ forall dp a . Listen w (Handler dp trans m) a
107 {-# INLINE listen #-}
121 {-# INLINE listen #-}
108
122
109 pass =
123 pass =
124+ handling @WRITER @w @trans @m $
110 coerce (T.pass @w @(trans m) @a) ::
125 coerce (T.pass @w @(trans m) @a) ::
111− forall dp a . Pass w (D.Handler dp trans m) a
126+ forall dp a . Pass w (Handler dp trans m) a
112 {-# INLINE pass #-}
127 {-# INLINE pass #-}
stack.yaml+1−1
@@ -1,4 +1,4 @@
1−resolver: lts-8.5
1+resolver: lts-8.12
2
2
3packages:
3packages:
4- 'ether'
4- 'ether'