git.iko.soy/typeable/ether
on master help sign in
Ensure tag uniqueness in monad stacks
commit9616e0c7c9700a0898d4d6a6c2c5faec494be365 authorIndex Int <vlad.z.4096@gmail.com> dateSat 6 Jun 2015, 18:23 (11 years ago) parent4bcafed
4 files changed+109−36
compare with master
unifiedsplit
src/Control/Ether/Core.hs+69 src/Control/Monad/Ether/Reader.hs+34−31 src/Control/Monad/Trans/Ether/Reader.hs+6−1 test/Regression.hs−4
src/Control/Ether/Core.hs+69
@@ -1,6 +1,75 @@
11{-# LANGUAGE TypeFamilies #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE PolyKinds #-}
4+{-# LANGUAGE ConstraintKinds #-}
5+{-# LANGUAGE TypeOperators #-}
6+{-# LANGUAGE UndecidableInstances #-}
27module Control.Ether.Core
38 ( EtherData
9+ , EtherTagless
10+ , MonadEther
11+ , EtherTags
412 ) where
513
14+import Data.Functor.Identity
15+import GHC.Exts (Constraint)
16+
17+import qualified Control.Monad.Trans.Cont as Trans
18+import qualified Control.Monad.Trans.Except as Trans
19+import qualified Control.Monad.Trans.Identity as Trans
20+import qualified Control.Monad.Trans.List as Trans
21+import qualified Control.Monad.Trans.Maybe as Trans
22+import qualified Control.Monad.Trans.State.Lazy as Trans.Lazy
23+import qualified Control.Monad.Trans.State.Strict as Trans.Strict
24+import qualified Control.Monad.Trans.Writer.Lazy as Trans.Lazy
25+import qualified Control.Monad.Trans.Writer.Strict as Trans.Strict
26+
627type family EtherData tag :: *
28+
29+type family OR (a :: Bool) (b :: Bool) :: Bool where
30+ OR 'True a = 'True
31+ OR 'False a = a
32+
33+type family ELEM (x :: k) (as :: [k]) :: Bool where
34+ ELEM x (x ': as) = 'True
35+ ELEM x (a ': as) = ELEM x as
36+ ELEM x '[] = 'False
37+
38+type family EtherTagless (tag :: *) (m :: * -> *) :: Constraint where
39+ EtherTagless tag m = ELEM tag (EtherTags m) ~ 'False
40+
41+class Monad m => MonadEther m where
42+ type family EtherTags m :: [*]
43+
44+instance MonadEther IO where
45+ type EtherTags IO = '[]
46+
47+instance MonadEther Identity where
48+ type EtherTags Identity = '[]
49+
50+instance Monad m => MonadEther (Trans.ContT r m) where
51+ type EtherTags (Trans.ContT r m) = EtherTags m
52+
53+instance Monad m => MonadEther (Trans.ExceptT e m) where
54+ type EtherTags (Trans.ExceptT e m) = EtherTags m
55+
56+instance Monad m => MonadEther (Trans.IdentityT m) where
57+ type EtherTags (Trans.IdentityT m) = EtherTags m
58+
59+instance Monad m => MonadEther (Trans.ListT m) where
60+ type EtherTags (Trans.ListT m) = EtherTags m
61+
62+instance Monad m => MonadEther (Trans.MaybeT m) where
63+ type EtherTags (Trans.MaybeT m) = EtherTags m
64+
65+instance Monad m => MonadEther (Trans.Lazy.StateT s m) where
66+ type EtherTags (Trans.Lazy.StateT s m) = EtherTags m
67+
68+instance Monad m => MonadEther (Trans.Strict.StateT s m) where
69+ type EtherTags (Trans.Strict.StateT s m) = EtherTags m
70+
71+instance (Monoid w, Monad m) => MonadEther (Trans.Lazy.WriterT w m) where
72+ type EtherTags (Trans.Lazy.WriterT w m) = EtherTags m
73+
74+instance (Monoid w, Monad m) => MonadEther (Trans.Strict.WriterT w m) where
75+ type EtherTags (Trans.Strict.WriterT w m) = EtherTags m
src/Control/Monad/Ether/Reader.hs+34−31
@@ -3,6 +3,8 @@
33{-# LANGUAGE FlexibleInstances #-}
44{-# LANGUAGE FlexibleContexts #-}
55{-# LANGUAGE UndecidableInstances #-}
6+{-# LANGUAGE DataKinds #-}
7+{-# LANGUAGE TypeOperators #-}
68{-# LANGUAGE GeneralizedNewtypeDeriving #-}
79module Control.Monad.Ether.Reader
810 ( module Control.Monad.Ether.Reader
@@ -12,21 +14,21 @@ module Control.Monad.Ether.Reader
1214import Data.Proxy (Proxy(Proxy))
1315import Control.Monad.Trans (lift)
1416
15−import Control.Ether.Core (EtherData)
17+import Control.Ether.Core
1618import Control.Monad.Trans.Ether.Reader
1719
1820-- for mtl instances
19−import qualified Control.Monad.Trans.Cont as Cont (ContT , liftLocal)
20−import qualified Control.Monad.Trans.Except as Except (ExceptT , mapExceptT)
21−import qualified Control.Monad.Trans.Identity as Identity (IdentityT, mapIdentityT)
22−import qualified Control.Monad.Trans.List as List (ListT , mapListT)
23−import qualified Control.Monad.Trans.Maybe as Maybe (MaybeT , mapMaybeT)
24−import qualified Control.Monad.Trans.State.Lazy as State.Lazy (StateT , mapStateT)
25−import qualified Control.Monad.Trans.State.Strict as State.Strict (StateT , mapStateT)
26−import qualified Control.Monad.Trans.Writer.Lazy as Writer.Lazy (WriterT , mapWriterT)
27−import qualified Control.Monad.Trans.Writer.Strict as Writer.Strict (WriterT , mapWriterT)
28−
29−class Monad m => MonadEtherReader tag m where
21+import qualified Control.Monad.Trans.Cont as Trans (ContT , liftLocal)
22+import qualified Control.Monad.Trans.Except as Trans (ExceptT , mapExceptT)
23+import qualified Control.Monad.Trans.Identity as Trans (IdentityT, mapIdentityT)
24+import qualified Control.Monad.Trans.List as Trans (ListT , mapListT)
25+import qualified Control.Monad.Trans.Maybe as Trans (MaybeT , mapMaybeT)
26+import qualified Control.Monad.Trans.State.Lazy as Trans.Lazy (StateT , mapStateT)
27+import qualified Control.Monad.Trans.State.Strict as Trans.Strict (StateT , mapStateT)
28+import qualified Control.Monad.Trans.Writer.Lazy as Trans.Lazy (WriterT , mapWriterT)
29+import qualified Control.Monad.Trans.Writer.Strict as Trans.Strict (WriterT , mapWriterT)
30+
31+class MonadEther m => MonadEtherReader tag m where
3032
3133 etherLocal :: proxy tag -> (EtherData tag -> EtherData tag) -> m a -> m a
3234
@@ -36,7 +38,8 @@ class Monad m => MonadEtherReader tag m where
3638 etherReader :: proxy tag -> (EtherData tag -> a) -> m a
3739 etherReader proxy f = fmap f (etherAsk proxy)
3840
39−instance {-# OVERLAPS #-} Monad m => MonadEtherReader tag (EtherReaderT tag m) where
41+instance {-# OVERLAPPING #-} (Monad m, EtherTagless tag m)
42+ => MonadEtherReader tag (EtherReaderT tag m) where
4043 etherAsk proxy = etherReaderT proxy return
4144 etherLocal proxy f m = etherReaderT proxy (runEtherReaderT proxy m . f)
4245
@@ -46,38 +49,38 @@ instance MonadEtherReader tag m => MonadEtherReader tag (EtherReaderT tag' m) wh
4649
4750-- Instances for mtl transformers
4851
49−instance MonadEtherReader tag m => MonadEtherReader tag (Cont.ContT r m) where
52+instance MonadEtherReader tag m => MonadEtherReader tag (Trans.ContT r m) where
5053 etherAsk proxy = lift (etherAsk proxy)
51− etherLocal proxy = Cont.liftLocal (etherAsk proxy) (etherLocal proxy)
54+ etherLocal proxy = Trans.liftLocal (etherAsk proxy) (etherLocal proxy)
5255
53−instance MonadEtherReader tag m => MonadEtherReader tag (Except.ExceptT e m) where
56+instance MonadEtherReader tag m => MonadEtherReader tag (Trans.ExceptT e m) where
5457 etherAsk proxy = lift (etherAsk proxy)
55− etherLocal proxy = Except.mapExceptT . etherLocal proxy
58+ etherLocal proxy = Trans.mapExceptT . etherLocal proxy
5659
57−instance MonadEtherReader tag m => MonadEtherReader tag (Identity.IdentityT m) where
60+instance MonadEtherReader tag m => MonadEtherReader tag (Trans.IdentityT m) where
5861 etherAsk proxy = lift (etherAsk proxy)
59− etherLocal proxy = Identity.mapIdentityT . etherLocal proxy
62+ etherLocal proxy = Trans.mapIdentityT . etherLocal proxy
6063
61−instance MonadEtherReader tag m => MonadEtherReader tag (List.ListT m) where
64+instance MonadEtherReader tag m => MonadEtherReader tag (Trans.ListT m) where
6265 etherAsk proxy = lift (etherAsk proxy)
63− etherLocal proxy = List.mapListT . etherLocal proxy
66+ etherLocal proxy = Trans.mapListT . etherLocal proxy
6467
65−instance MonadEtherReader tag m => MonadEtherReader tag (Maybe.MaybeT m) where
68+instance MonadEtherReader tag m => MonadEtherReader tag (Trans.MaybeT m) where
6669 etherAsk proxy = lift (etherAsk proxy)
67− etherLocal proxy = Maybe.mapMaybeT . etherLocal proxy
70+ etherLocal proxy = Trans.mapMaybeT . etherLocal proxy
6871
69−instance MonadEtherReader tag m => MonadEtherReader tag (State.Lazy.StateT s m) where
72+instance MonadEtherReader tag m => MonadEtherReader tag (Trans.Lazy.StateT s m) where
7073 etherAsk proxy = lift (etherAsk proxy)
71− etherLocal proxy = State.Lazy.mapStateT . etherLocal proxy
74+ etherLocal proxy = Trans.Lazy.mapStateT . etherLocal proxy
7275
73−instance MonadEtherReader tag m => MonadEtherReader tag (State.Strict.StateT s m) where
76+instance MonadEtherReader tag m => MonadEtherReader tag (Trans.Strict.StateT s m) where
7477 etherAsk proxy = lift (etherAsk proxy)
75− etherLocal proxy = State.Strict.mapStateT . etherLocal proxy
78+ etherLocal proxy = Trans.Strict.mapStateT . etherLocal proxy
7679
77−instance (Monoid w, MonadEtherReader tag m) => MonadEtherReader tag (Writer.Lazy.WriterT w m) where
80+instance (Monoid w, MonadEtherReader tag m) => MonadEtherReader tag (Trans.Lazy.WriterT w m) where
7881 etherAsk proxy = lift (etherAsk proxy)
79− etherLocal proxy = Writer.Lazy.mapWriterT . etherLocal proxy
82+ etherLocal proxy = Trans.Lazy.mapWriterT . etherLocal proxy
8083
81−instance (Monoid w, MonadEtherReader tag m) => MonadEtherReader tag (Writer.Strict.WriterT w m) where
84+instance (Monoid w, MonadEtherReader tag m) => MonadEtherReader tag (Trans.Strict.WriterT w m) where
8285 etherAsk proxy = lift (etherAsk proxy)
83− etherLocal proxy = Writer.Strict.mapWriterT . etherLocal proxy
86+ etherLocal proxy = Trans.Strict.mapWriterT . etherLocal proxy
src/Control/Monad/Trans/Ether/Reader.hs+6−1
@@ -3,6 +3,8 @@
33{-# LANGUAGE FlexibleInstances #-}
44{-# LANGUAGE FlexibleContexts #-}
55{-# LANGUAGE UndecidableInstances #-}
6+{-# LANGUAGE DataKinds #-}
7+{-# LANGUAGE TypeOperators #-}
68{-# LANGUAGE GeneralizedNewtypeDeriving #-}
79module Control.Monad.Trans.Ether.Reader where
810
@@ -13,7 +15,7 @@ import Control.Monad (MonadPlus)
1315import Control.Monad.Fix (MonadFix)
1416import Control.Monad.Trans.Class (MonadTrans, lift)
1517import Control.Monad.IO.Class (MonadIO)
16−import Control.Ether.Core (EtherData)
18+import Control.Ether.Core
1719
1820import qualified Control.Monad.Signatures as Sig
1921import qualified Control.Monad.Trans.Reader as R
@@ -28,6 +30,9 @@ newtype EtherReaderT tag m a = EtherReaderT (R.ReaderT (EtherData tag) m a)
2830 deriving ( Functor, Applicative, Alternative, Monad, MonadPlus
2931 , MonadFix, MonadTrans, MonadIO )
3032
33+instance Monad m => MonadEther (EtherReaderT tag m) where
34+ type EtherTags (EtherReaderT tag m) = tag ': EtherTags m
35+
3136etherReaderT :: proxy tag -> (EtherData tag -> m a) -> EtherReaderT tag m a
3237etherReaderT _proxy = EtherReaderT . R.ReaderT
3338
test/Regression.hs−4
@@ -60,7 +60,3 @@ layeredLocalCore' k f a1 a2 = (direct, indirect)
6060 where
6161 direct = apply k (fromIntegral a1, apply f a2)
6262 indirect = layeredLocalCore (apply f) (\n m -> apply k (fromIntegral n, m))
63−
64−-- this should not compile
65−z :: IO Int
66−z = runAmountT (runAmountT (runAmountT askAmount 20) 10) 5