@@ -1,150 +0,0 @@
1−{-# LANGUAGE TypeFamilies #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE PolyKinds #-}
4−{-# LANGUAGE ConstraintKinds #-}
5−{-# LANGUAGE TypeOperators #-}
6−{-# LANGUAGE FlexibleInstances #-}
7−{-# LANGUAGE UndecidableInstances #-}
8−{-# LANGUAGE MultiParamTypeClasses #-}
9−{-# LANGUAGE FunctionalDependencies #-}
11−-- | Type-level machinery for tag manipulation.
13−module Control.Ether.Tagged
23−import Data.Proxy (Proxy)
24−import Data.Functor.Identity (Identity)
25−import Data.Monoid (First, Last)
26−import qualified Control.Monad.ST.Strict as Strict (ST)
27−import qualified Control.Monad.ST.Lazy as Lazy (ST)
29−import GHC.Exts (Constraint)
30−import Control.Ether.Util (type (++), MaybeToList)
32−import qualified Control.Monad.Trans.Cont as Trans
33−import qualified Control.Monad.Trans.Except as Trans
34−import qualified Control.Monad.Trans.Identity as Trans
35−import qualified Control.Monad.Trans.List as Trans
36−import qualified Control.Monad.Trans.Maybe as Trans
37−import qualified Control.Monad.Trans.Reader as Trans
38−import qualified Control.Monad.Trans.State.Lazy as Trans.Lazy
39−import qualified Control.Monad.Trans.State.Strict as Trans.Strict
40−import qualified Control.Monad.Trans.Writer.Lazy as Trans.Lazy
41−import qualified Control.Monad.Trans.Writer.Strict as Trans.Strict
44−-- The main purpose of the 'UniqueTag' class is to provide clear error
45−-- messages when the tag uniqueness property is violated. You should never
46−-- write instances for it unless you know what you're doing.
49−type family IsUnique (x :: k) (as :: [k]) :: Constraint where
50− IsUnique x (x ': as) = (UniqueTag x, IsUnique x as)
51− IsUnique x (a ': as) = IsUnique x as
54−type family Unique (as :: [k]) :: Constraint where
56− Unique (a ': as) = (IsUnique a as, Unique as)
59−-- The 'UniqueTags` constraint placed on a type variable representing a
60−-- monad transformer stack ensures that every tag in the stack appears
62−type family UniqueTags (m :: * -> *) :: Constraint where
63− UniqueTags m = Unique (Tags m)
66−-- Type-restricted version of 'id' that adds a 'UniqueTags' constraint to
67−-- the provided monadic value.
68−ensureUniqueTags :: UniqueTags m => m a -> m a
71−type family ListMapTag (as :: [* -> *]) :: [*] where
73− ListMapTag (a ': as) = MaybeToList (Tag a) ++ ListMapTag as
75−-- | The 'Taggable' class defines the type families to manage tags in monad
76−-- transformer stacks. Its kind is restricted to @* -> *@ to prevent incorrect
78−class Taggable (m :: * -> *) where
80− -- | The 'Tag' type family equals @Nothing@ for most types, but for tagged
81− -- monad transformers it equals @Just tag@.
82− type Tag m :: Maybe k
83− type instance Tag m = 'Nothing
85− -- | The 'Inner' type family equals @Nothing@ for most types, but for
86− -- monad transformers with inner monad @m@ it equals @Just m@.
87− type Inner m :: Maybe (* -> *)
88− type instance Inner m = 'Nothing
90−type family Inners' m where
91− Inners' 'Nothing = '[]
92− Inners' ('Just n) = n ': Inners n
94−-- | The 'Inners' type function recursively applies 'Inner' and returns the
95−-- results in a type-level list.
96−type Inners m = Inners' (Inner m)
99−instance Taggable Identity
101−instance Taggable Maybe
102−instance Taggable Last
103−instance Taggable First
104−instance Taggable ((->) r)
105−instance Taggable STM
106−instance Taggable (Either e)
107−instance Taggable Proxy
108−instance Taggable (Strict.ST s)
109−instance Taggable (Lazy.ST s)
111−instance Taggable (Trans.ContT r m) where
112− type Inner (Trans.ContT r m) = 'Just m
114−instance Taggable (Trans.ExceptT e m) where
115− type Inner (Trans.ExceptT e m) = 'Just m
117−instance Taggable (Trans.IdentityT m) where
118− type Inner (Trans.IdentityT m) = 'Just m
120−instance Taggable (Trans.ListT m) where
121− type Inner (Trans.ListT m) = 'Just m
123−instance Taggable (Trans.MaybeT m) where
124− type Inner (Trans.MaybeT m) = 'Just m
126−instance Taggable (Trans.ReaderT r m) where
127− type Inner (Trans.ReaderT r m) = 'Just m
129−instance Taggable (Trans.Lazy.StateT s m) where
130− type Inner (Trans.Lazy.StateT s m) = 'Just m
132−instance Taggable (Trans.Strict.StateT s m) where
133− type Inner (Trans.Strict.StateT s m) = 'Just m
135−instance Taggable (Trans.Lazy.WriterT w m) where
136− type Inner (Trans.Lazy.WriterT w m) = 'Just m
138−instance Taggable (Trans.Strict.WriterT w m) where
139− type Inner (Trans.Strict.WriterT w m) = 'Just m
141−-- | The 'Tags' type function returns a type-level list of all tags in
142−-- a monad transformer stack. Requires 'Taggable' instances.
143−type Tags (m :: * -> *) = MaybeToList (Tag m) ++ ListMapTag (Inners m)
145−-- | The 'Tagged' type class establishes a relationship between a tagged
146−-- monad transformer and its untagged counterpart.
147−class (Taggable m, Tag m ~ 'Just tag) => Tagged m tag | m -> tag where
148− type Untagged m :: * -> *
149− tagged :: proxy tag -> Untagged m a -> m a
150− untagged :: proxy tag -> m a -> Untagged m a