git.iko.soy/typeable/ether
on master help sign in
Flatten StateT
commit67bbb76e0e2c019c081fad24ebc9814898e8f413 authorIndex Int <vlad.z.4096@gmail.com> dateFri 12 Aug 2016, 23:12 (10 years ago) parent5b50028
5 files changed+183−10
compare with master
unifiedsplit
ether-flatten/ether-flatten.cabal+2 ether-flatten/src/Control/Ether/Flatten.hs+12−1 ether-flatten/src/Control/Monad/Ether/Reader/Flatten.hs+7−9 ether-flatten/src/Control/Monad/Ether/State/Flatten.hs+81 ether-suite/bench/Bench.hs+81
ether-flatten/ether-flatten.cabal+2
@@ -24,6 +24,7 @@ source-repository head
2424library
2525
2626 exposed-modules: Control.Monad.Ether.Reader.Flatten
27+ , Control.Monad.Ether.State.Flatten
2728 , Control.Ether.Flatten
2829 build-depends: base >=4.9 && <4.10
2930 , ether >=0.5 && <0.6
@@ -31,6 +32,7 @@ library
3132 , transformers-lift >=0.1.0.1
3233 , ghc-prim >=0.3
3334 , lens >=4.14
35+ , deepseq >= 1.4
3436
3537 default-language: Haskell2010
3638 default-extensions: PolyKinds
ether-flatten/src/Control/Ether/Flatten.hs+12−1
@@ -17,6 +17,7 @@ module Control.Ether.Flatten
1717 ) where
1818
1919import Control.Lens
20+import Control.DeepSeq
2021import GHC.Prim (Proxy#)
2122
2223class HasLens tag outer inner | tag outer -> inner where
@@ -24,7 +25,17 @@ class HasLens tag outer inner | tag outer -> inner where
2425
2526data Product (ts :: [k]) (as :: [*]) where
2627 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
2839
2940load :: forall tag a . a -> Product '[tag] '[a]
3041load 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
1515 , runReaderT
1616 ) where
1717
18−import qualified Control.Monad.Trans.Lift.Local as Lift
18+import qualified Control.Monad.Trans.Lift.Local as Lift
1919
2020import Data.Functor.Identity
2121import Control.Monad.Ether.Reader.Class as C
@@ -28,6 +28,8 @@ data READER (ts :: [k])
2828
2929type ReaderT ts r = Dispatch (READER ts) (T.ReaderT r)
3030
31+type Reader ts r = ReaderT ts r Identity
32+
3133reflatten
3234 :: forall tagsOld tagsNew r m a
3335 . ReaderT tagsOld r m a
@@ -51,7 +53,9 @@ instance
5153 ) => C.MonadReader tag r (Dispatch (READER (tag ': tags)) trans m)
5254 where
5355 ask t = pack $ view (lensOf t)
56+ {-# INLINE ask #-}
5457 local t f = pack . T.local (over (lensOf t) f) . unpack
58+ {-# INLINE local #-}
5559
5660instance {-# OVERLAPPABLE #-}
5761 ( Monad m
@@ -67,14 +71,8 @@ instance {-# OVERLAPPABLE #-}
6771 . reflatten @(t ': tags) @tags
6872 {-# INLINE local #-}
6973
70−runReaderT
71− :: ReaderT tags (Product tags as) m a
72− -> Product tags as
73− -> m a
74+runReaderT :: ReaderT tags (Product tags as) m a -> Product tags as -> m a
7475runReaderT m = T.runReaderT (unpack m)
7576
76−runReader
77− :: ReaderT tags (Product tags as) Identity a
78− -> Product tags as
79− -> a
77+runReader :: Reader tags (Product tags as) a -> Product tags as -> a
8078runReader 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
88
99import Criterion.Main
1010import qualified Control.Monad.Reader as M
11+import qualified Control.Monad.State as M
1112import qualified Control.Monad.Ether.Reader as E
13+import qualified Control.Monad.Ether.State as E
1214import qualified Control.Monad.Ether.Reader.Flatten as E.F
15+import qualified Control.Monad.Ether.State.Flatten as E.F
1316import Control.Ether.Flatten
1417import qualified Control.Lens as L
1518
@@ -29,11 +32,43 @@ readerSummatorMTL_flat_9 = do
2932 , show <$> L.view L._9 ]
3033{-# NOINLINE readerSummatorMTL_flat_9 #-}
3134
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+
3260run_readerSummatorMTL_flat_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> String
3361run_readerSummatorMTL_flat_9
3462 (a1, a2, a3, a4, a5, a6, a7, a8, a9) =
3563 M.runReader readerSummatorMTL_flat_9 (a9, a8, a7, a6, a5, a4, a3, a2, a1)
3664
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+
3772readerSummatorEther_sep_9
3873 :: ( E.MonadReader 1 Int m
3974 , E.MonadReader 2 Int m
@@ -57,6 +92,38 @@ readerSummatorEther_sep_9 = concat <$> sequenceA
5792 , show <$> E.ask @9 ]
5893{-# NOINLINE readerSummatorEther_sep_9 #-}
5994
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+
60127run_readerSummatorEther_nested_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> String
61128run_readerSummatorEther_nested_9
62129 (a1, a2, a3, a4, a5, a6, a7, a8, a9)
@@ -88,6 +155,18 @@ run_readerSummatorEther_flattenhalf_9
88155 . flip E.F.runReaderT (load @5 a5 <+> load @6 a4 <+> load @7 a3 <+> load @8 a2 <+> load @9 a1)
89156 $ readerSummatorEther_sep_9
90157
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+
91170tuple_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int)
92171tuple_9 = (1, -2, 3, -4, 5, -6, 7, -8, 9)
93172
@@ -99,4 +178,6 @@ main = do
99178 , bench "readerSummatorEther_flatten_9" $ nf run_readerSummatorEther_flatten_9 tuple_9
100179 , bench "readerSummatorEther_flattenhalf_9" $
101180 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
102183 ]