git.iko.soy/typeable/ether
on master help sign in
Remove EtherData
commit67f2cbf6eeb88a758b2f528347073ea7234918e5 authorIndex Int <vlad.z.4096@gmail.com> dateSat 6 Jun 2015, 19:07 (11 years ago) parent9616e0c
5 files changed+51−55
compare with master
unifiedsplit
src/Control/Ether/Core.hs+1−4 src/Control/Ether/TH.hs+15−16 src/Control/Monad/Ether/Reader.hs+15−15 src/Control/Monad/Trans/Ether/Reader.hs+16−16 test/Regression.hs+4−4
src/Control/Ether/Core.hs+1−4
@@ -5,8 +5,7 @@
55{-# LANGUAGE TypeOperators #-}
66{-# LANGUAGE UndecidableInstances #-}
77module Control.Ether.Core
8− ( EtherData
9− , EtherTagless
8+ ( EtherTagless
109 , MonadEther
1110 , EtherTags
1211 ) where
@@ -24,8 +23,6 @@ import qualified Control.Monad.Trans.State.Strict as Trans.Strict
2423import qualified Control.Monad.Trans.Writer.Lazy as Trans.Lazy
2524import qualified Control.Monad.Trans.Writer.Strict as Trans.Strict
2625
27−type family EtherData tag :: *
28−
2926type family OR (a :: Bool) (b :: Bool) :: Bool where
3027 OR 'True a = 'True
3128 OR 'False a = a
src/Control/Ether/TH.hs+15−16
@@ -9,7 +9,6 @@ import qualified Language.Haskell.TH as TH
99
1010import Data.Proxy
1111import Data.Functor.Identity
12−import Control.Ether.Core
1312import Control.Monad.Ether.Reader
1413
1514emptyDataDecl :: TH.Name -> TH.DecQ
@@ -25,11 +24,10 @@ tyVar name = do
2524 return (TH.PlainTV thName, thType)
2625
2726data EtherealConfig
28− = EtherealReaderConfig TH.Name String String String String String
27+ = EtherealReaderConfig String String String String String
2928
30−defaultEtherealReaderConfig :: TH.Name -> String -> EtherealConfig
31−defaultEtherealReaderConfig tyname name = EtherealReaderConfig
32− tyname
29+defaultEtherealReaderConfig :: String -> EtherealConfig
30+defaultEtherealReaderConfig name = EtherealReaderConfig
3331 ("Monad" ++ name)
3432 ("Tag" ++ name)
3533 ("run" ++ name ++ "T")
@@ -39,8 +37,7 @@ defaultEtherealReaderConfig tyname name = EtherealReaderConfig
3937ethereal :: EtherealConfig -> TH.DecsQ
4038
4139ethereal (EtherealReaderConfig
42− tyname strEffName
43− strTagName strRunTransName
40+ strEffName strTagName strRunTransName
4441 strRunName strAskName) = do
4542 let effName = TH.mkName strEffName
4643 tagName = TH.mkName strTagName
@@ -50,32 +47,34 @@ ethereal (EtherealReaderConfig
5047 askName = TH.mkName strAskName
5148 effDecl <- TH.tySynD effName [] [t| MonadEtherReader $tag |]
5249 tagDecl <- emptyDataDecl tagName
53− [tagInst] <- [d| type instance EtherData $tag = $(TH.conT tyname) |]
5450 runTransFunSig <- do
5551 (mBndr, m) <- tyVar "m"
5652 (aBndr, a) <- tyVar "a"
53+ (rBndr, r) <- tyVar "r"
5754 TH.sigD runTransName
58− $ TH.forallT [mBndr, aBndr] (return [])
59− [t| EtherReaderT $tag $m $a -> EtherData $tag -> $m $a |]
55+ $ TH.forallT [mBndr, aBndr, rBndr] (return [])
56+ [t| EtherReaderT $tag $r $m $a -> $r -> $m $a |]
6057 runTransFunBody <- funSimple runTransName
6158 [e| runEtherReaderT (Proxy :: Proxy $tag) |]
6259 runFunSig <- do
6360 (aBndr, a) <- tyVar "a"
61+ (rBndr, r) <- tyVar "r"
6462 TH.sigD runName
65− $ TH.forallT [aBndr] (return [])
66− [t| EtherReaderT $tag Identity $a -> EtherData $tag -> $a |]
63+ $ TH.forallT [aBndr, rBndr] (return [])
64+ [t| EtherReaderT $tag $r Identity $a -> $r -> $a |]
6765 runFunBody <- funSimple runName
6866 [e| ((runIdentity.).) $(TH.varE runTransName) |]
6967 askFunSig <- do
7068 (mBndr, m) <- tyVar "m"
69+ (rBndr, r) <- tyVar "m"
7170 TH.sigD askName
72− $ TH.forallT [mBndr]
73− (sequence [ [t| MonadEtherReader $tag $m |] ])
74− [t| $m (EtherData $tag) |]
71+ $ TH.forallT [mBndr, rBndr]
72+ (sequence [ [t| MonadEtherReader $tag $r $m |] ])
73+ [t| $m $r |]
7574 askFunBody <-
7675 let body = [e| etherAsk (Proxy :: Proxy $tag) |]
7776 in TH.funD askName [ TH.clause [] (TH.normalB body) [] ]
78− return [ effDecl, tagDecl, tagInst
77+ return [ effDecl, tagDecl
7978 , runTransFunSig, runTransFunBody
8079 , runFunSig, runFunBody
8180 , 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
2828import qualified Control.Monad.Trans.Writer.Lazy as Trans.Lazy (WriterT , mapWriterT)
2929import qualified Control.Monad.Trans.Writer.Strict as Trans.Strict (WriterT , mapWriterT)
3030
31−class MonadEther m => MonadEtherReader tag m where
31+class MonadEther m => MonadEtherReader tag r m where
3232
33− etherLocal :: proxy tag -> (EtherData tag -> EtherData tag) -> m a -> m a
33+ etherLocal :: proxy tag -> (r -> r) -> m a -> m a
3434
35− etherAsk :: proxy tag -> m (EtherData tag)
35+ etherAsk :: proxy tag -> m r
3636 etherAsk proxy = etherReader proxy id
3737
38− etherReader :: proxy tag -> (EtherData tag -> a) -> m a
38+ etherReader :: proxy tag -> (r -> a) -> m a
3939 etherReader proxy f = fmap f (etherAsk proxy)
4040
4141instance {-# OVERLAPPING #-} (Monad m, EtherTagless tag m)
42− => MonadEtherReader tag (EtherReaderT tag m) where
42+ => MonadEtherReader tag r (EtherReaderT tag r m) where
4343 etherAsk proxy = etherReaderT proxy return
4444 etherLocal proxy f m = etherReaderT proxy (runEtherReaderT proxy m . f)
4545
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
4747 etherAsk proxy = lift (etherAsk proxy)
4848 etherLocal proxy = mapEtherReaderT Proxy . etherLocal proxy
4949
5050-- Instances for mtl transformers
5151
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
5353 etherAsk proxy = lift (etherAsk proxy)
5454 etherLocal proxy = Trans.liftLocal (etherAsk proxy) (etherLocal proxy)
5555
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
5757 etherAsk proxy = lift (etherAsk proxy)
5858 etherLocal proxy = Trans.mapExceptT . etherLocal proxy
5959
60−instance MonadEtherReader tag m => MonadEtherReader tag (Trans.IdentityT m) where
60+instance MonadEtherReader tag r m => MonadEtherReader tag r (Trans.IdentityT m) where
6161 etherAsk proxy = lift (etherAsk proxy)
6262 etherLocal proxy = Trans.mapIdentityT . etherLocal proxy
6363
64−instance MonadEtherReader tag m => MonadEtherReader tag (Trans.ListT m) where
64+instance MonadEtherReader tag r m => MonadEtherReader tag r (Trans.ListT m) where
6565 etherAsk proxy = lift (etherAsk proxy)
6666 etherLocal proxy = Trans.mapListT . etherLocal proxy
6767
68−instance MonadEtherReader tag m => MonadEtherReader tag (Trans.MaybeT m) where
68+instance MonadEtherReader tag r m => MonadEtherReader tag r (Trans.MaybeT m) where
6969 etherAsk proxy = lift (etherAsk proxy)
7070 etherLocal proxy = Trans.mapMaybeT . etherLocal proxy
7171
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
7373 etherAsk proxy = lift (etherAsk proxy)
7474 etherLocal proxy = Trans.Lazy.mapStateT . etherLocal proxy
7575
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
7777 etherAsk proxy = lift (etherAsk proxy)
7878 etherLocal proxy = Trans.Strict.mapStateT . etherLocal proxy
7979
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
8181 etherAsk proxy = lift (etherAsk proxy)
8282 etherLocal proxy = Trans.Lazy.mapWriterT . etherLocal proxy
8383
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
8585 etherAsk proxy = lift (etherAsk proxy)
8686 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
2626import qualified Control.Monad.Writer.Class as Class
2727import qualified Control.Monad.Error.Class as Class
2828
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)
3030 deriving ( Functor, Applicative, Alternative, Monad, MonadPlus
3131 , MonadFix, MonadTrans, MonadIO )
3232
33−instance Monad m => MonadEther (EtherReaderT tag m) where
34− type EtherTags (EtherReaderT tag m) = tag ': EtherTags m
33+instance Monad m => MonadEther (EtherReaderT tag r m) where
34+ type EtherTags (EtherReaderT tag r m) = tag ': EtherTags m
3535
36−etherReaderT :: proxy tag -> (EtherData tag -> m a) -> EtherReaderT tag m a
36+etherReaderT :: proxy tag -> (r -> m a) -> EtherReaderT tag r m a
3737etherReaderT _proxy = EtherReaderT . R.ReaderT
3838
39−runEtherReaderT :: proxy tag -> EtherReaderT tag m a -> EtherData tag -> m a
39+runEtherReaderT :: proxy tag -> EtherReaderT tag r m a -> r -> m a
4040runEtherReaderT _proxy (EtherReaderT (R.ReaderT s)) = s
4141
42−mapEtherReaderT :: proxy tag -> (m a -> n b) -> EtherReaderT tag m a -> EtherReaderT tag n b
43−mapEtherReaderT _proxy f m = coerce $ R.mapReaderT f (coerce m)
42+mapEtherReaderT :: proxy tag -> (m a -> n b) -> EtherReaderT tag r m a -> EtherReaderT tag r n b
43+mapEtherReaderT _proxy f m = EtherReaderT $ R.mapReaderT f (coerce m)
4444
45−liftCatch :: proxy tag -> Sig.Catch e m a -> Sig.Catch e (EtherReaderT tag m) a
46−liftCatch _proxy f m h = coerce $ R.liftCatch f (coerce m) (coerce h)
45+liftCatch :: proxy tag -> Sig.Catch e m a -> Sig.Catch e (EtherReaderT tag r m) a
46+liftCatch _proxy f m h = EtherReaderT $ R.liftCatch f (coerce m) (coerce h)
4747
48−liftCallCC :: proxy tag -> Sig.CallCC m a b -> Sig.CallCC (EtherReaderT tag m) a b
49−liftCallCC _proxy callCC f = coerce $ R.liftCallCC callCC (coerce f)
48+liftCallCC :: proxy tag -> Sig.CallCC m a b -> Sig.CallCC (EtherReaderT tag r m) a b
49+liftCallCC _proxy callCC f = EtherReaderT $ R.liftCallCC callCC (coerce f)
5050
5151-- Instances for mtl classes
5252
53−instance Class.MonadCont m => Class.MonadCont (EtherReaderT tag m) where
53+instance Class.MonadCont m => Class.MonadCont (EtherReaderT tag r m) where
5454 callCC = liftCallCC Proxy Class.callCC
5555
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
5757 ask = lift Class.ask
5858 local = mapEtherReaderT Proxy . Class.local
5959 reader = lift . Class.reader
6060
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
6262 get = lift Class.get
6363 put = lift . Class.put
6464 state = lift . Class.state
6565
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
6767 writer = lift . Class.writer
6868 tell = lift . Class.tell
6969 listen = mapEtherReaderT Proxy Class.listen
7070 pass = mapEtherReaderT Proxy Class.pass
7171
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
7373 throwError = lift . Class.throwError
7474 catchError = liftCatch Proxy Class.catchError
test/Regression.hs+4−4
@@ -14,8 +14,8 @@ import Test.Tasty
1414import Test.Tasty.QuickCheck
1515import Test.QuickCheck.Function
1616
17−ethereal (defaultEtherealReaderConfig ''Int "Amount")
18−ethereal (defaultEtherealReaderConfig ''Integer "Count")
17+ethereal (defaultEtherealReaderConfig "Amount")
18+ethereal (defaultEtherealReaderConfig "Count")
1919
2020main :: IO ()
2121main = defaultMain suite
@@ -44,7 +44,7 @@ layeredLocalRight k f a1 a2 = property (direct == run indirect)
4444 (direct, indirect) = layeredLocalCore' k f a1 a2
4545
4646layeredLocalCore
47− :: (MonadAmount m, MonadCount m)
47+ :: (MonadAmount Int m, MonadCount Integer m)
4848 => (Integer -> Integer) -> (Int -> Integer -> a) -> m a
4949layeredLocalCore f g = do
5050 n <- askAmount
@@ -52,7 +52,7 @@ layeredLocalCore f g = do
5252 return (g n m)
5353
5454layeredLocalCore'
55− :: (MonadAmount m, MonadCount m)
55+ :: (MonadAmount Int m, MonadCount Integer m)
5656 => Fun (Int, Integer) Integer
5757 -> Fun Integer Integer
5858 -> Int -> Integer -> (Integer, m Integer)