git.iko.soy/typeable/ether
on master help sign in
Flatten StateT
67bbb76Index Int
ether-flatten/ether-flatten.cabal+2
compare with master
unifiedsplit
@@ -24,6 +24,7 @@ source-repository head
24library
24library
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.Ether.Flatten
28 , Control.Ether.Flatten
28 build-depends: base >=4.9 && <4.10
29 build-depends: base >=4.9 && <4.10
29 , ether >=0.5 && <0.6
30 , ether >=0.5 && <0.6
@@ -31,6 +32,7 @@ library
31 , transformers-lift >=0.1.0.1
32 , transformers-lift >=0.1.0.1
32 , ghc-prim >=0.3
33 , ghc-prim >=0.3
33 , lens >=4.14
34 , lens >=4.14
35+ , deepseq >= 1.4
34
36
35 default-language: Haskell2010
37 default-language: Haskell2010
36 default-extensions: PolyKinds
38 default-extensions: PolyKinds
ether-flatten/src/Control/Ether/Flatten.hs+12−1
@@ -17,6 +17,7 @@ module Control.Ether.Flatten
17 ) where
17 ) where
18
18
19import Control.Lens
19import Control.Lens
20+import Control.DeepSeq
20import GHC.Prim (Proxy#)
21import GHC.Prim (Proxy#)
21
22
22class HasLens tag outer inner | tag outer -> inner where
23class HasLens tag outer inner | tag outer -> inner where
@@ -24,7 +25,17 @@ class HasLens tag outer inner | tag outer -> inner where
24
25
25data Product (ts :: [k]) (as :: [*]) where
26data Product (ts :: [k]) (as :: [*]) where
26 Nil :: Product '[] '[]
27 Nil :: Product '[] '[]
27− Cons :: !a -> !(Product ts as) -> Product (t ': ts) (a ': as)
28+ Cons :: a -> !(Product ts as) -> Product (t ': ts) (a ': as)
29+
30+instance NFData (Product '[] '[]) where
31+ rnf Nil = ()
32+
33+instance
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
28
39
29load :: forall tag a . a -> Product '[tag] '[a]
40load :: forall tag a . a -> Product '[tag] '[a]
30load a = Cons a Nil
41load a = Cons a Nil
ether-flatten/src/Control/Monad/Ether/Reader/Flatten.hs+7−9
@@ -15,7 +15,7 @@ module Control.Monad.Ether.Reader.Flatten
15 , runReaderT
15 , runReaderT
16 ) where
16 ) where
17
17
18−import qualified Control.Monad.Trans.Lift.Local as Lift
18+import qualified Control.Monad.Trans.Lift.Local as Lift
19
19
20import Data.Functor.Identity
20import Data.Functor.Identity
21import Control.Monad.Ether.Reader.Class as C
21import Control.Monad.Ether.Reader.Class as C
@@ -28,6 +28,8 @@ data READER (ts :: [k])
28
28
29type ReaderT ts r = Dispatch (READER ts) (T.ReaderT r)
29type ReaderT ts r = Dispatch (READER ts) (T.ReaderT r)
30
30
31+type Reader ts r = ReaderT ts r Identity
32+
31reflatten
33reflatten
32 :: forall tagsOld tagsNew r m a
34 :: forall tagsOld tagsNew r m a
33 . ReaderT tagsOld r m a
35 . ReaderT tagsOld r m a
@@ -51,7 +53,9 @@ instance
51 ) => C.MonadReader tag r (Dispatch (READER (tag ': tags)) trans m)
53 ) => C.MonadReader tag r (Dispatch (READER (tag ': tags)) trans m)
52 where
54 where
53 ask t = pack $ view (lensOf t)
55 ask t = pack $ view (lensOf t)
56+ {-# INLINE ask #-}
54 local t f = pack . T.local (over (lensOf t) f) . unpack
57 local t f = pack . T.local (over (lensOf t) f) . unpack
58+ {-# INLINE local #-}
55
59
56instance {-# OVERLAPPABLE #-}
60instance {-# OVERLAPPABLE #-}
57 ( Monad m
61 ( Monad m
@@ -67,14 +71,8 @@ instance {-# OVERLAPPABLE #-}
67 . reflatten @(t ': tags) @tags
71 . reflatten @(t ': tags) @tags
68 {-# INLINE local #-}
72 {-# INLINE local #-}
69
73
70−runReaderT
71− :: ReaderT tags (Product tags as) m a
74+runReaderT :: ReaderT tags (Product tags as) m a -> Product tags as -> m a
72− -> Product tags as
73− -> m a
74runReaderT m = T.runReaderT (unpack m)
75runReaderT m = T.runReaderT (unpack m)
75
76
76−runReader
77− :: ReaderT tags (Product tags as) Identity a
78− -> Product tags as
77+runReader :: Reader tags (Product tags as) a -> Product tags as -> a
79− -> a
80runReader m = T.runReader (unpack m)
78runReader m = T.runReader (unpack m)
ether-flatten/src/Control/Monad/Ether/State/Flatten.hsnew file+81
@@ -0,0 +1,81 @@
1+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
2+
3+{-# LANGUAGE RankNTypes #-}
4+{-# LANGUAGE TypeSynonymInstances #-}
5+{-# LANGUAGE DataKinds #-}
6+{-# LANGUAGE TypeOperators #-}
7+{-# LANGUAGE UndecidableInstances #-}
8+{-# LANGUAGE FlexibleInstances #-}
9+{-# LANGUAGE GADTs #-}
10+{-# LANGUAGE TypeFamilies #-}
11+{-# LANGUAGE MagicHash #-}
12+
13+module Control.Monad.Ether.State.Flatten
14+ ( runState
15+ , runStateT
16+ ) where
17+
18+import qualified Control.Monad.Trans.Class as Lift
19+
20+import Data.Functor.Identity
21+import Control.Monad.Ether.State.Class as C
22+import Control.Monad.Trans.Ether.Dispatch
23+import qualified Control.Monad.Trans.State as T
24+import Control.Lens
25+import Control.Ether.Flatten
26+
27+data STATE (ts :: [k])
28+
29+type StateT ts s = Dispatch (STATE ts) (T.StateT s)
30+
31+type State ts s = StateT ts s Identity
32+
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 #-}
39+
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
49+
50+instance
51+ ( Monad m, HasLens tag payload s
52+ , trans ~ T.StateT payload
53+ ) => C.MonadState tag s (Dispatch (STATE (tag ': tags)) trans m)
54+ where
55+ get t = pack $ use (lensOf t)
56+ {-# INLINE get #-}
57+ put t s = pack $ zoom (lensOf t) (T.put s)
58+ {-# INLINE put #-}
59+
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)
67+ {-# INLINE get #-}
68+ put t = reflatten @tags @(t ': tags) . C.put t
69+ {-# INLINE put #-}
70+
71+runStateT
72+ :: StateT tags (Product tags as) m a
73+ -> Product tags as
74+ -> m (a, Product tags as)
75+runStateT m = T.runStateT (unpack m)
76+
77+runState
78+ :: State tags (Product tags as) a
79+ -> Product tags as
80+ -> (a, Product tags as)
81+runState m = T.runState (unpack m)
ether-suite/bench/Bench.hs+81
@@ -8,8 +8,11 @@ module Main (main) where
8
8
9import Criterion.Main
9import Criterion.Main
10import qualified Control.Monad.Reader as M
10import qualified Control.Monad.Reader as M
11+import qualified Control.Monad.State as M
11import qualified Control.Monad.Ether.Reader as E
12import qualified Control.Monad.Ether.Reader as E
13+import qualified Control.Monad.Ether.State as E
12import qualified Control.Monad.Ether.Reader.Flatten as E.F
14import qualified Control.Monad.Ether.Reader.Flatten as E.F
15+import qualified Control.Monad.Ether.State.Flatten as E.F
13import Control.Ether.Flatten
16import Control.Ether.Flatten
14import qualified Control.Lens as L
17import qualified Control.Lens as L
15
18
@@ -29,11 +32,43 @@ readerSummatorMTL_flat_9 = do
29 , show <$> L.view L._9 ]
32 , show <$> L.view L._9 ]
30{-# NOINLINE readerSummatorMTL_flat_9 #-}
33{-# NOINLINE readerSummatorMTL_flat_9 #-}
31
34
35+stateSummatorMTL_flat_9
36+ :: 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+
32run_readerSummatorMTL_flat_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> String
60run_readerSummatorMTL_flat_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> String
33run_readerSummatorMTL_flat_9
61run_readerSummatorMTL_flat_9
34 (a1, a2, a3, a4, a5, a6, a7, a8, a9) =
62 (a1, a2, a3, a4, a5, a6, a7, a8, a9) =
35 M.runReader readerSummatorMTL_flat_9 (a9, a8, a7, a6, a5, a4, a3, a2, a1)
63 M.runReader readerSummatorMTL_flat_9 (a9, a8, a7, a6, a5, a4, a3, a2, a1)
36
64
65+run_stateSummatorMTL_flat_9 ::
66+ (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
69+ (a1, a2, a3, a4, a5, a6, a7, a8, a9) =
70+ M.runState stateSummatorMTL_flat_9 (a9, a8, a7, a6, a5, a4, a3, a2, a1)
71+
37readerSummatorEther_sep_9
72readerSummatorEther_sep_9
38 :: ( E.MonadReader 1 Int m
73 :: ( E.MonadReader 1 Int m
39 , E.MonadReader 2 Int m
74 , E.MonadReader 2 Int m
@@ -57,6 +92,38 @@ readerSummatorEther_sep_9 = concat <$> sequenceA
57 , show <$> E.ask @9 ]
92 , show <$> E.ask @9 ]
58{-# NOINLINE readerSummatorEther_sep_9 #-}
93{-# NOINLINE readerSummatorEther_sep_9 #-}
59
94
95+stateSummatorEther_sep_9
96+ :: ( E.MonadState 1 Int m
97+ , E.MonadState 2 Int m
98+ , E.MonadState 3 Int m
99+ , E.MonadState 4 Int m
100+ , E.MonadState 5 Int m
101+ , E.MonadState 6 Int m
102+ , E.MonadState 7 Int m
103+ , E.MonadState 8 Int m
104+ , 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+
60run_readerSummatorEther_nested_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> String
127run_readerSummatorEther_nested_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> String
61run_readerSummatorEther_nested_9
128run_readerSummatorEther_nested_9
62 (a1, a2, a3, a4, a5, a6, a7, a8, a9)
129 (a1, a2, a3, a4, a5, a6, a7, a8, a9)
@@ -88,6 +155,18 @@ run_readerSummatorEther_flattenhalf_9
88 . flip E.F.runReaderT (load @5 a5 <+> load @6 a4 <+> load @7 a3 <+> load @8 a2 <+> load @9 a1)
155 . flip E.F.runReaderT (load @5 a5 <+> load @6 a4 <+> load @7 a3 <+> load @8 a2 <+> load @9 a1)
89 $ readerSummatorEther_sep_9
156 $ readerSummatorEther_sep_9
90
157
158+run_stateSummatorEther_flatten_9 ::
159+ (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
162+ (a1, a2, a3, a4, a5, a6, a7, a8, a9)
163+ =
164+ 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 )
169+
91tuple_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int)
170tuple_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int)
92tuple_9 = (1, -2, 3, -4, 5, -6, 7, -8, 9)
171tuple_9 = (1, -2, 3, -4, 5, -6, 7, -8, 9)
93
172
@@ -99,4 +178,6 @@ main = do
99 , bench "readerSummatorEther_flatten_9" $ nf run_readerSummatorEther_flatten_9 tuple_9
178 , bench "readerSummatorEther_flatten_9" $ nf run_readerSummatorEther_flatten_9 tuple_9
100 , bench "readerSummatorEther_flattenhalf_9" $
179 , bench "readerSummatorEther_flattenhalf_9" $
101 nf run_readerSummatorEther_flattenhalf_9 tuple_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
102 ]
183 ]