git.iko.soy/typeable/ether
on master help sign in
Remove EtherData
67f2cbfIndex Int
src/Control/Ether/Core.hs+1−4
compare with master
unifiedsplit
@@ -5,8 +5,7 @@
5{-# LANGUAGE TypeOperators #-}
5{-# LANGUAGE TypeOperators #-}
6{-# LANGUAGE UndecidableInstances #-}
6{-# LANGUAGE UndecidableInstances #-}
7module Control.Ether.Core
7module Control.Ether.Core
8− ( EtherData
9− , EtherTagless
8+ ( EtherTagless
10 , MonadEther
9 , MonadEther
11 , EtherTags
10 , EtherTags
12 ) where
11 ) where
@@ -24,8 +23,6 @@ import qualified Control.Monad.Trans.State.Strict as Trans.Strict
24import qualified Control.Monad.Trans.Writer.Lazy as Trans.Lazy
23import qualified Control.Monad.Trans.Writer.Lazy as Trans.Lazy
25import qualified Control.Monad.Trans.Writer.Strict as Trans.Strict
24import qualified Control.Monad.Trans.Writer.Strict as Trans.Strict
26
25
27−type family EtherData tag :: *
28−
29type family OR (a :: Bool) (b :: Bool) :: Bool where
26type family OR (a :: Bool) (b :: Bool) :: Bool where
30 OR 'True a = 'True
27 OR 'True a = 'True
31 OR 'False a = a
28 OR 'False a = a
src/Control/Ether/TH.hs+15−16
@@ -9,7 +9,6 @@ import qualified Language.Haskell.TH as TH
9
9
10import Data.Proxy
10import Data.Proxy
11import Data.Functor.Identity
11import Data.Functor.Identity
12−import Control.Ether.Core
13import Control.Monad.Ether.Reader
12import Control.Monad.Ether.Reader
14
13
15emptyDataDecl :: TH.Name -> TH.DecQ
14emptyDataDecl :: TH.Name -> TH.DecQ
@@ -25,11 +24,10 @@ tyVar name = do
25 return (TH.PlainTV thName, thType)
24 return (TH.PlainTV thName, thType)
26
25
27data EtherealConfig
26data EtherealConfig
28− = EtherealReaderConfig TH.Name String String String String String
27+ = EtherealReaderConfig String String String String String
29
28
30−defaultEtherealReaderConfig :: TH.Name -> String -> EtherealConfig
29+defaultEtherealReaderConfig :: String -> EtherealConfig
31−defaultEtherealReaderConfig tyname name = EtherealReaderConfig
30+defaultEtherealReaderConfig name = EtherealReaderConfig
32− tyname
33 ("Monad" ++ name)
31 ("Monad" ++ name)
34 ("Tag" ++ name)
32 ("Tag" ++ name)
35 ("run" ++ name ++ "T")
33 ("run" ++ name ++ "T")
@@ -39,8 +37,7 @@ defaultEtherealReaderConfig tyname name = EtherealReaderConfig
39ethereal :: EtherealConfig -> TH.DecsQ
37ethereal :: EtherealConfig -> TH.DecsQ
40
38
41ethereal (EtherealReaderConfig
39ethereal (EtherealReaderConfig
42− tyname strEffName
43− strTagName strRunTransName
40+ strEffName strTagName strRunTransName
44 strRunName strAskName) = do
41 strRunName strAskName) = do
45 let effName = TH.mkName strEffName
42 let effName = TH.mkName strEffName
46 tagName = TH.mkName strTagName
43 tagName = TH.mkName strTagName
@@ -50,32 +47,34 @@ ethereal (EtherealReaderConfig
50 askName = TH.mkName strAskName
47 askName = TH.mkName strAskName
51 effDecl <- TH.tySynD effName [] [t| MonadEtherReader $tag |]
48 effDecl <- TH.tySynD effName [] [t| MonadEtherReader $tag |]
52 tagDecl <- emptyDataDecl tagName
49 tagDecl <- emptyDataDecl tagName
53− [tagInst] <- [d| type instance EtherData $tag = $(TH.conT tyname) |]
54 runTransFunSig <- do
50 runTransFunSig <- do
55 (mBndr, m) <- tyVar "m"
51 (mBndr, m) <- tyVar "m"
56 (aBndr, a) <- tyVar "a"
52 (aBndr, a) <- tyVar "a"
53+ (rBndr, r) <- tyVar "r"
57 TH.sigD runTransName
54 TH.sigD runTransName
58− $ TH.forallT [mBndr, aBndr] (return [])
55+ $ TH.forallT [mBndr, aBndr, rBndr] (return [])
59− [t| EtherReaderT $tag $m $a -> EtherData $tag -> $m $a |]
56+ [t| EtherReaderT $tag $r $m $a -> $r -> $m $a |]
60 runTransFunBody <- funSimple runTransName
57 runTransFunBody <- funSimple runTransName
61 [e| runEtherReaderT (Proxy :: Proxy $tag) |]
58 [e| runEtherReaderT (Proxy :: Proxy $tag) |]
62 runFunSig <- do
59 runFunSig <- do
63 (aBndr, a) <- tyVar "a"
60 (aBndr, a) <- tyVar "a"
61+ (rBndr, r) <- tyVar "r"
64 TH.sigD runName
62 TH.sigD runName
65− $ TH.forallT [aBndr] (return [])
63+ $ TH.forallT [aBndr, rBndr] (return [])
66− [t| EtherReaderT $tag Identity $a -> EtherData $tag -> $a |]
64+ [t| EtherReaderT $tag $r Identity $a -> $r -> $a |]
67 runFunBody <- funSimple runName
65 runFunBody <- funSimple runName
68 [e| ((runIdentity.).) $(TH.varE runTransName) |]
66 [e| ((runIdentity.).) $(TH.varE runTransName) |]
69 askFunSig <- do
67 askFunSig <- do
70 (mBndr, m) <- tyVar "m"
68 (mBndr, m) <- tyVar "m"
69+ (rBndr, r) <- tyVar "m"
71 TH.sigD askName
70 TH.sigD askName
72− $ TH.forallT [mBndr]
71+ $ TH.forallT [mBndr, rBndr]
73− (sequence [ [t| MonadEtherReader $tag $m |] ])
72+ (sequence [ [t| MonadEtherReader $tag $r $m |] ])
74− [t| $m (EtherData $tag) |]
73+ [t| $m $r |]
75 askFunBody <-
74 askFunBody <-
76 let body = [e| etherAsk (Proxy :: Proxy $tag) |]
75 let body = [e| etherAsk (Proxy :: Proxy $tag) |]
77 in TH.funD askName [ TH.clause [] (TH.normalB body) [] ]
76 in TH.funD askName [ TH.clause [] (TH.normalB body) [] ]
78− return [ effDecl, tagDecl, tagInst
77+ return [ effDecl, tagDecl
79 , runTransFunSig, runTransFunBody
78 , runTransFunSig, runTransFunBody
80 , runFunSig, runFunBody
79 , runFunSig, runFunBody
81 , askFunSig, askFunBody ]
80 , askFunSig, askFunBody ]
src/Control/Monad/Ether/Reader.hs+15−15
@@ -28,59 +28,59 @@ import qualified Control.Monad.Trans.State.Strict as Trans.Strict (StateT , m
28import qualified Control.Monad.Trans.Writer.Lazy as Trans.Lazy (WriterT , mapWriterT)
28import qualified Control.Monad.Trans.Writer.Lazy as Trans.Lazy (WriterT , mapWriterT)
29import qualified Control.Monad.Trans.Writer.Strict as Trans.Strict (WriterT , mapWriterT)
29import qualified Control.Monad.Trans.Writer.Strict as Trans.Strict (WriterT , mapWriterT)
30
30
31−class MonadEther m => MonadEtherReader tag m where
31+class MonadEther m => MonadEtherReader tag r m where
32
32
33− etherLocal :: proxy tag -> (EtherData tag -> EtherData tag) -> m a -> m a
33+ etherLocal :: proxy tag -> (r -> r) -> m a -> m a
34
34
35− etherAsk :: proxy tag -> m (EtherData tag)
35+ etherAsk :: proxy tag -> m r
36 etherAsk proxy = etherReader proxy id
36 etherAsk proxy = etherReader proxy id
37
37
38− etherReader :: proxy tag -> (EtherData tag -> a) -> m a
38+ etherReader :: proxy tag -> (r -> a) -> m a
39 etherReader proxy f = fmap f (etherAsk proxy)
39 etherReader proxy f = fmap f (etherAsk proxy)
40
40
41instance {-# OVERLAPPING #-} (Monad m, EtherTagless tag m)
41instance {-# OVERLAPPING #-} (Monad m, EtherTagless tag m)
42− => MonadEtherReader tag (EtherReaderT tag m) where
42+ => MonadEtherReader tag r (EtherReaderT tag r m) where
43 etherAsk proxy = etherReaderT proxy return
43 etherAsk proxy = etherReaderT proxy return
44 etherLocal proxy f m = etherReaderT proxy (runEtherReaderT proxy m . f)
44 etherLocal proxy f m = etherReaderT proxy (runEtherReaderT proxy m . f)
45
45
46−instance MonadEtherReader tag m => MonadEtherReader tag (EtherReaderT tag' m) where
46+instance MonadEtherReader tag r m => MonadEtherReader tag r (EtherReaderT tag' r' m) where
47 etherAsk proxy = lift (etherAsk proxy)
47 etherAsk proxy = lift (etherAsk proxy)
48 etherLocal proxy = mapEtherReaderT Proxy . etherLocal proxy
48 etherLocal proxy = mapEtherReaderT Proxy . etherLocal proxy
49
49
50-- Instances for mtl transformers
50-- Instances for mtl transformers
51
51
52−instance MonadEtherReader tag m => MonadEtherReader tag (Trans.ContT r m) where
52+instance MonadEtherReader tag r m => MonadEtherReader tag r (Trans.ContT r' m) where
53 etherAsk proxy = lift (etherAsk proxy)
53 etherAsk proxy = lift (etherAsk proxy)
54 etherLocal proxy = Trans.liftLocal (etherAsk proxy) (etherLocal proxy)
54 etherLocal proxy = Trans.liftLocal (etherAsk proxy) (etherLocal proxy)
55
55
56−instance MonadEtherReader tag m => MonadEtherReader tag (Trans.ExceptT e m) where
56+instance MonadEtherReader tag r m => MonadEtherReader tag r (Trans.ExceptT e m) where
57 etherAsk proxy = lift (etherAsk proxy)
57 etherAsk proxy = lift (etherAsk proxy)
58 etherLocal proxy = Trans.mapExceptT . etherLocal proxy
58 etherLocal proxy = Trans.mapExceptT . etherLocal proxy
59
59
60−instance MonadEtherReader tag m => MonadEtherReader tag (Trans.IdentityT m) where
60+instance MonadEtherReader tag r m => MonadEtherReader tag r (Trans.IdentityT m) where
61 etherAsk proxy = lift (etherAsk proxy)
61 etherAsk proxy = lift (etherAsk proxy)
62 etherLocal proxy = Trans.mapIdentityT . etherLocal proxy
62 etherLocal proxy = Trans.mapIdentityT . etherLocal proxy
63
63
64−instance MonadEtherReader tag m => MonadEtherReader tag (Trans.ListT m) where
64+instance MonadEtherReader tag r m => MonadEtherReader tag r (Trans.ListT m) where
65 etherAsk proxy = lift (etherAsk proxy)
65 etherAsk proxy = lift (etherAsk proxy)
66 etherLocal proxy = Trans.mapListT . etherLocal proxy
66 etherLocal proxy = Trans.mapListT . etherLocal proxy
67
67
68−instance MonadEtherReader tag m => MonadEtherReader tag (Trans.MaybeT m) where
68+instance MonadEtherReader tag r m => MonadEtherReader tag r (Trans.MaybeT m) where
69 etherAsk proxy = lift (etherAsk proxy)
69 etherAsk proxy = lift (etherAsk proxy)
70 etherLocal proxy = Trans.mapMaybeT . etherLocal proxy
70 etherLocal proxy = Trans.mapMaybeT . etherLocal proxy
71
71
72−instance MonadEtherReader tag m => MonadEtherReader tag (Trans.Lazy.StateT s m) where
72+instance MonadEtherReader tag r m => MonadEtherReader tag r (Trans.Lazy.StateT s m) where
73 etherAsk proxy = lift (etherAsk proxy)
73 etherAsk proxy = lift (etherAsk proxy)
74 etherLocal proxy = Trans.Lazy.mapStateT . etherLocal proxy
74 etherLocal proxy = Trans.Lazy.mapStateT . etherLocal proxy
75
75
76−instance MonadEtherReader tag m => MonadEtherReader tag (Trans.Strict.StateT s m) where
76+instance MonadEtherReader tag r m => MonadEtherReader tag r (Trans.Strict.StateT s m) where
77 etherAsk proxy = lift (etherAsk proxy)
77 etherAsk proxy = lift (etherAsk proxy)
78 etherLocal proxy = Trans.Strict.mapStateT . etherLocal proxy
78 etherLocal proxy = Trans.Strict.mapStateT . etherLocal proxy
79
79
80−instance (Monoid w, MonadEtherReader tag m) => MonadEtherReader tag (Trans.Lazy.WriterT w m) where
80+instance (Monoid w, MonadEtherReader tag r m) => MonadEtherReader tag r (Trans.Lazy.WriterT w m) where
81 etherAsk proxy = lift (etherAsk proxy)
81 etherAsk proxy = lift (etherAsk proxy)
82 etherLocal proxy = Trans.Lazy.mapWriterT . etherLocal proxy
82 etherLocal proxy = Trans.Lazy.mapWriterT . etherLocal proxy
83
83
84−instance (Monoid w, MonadEtherReader tag m) => MonadEtherReader tag (Trans.Strict.WriterT w m) where
84+instance (Monoid w, MonadEtherReader tag r m) => MonadEtherReader tag r (Trans.Strict.WriterT w m) where
85 etherAsk proxy = lift (etherAsk proxy)
85 etherAsk proxy = lift (etherAsk proxy)
86 etherLocal proxy = Trans.Strict.mapWriterT . etherLocal proxy
86 etherLocal proxy = Trans.Strict.mapWriterT . etherLocal proxy
src/Control/Monad/Trans/Ether/Reader.hs+16−16
@@ -26,49 +26,49 @@ import qualified Control.Monad.State.Class as Class
26import qualified Control.Monad.Writer.Class as Class
26import qualified Control.Monad.Writer.Class as Class
27import qualified Control.Monad.Error.Class as Class
27import qualified Control.Monad.Error.Class as Class
28
28
29−newtype EtherReaderT tag m a = EtherReaderT (R.ReaderT (EtherData tag) m a)
29+newtype EtherReaderT tag r m a = EtherReaderT (R.ReaderT r m a)
30 deriving ( Functor, Applicative, Alternative, Monad, MonadPlus
30 deriving ( Functor, Applicative, Alternative, Monad, MonadPlus
31 , MonadFix, MonadTrans, MonadIO )
31 , MonadFix, MonadTrans, MonadIO )
32
32
33−instance Monad m => MonadEther (EtherReaderT tag m) where
33+instance Monad m => MonadEther (EtherReaderT tag r m) where
34− type EtherTags (EtherReaderT tag m) = tag ': EtherTags m
34+ type EtherTags (EtherReaderT tag r m) = tag ': EtherTags m
35
35
36−etherReaderT :: proxy tag -> (EtherData tag -> m a) -> EtherReaderT tag m a
36+etherReaderT :: proxy tag -> (r -> m a) -> EtherReaderT tag r m a
37etherReaderT _proxy = EtherReaderT . R.ReaderT
37etherReaderT _proxy = EtherReaderT . R.ReaderT
38
38
39−runEtherReaderT :: proxy tag -> EtherReaderT tag m a -> EtherData tag -> m a
39+runEtherReaderT :: proxy tag -> EtherReaderT tag r m a -> r -> m a
40runEtherReaderT _proxy (EtherReaderT (R.ReaderT s)) = s
40runEtherReaderT _proxy (EtherReaderT (R.ReaderT s)) = s
41
41
42−mapEtherReaderT :: proxy tag -> (m a -> n b) -> EtherReaderT tag m a -> EtherReaderT tag n b
42+mapEtherReaderT :: proxy tag -> (m a -> n b) -> EtherReaderT tag r m a -> EtherReaderT tag r n b
43−mapEtherReaderT _proxy f m = coerce $ R.mapReaderT f (coerce m)
43+mapEtherReaderT _proxy f m = EtherReaderT $ R.mapReaderT f (coerce m)
44
44
45−liftCatch :: proxy tag -> Sig.Catch e m a -> Sig.Catch e (EtherReaderT tag m) a
45+liftCatch :: proxy tag -> Sig.Catch e m a -> Sig.Catch e (EtherReaderT tag r m) a
46−liftCatch _proxy f m h = coerce $ R.liftCatch f (coerce m) (coerce h)
46+liftCatch _proxy f m h = EtherReaderT $ R.liftCatch f (coerce m) (coerce h)
47
47
48−liftCallCC :: proxy tag -> Sig.CallCC m a b -> Sig.CallCC (EtherReaderT tag m) a b
48+liftCallCC :: proxy tag -> Sig.CallCC m a b -> Sig.CallCC (EtherReaderT tag r m) a b
49−liftCallCC _proxy callCC f = coerce $ R.liftCallCC callCC (coerce f)
49+liftCallCC _proxy callCC f = EtherReaderT $ R.liftCallCC callCC (coerce f)
50
50
51-- Instances for mtl classes
51-- Instances for mtl classes
52
52
53−instance Class.MonadCont m => Class.MonadCont (EtherReaderT tag m) where
53+instance Class.MonadCont m => Class.MonadCont (EtherReaderT tag r m) where
54 callCC = liftCallCC Proxy Class.callCC
54 callCC = liftCallCC Proxy Class.callCC
55
55
56−instance Class.MonadReader r m => Class.MonadReader r (EtherReaderT tag m) where
56+instance Class.MonadReader r' m => Class.MonadReader r' (EtherReaderT tag r m) where
57 ask = lift Class.ask
57 ask = lift Class.ask
58 local = mapEtherReaderT Proxy . Class.local
58 local = mapEtherReaderT Proxy . Class.local
59 reader = lift . Class.reader
59 reader = lift . Class.reader
60
60
61−instance Class.MonadState s m => Class.MonadState s (EtherReaderT tag m) where
61+instance Class.MonadState s m => Class.MonadState s (EtherReaderT tag r m) where
62 get = lift Class.get
62 get = lift Class.get
63 put = lift . Class.put
63 put = lift . Class.put
64 state = lift . Class.state
64 state = lift . Class.state
65
65
66−instance Class.MonadWriter w m => Class.MonadWriter w (EtherReaderT tag m) where
66+instance Class.MonadWriter w m => Class.MonadWriter w (EtherReaderT tag r m) where
67 writer = lift . Class.writer
67 writer = lift . Class.writer
68 tell = lift . Class.tell
68 tell = lift . Class.tell
69 listen = mapEtherReaderT Proxy Class.listen
69 listen = mapEtherReaderT Proxy Class.listen
70 pass = mapEtherReaderT Proxy Class.pass
70 pass = mapEtherReaderT Proxy Class.pass
71
71
72−instance Class.MonadError e m => Class.MonadError e (EtherReaderT tag m) where
72+instance Class.MonadError e m => Class.MonadError e (EtherReaderT tag r m) where
73 throwError = lift . Class.throwError
73 throwError = lift . Class.throwError
74 catchError = liftCatch Proxy Class.catchError
74 catchError = liftCatch Proxy Class.catchError
test/Regression.hs+4−4
@@ -14,8 +14,8 @@ import Test.Tasty
14import Test.Tasty.QuickCheck
14import Test.Tasty.QuickCheck
15import Test.QuickCheck.Function
15import Test.QuickCheck.Function
16
16
17−ethereal (defaultEtherealReaderConfig ''Int "Amount")
17+ethereal (defaultEtherealReaderConfig "Amount")
18−ethereal (defaultEtherealReaderConfig ''Integer "Count")
18+ethereal (defaultEtherealReaderConfig "Count")
19
19
20main :: IO ()
20main :: IO ()
21main = defaultMain suite
21main = defaultMain suite
@@ -44,7 +44,7 @@ layeredLocalRight k f a1 a2 = property (direct == run indirect)
44 (direct, indirect) = layeredLocalCore' k f a1 a2
44 (direct, indirect) = layeredLocalCore' k f a1 a2
45
45
46layeredLocalCore
46layeredLocalCore
47− :: (MonadAmount m, MonadCount m)
47+ :: (MonadAmount Int m, MonadCount Integer m)
48 => (Integer -> Integer) -> (Int -> Integer -> a) -> m a
48 => (Integer -> Integer) -> (Int -> Integer -> a) -> m a
49layeredLocalCore f g = do
49layeredLocalCore f g = do
50 n <- askAmount
50 n <- askAmount
@@ -52,7 +52,7 @@ layeredLocalCore f g = do
52 return (g n m)
52 return (g n m)
53
53
54layeredLocalCore'
54layeredLocalCore'
55− :: (MonadAmount m, MonadCount m)
55+ :: (MonadAmount Int m, MonadCount Integer m)
56 => Fun (Int, Integer) Integer
56 => Fun (Int, Integer) Integer
57 -> Fun Integer Integer
57 -> Fun Integer Integer
58 -> Int -> Integer -> (Integer, m Integer)
58 -> Int -> Integer -> (Integer, m Integer)