@@ -13,6 +13,7 @@ module Control.Ether.Tags
1313 ( Taggable(..)
1414 , Tagged(..)
1515 , Tags
16+ , Inners
1617 , UniqueTag
1718 , UniqueTags
1819 , ensureUniqueTags
@@ -26,6 +27,7 @@ import qualified Control.Monad.ST.Lazy as Lazy (ST)
2627import GHC.Conc (STM)
2728import GHC.Exts (Constraint)
2829import qualified Control.Newtype as NT
30+import Control.Ether.Util (type (++), MaybeToList)
2931
3032import qualified Control.Monad.Trans.Cont as Trans
3133import qualified Control.Monad.Trans.Except as Trans
@@ -66,17 +68,9 @@ type family UniqueTags (m :: * -> *) :: Constraint where
6668ensureUniqueTags :: UniqueTags m => m a -> m a
6769ensureUniqueTags = id
6870
69−type family MaybeToList (mt :: Maybe k) :: [k] where
70− MaybeToList 'Nothing = '[]
71− MaybeToList ('Just t) = '[t]
72−
73−type family MaybeMapTag (as :: Maybe (* -> *)) :: Maybe * where
74− MaybeMapTag 'Nothing = 'Nothing
75− MaybeMapTag ('Just a) = Tag a
76−
77−type family (as :: [*]) ++ (bs :: [*]) :: [*] where
78− '[] ++ bs = bs
79− (a ': as) ++ bs = a ': (as ++ bs)
71+type family ListMapTag (as :: [* -> *]) :: [*] where
72+ ListMapTag '[] = '[]
73+ ListMapTag (a ': as) = MaybeToList (Tag a) ++ ListMapTag as
8074
8175-- | The 'Taggable' class defines the type families to manage tags in monad
8276-- transformer stacks. Its kind is restricted to @* -> *@ to prevent incorrect
@@ -93,6 +87,12 @@ class Taggable (m :: * -> *) where
9387 type Inner m :: Maybe (* -> *)
9488 type instance Inner m = 'Nothing
9589
90+type family Inners' m where
91+ Inners' 'Nothing = '[]
92+ Inners' ('Just n) = n ': Inners n
93+
94+type Inners m = Inners' (Inner m)
95+
9696instance Taggable IO
9797instance Taggable Identity
9898
@@ -136,7 +136,9 @@ instance Taggable (Trans.Lazy.WriterT w m) where
136136instance Taggable (Trans.Strict.WriterT w m) where
137137 type Inner (Trans.Strict.WriterT w m) = 'Just m
138138
139−type Tags (m :: * -> *) = MaybeToList (Tag m) ++ MaybeToList (MaybeMapTag (Inner m))
139+-- | The 'Tags' type function returns a type-level list of all tags in
140+-- a monad transformer stack. Requires 'Taggable' instances.
141+type Tags (m :: * -> *) = MaybeToList (Tag m) ++ ListMapTag (Inners m)
140142
141143-- | The 'Tagged' type class establishes a relationship between a tagged
142144-- monad transformer and its untagged counterpart.
@@ -145,13 +147,9 @@ class (Taggable m, Tag m ~ 'Just tag) => Tagged m tag | m -> tag where
145147 type Untagged m :: * -> *
146148
147149 tagged :: proxy tag -> Untagged m a -> m a
148− default tagged
149− :: (NT.Newtype (m a), NT.O (m a) ~ Untagged m a)
150− => proxy tag -> Untagged m a -> m a
150+ default tagged :: NT.Newtype (m a) => proxy tag -> NT.O (m a) -> m a
151151 tagged _ = NT.pack
152152
153153 untagged :: proxy tag -> m a -> Untagged m a
154− default untagged
155− :: (NT.Newtype (m a), NT.O (m a) ~ Untagged m a)
156− => proxy tag -> m a -> Untagged m a
154+ default untagged :: NT.Newtype (m a) => proxy tag -> m a -> NT.O (m a)
157155 untagged _ = NT.unpack