@@ -13,6 +13,7 @@ module Control.Ether.Tags
13 ( Taggable(..)
13 ( Taggable(..)
14 , Tagged(..)
14 , Tagged(..)
16 , UniqueTag
17 , UniqueTag
17 , UniqueTags
18 , UniqueTags
18 , ensureUniqueTags
19 , ensureUniqueTags
@@ -26,6 +27,7 @@ import qualified Control.Monad.ST.Lazy as Lazy (ST)
26import GHC.Conc (STM)
27import GHC.Conc (STM)
27import GHC.Exts (Constraint)
28import GHC.Exts (Constraint)
28import qualified Control.Newtype as NT
29import qualified Control.Newtype as NT
30+import Control.Ether.Util (type (++), MaybeToList)
30import qualified Control.Monad.Trans.Cont as Trans
32import qualified Control.Monad.Trans.Cont as Trans
31import qualified Control.Monad.Trans.Except as Trans
33import qualified Control.Monad.Trans.Except as Trans
@@ -66,17 +68,9 @@ type family UniqueTags (m :: * -> *) :: Constraint where
66ensureUniqueTags :: UniqueTags m => m a -> m a
68ensureUniqueTags :: UniqueTags m => m a -> m a
67ensureUniqueTags = id
69ensureUniqueTags = id
69−type family MaybeToList (mt :: Maybe k) :: [k] where
71+type family ListMapTag (as :: [* -> *]) :: [*] where
70− MaybeToList 'Nothing = '[]
72+ ListMapTag '[] = '[]
71− MaybeToList ('Just t) = '[t]
73+ ListMapTag (a ': as) = MaybeToList (Tag a) ++ ListMapTag as
73−type family MaybeMapTag (as :: Maybe (* -> *)) :: Maybe * where
74− MaybeMapTag 'Nothing = 'Nothing
75− MaybeMapTag ('Just a) = Tag a
77−type family (as :: [*]) ++ (bs :: [*]) :: [*] where
79− (a ': as) ++ bs = a ': (as ++ bs)
81-- | The 'Taggable' class defines the type families to manage tags in monad
75-- | The 'Taggable' class defines the type families to manage tags in monad
82-- transformer stacks. Its kind is restricted to @* -> *@ to prevent incorrect
76-- transformer stacks. Its kind is restricted to @* -> *@ to prevent incorrect
@@ -93,6 +87,12 @@ class Taggable (m :: * -> *) where
93 type Inner m :: Maybe (* -> *)
87 type Inner m :: Maybe (* -> *)
94 type instance Inner m = 'Nothing
88 type instance Inner m = 'Nothing
90+type family Inners' m where
91+ Inners' 'Nothing = '[]
92+ Inners' ('Just n) = n ': Inners n
94+type Inners m = Inners' (Inner m)
96instance Taggable IO
96instance Taggable IO
97instance Taggable Identity
97instance Taggable Identity
@@ -136,7 +136,9 @@ instance Taggable (Trans.Lazy.WriterT w m) where
136instance Taggable (Trans.Strict.WriterT w m) where
136instance Taggable (Trans.Strict.WriterT w m) where
137 type Inner (Trans.Strict.WriterT w m) = 'Just m
137 type Inner (Trans.Strict.WriterT w m) = 'Just m
139+-- | The 'Tags' type function returns a type-level list of all tags in
140+-- a monad transformer stack. Requires 'Taggable' instances.
139−type Tags (m :: * -> *) = MaybeToList (Tag m) ++ MaybeToList (MaybeMapTag (Inner m))
141+type Tags (m :: * -> *) = MaybeToList (Tag m) ++ ListMapTag (Inners m)
141-- | The 'Tagged' type class establishes a relationship between a tagged
143-- | The 'Tagged' type class establishes a relationship between a tagged
142-- monad transformer and its untagged counterpart.
144-- monad transformer and its untagged counterpart.
@@ -145,13 +147,9 @@ class (Taggable m, Tag m ~ 'Just tag) => Tagged m tag | m -> tag where
145 type Untagged m :: * -> *
147 type Untagged m :: * -> *
147 tagged :: proxy tag -> Untagged m a -> m a
149 tagged :: proxy tag -> Untagged m a -> m a
148− default tagged
150+ default tagged :: NT.Newtype (m a) => proxy tag -> NT.O (m a) -> m a
149− :: (NT.Newtype (m a), NT.O (m a) ~ Untagged m a)
150− => proxy tag -> Untagged m a -> m a
151 tagged _ = NT.pack
151 tagged _ = NT.pack
153 untagged :: proxy tag -> m a -> Untagged m a
153 untagged :: proxy tag -> m a -> Untagged m a
154− default untagged
154+ default untagged :: NT.Newtype (m a) => proxy tag -> m a -> NT.O (m a)
155− :: (NT.Newtype (m a), NT.O (m a) ~ Untagged m a)
156− => proxy tag -> m a -> Untagged m a
157 untagged _ = NT.unpack
155 untagged _ = NT.unpack