git.iko.soy/typeable/ether
on master help sign in
Separate tag uniqueness constraint
dabd659Index Int
src/Control/Ether/Core.hs+8−4
compare with master
unifiedsplit
@@ -5,8 +5,9 @@
5{-# LANGUAGE TypeOperators #-}
5{-# LANGUAGE TypeOperators #-}
6{-# LANGUAGE UndecidableInstances #-}
6{-# LANGUAGE UndecidableInstances #-}
7module Control.Ether.Core
7module Control.Ether.Core
8− ( EtherTagset
9− , EtherTags
8+ ( EtherTags
9+ , UniqueEtherTags
10+ , ensureUniqueEtherTags
10 ) where
11 ) where
11
12
12import Data.Proxy (Proxy)
13import Data.Proxy (Proxy)
@@ -37,8 +38,11 @@ type family Unique (as :: [k]) :: Constraint where
37 Unique '[] = ()
38 Unique '[] = ()
38 Unique (a ': as) = (Elem a as ~ 'False, Unique as)
39 Unique (a ': as) = (Elem a as ~ 'False, Unique as)
39
40
40−type family EtherTagset (m :: * -> *) :: Constraint where
41+type family UniqueEtherTags (m :: * -> *) :: Constraint where
41− EtherTagset m = Unique (EtherTags m)
42+ UniqueEtherTags m = Unique (EtherTags m)
43+
44+ensureUniqueEtherTags :: UniqueEtherTags m => m a -> m a
45+ensureUniqueEtherTags = id
42
46
43type family EtherTags (m :: * -> *) :: [*]
47type family EtherTags (m :: * -> *) :: [*]
44
48
src/Control/Monad/Ether/Reader.hs+3−6
@@ -34,7 +34,6 @@ module Control.Monad.Ether.Reader
34import Data.Proxy (Proxy(Proxy))
34import Data.Proxy (Proxy(Proxy))
35import Control.Monad.Trans (lift)
35import Control.Monad.Trans (lift)
36
36
37−import Control.Ether.Core
38import Control.Monad.Trans.Ether.Reader
37import Control.Monad.Trans.Ether.Reader
39
38
40-- for mtl instances
39-- for mtl instances
@@ -49,7 +48,7 @@ import qualified Control.Monad.Trans.State.Strict as Trans.Strict (StateT , m
49import qualified Control.Monad.Trans.Writer.Lazy as Trans.Lazy (WriterT , mapWriterT)
48import qualified Control.Monad.Trans.Writer.Lazy as Trans.Lazy (WriterT , mapWriterT)
50import qualified Control.Monad.Trans.Writer.Strict as Trans.Strict (WriterT , mapWriterT)
49import qualified Control.Monad.Trans.Writer.Strict as Trans.Strict (WriterT , mapWriterT)
51
50
52−class (Monad m, EtherTagset m) => MonadEtherReader tag r m | m tag -> r where
51+class Monad m => MonadEtherReader tag r m | m tag -> r where
53
52
54 etherLocal :: proxy tag -> (r -> r) -> m a -> m a
53 etherLocal :: proxy tag -> (r -> r) -> m a -> m a
55
54
@@ -70,13 +69,11 @@ ask' = etherAsk (Proxy :: Proxy r)
70reader' :: forall m r a . MonadReader' r m => (r -> a) -> m a
69reader' :: forall m r a . MonadReader' r m => (r -> a) -> m a
71reader' = etherReader (Proxy :: Proxy r)
70reader' = etherReader (Proxy :: Proxy r)
72
71
73−instance {-# OVERLAPPING #-} (Monad m, EtherTagset (EtherReaderT tag r m))
74− => MonadEtherReader tag r (EtherReaderT tag r m) where
72+instance {-# OVERLAPPING #-} Monad m => MonadEtherReader tag r (EtherReaderT tag r m) where
75 etherAsk proxy = etherReaderT proxy return
73 etherAsk proxy = etherReaderT proxy return
76 etherLocal proxy f m = etherReaderT proxy (runEtherReaderT proxy m . f)
74 etherLocal proxy f m = etherReaderT proxy (runEtherReaderT proxy m . f)
77
75
78−instance (MonadEtherReader tag r m, EtherTagset (EtherReaderT tag' r' m))
79− => MonadEtherReader tag r (EtherReaderT tag' r' m) where
76+instance (MonadEtherReader tag r m) => MonadEtherReader tag r (EtherReaderT tag' r' m) where
80 etherAsk proxy = lift (etherAsk proxy)
77 etherAsk proxy = lift (etherAsk proxy)
81 etherLocal proxy = mapEtherReaderT Proxy . etherLocal proxy
78 etherLocal proxy = mapEtherReaderT Proxy . etherLocal proxy
82
79
test/Regression.hs+17
@@ -75,3 +75,20 @@ inferCore = local' (succ :: Int -> Int) $ do
75
75
76wrapCore :: MonadEtherReader TagReader1 Int m => m Int
76wrapCore :: MonadEtherReader TagReader1 Int m => m Int
77wrapCore = ethered r1 ask
77wrapCore = ethered r1 ask
78+
79+
80+-- Should not compile with `ensureUniqueEtherTags`
81+uniqueTagsCore :: IO ()
82+uniqueTagsCore = flip runReader1T (1 :: Int)
83+ . flip runReader1T (True :: Bool)
84+ . flip runReader1T (2 :: Int)
85+ . flip runReader1T (3 :: Integer)
86+ {- . ensureUniqueEtherTags -}
87+ $ do
88+ a :: Integer <- askReader1
89+ b :: Int <- askReader1
90+ c :: Bool <- askReader1
91+ liftIO $ do
92+ print a
93+ print b
94+ print c