module Control.Ether.Tagged
( Taggable(..)
, Tagged(..)
, Tags
, Inners
, UniqueTag
, UniqueTags
, ensureUniqueTags
) where
import Data.Proxy (Proxy)
import Data.Functor.Identity (Identity)
import Data.Monoid (First, Last)
import qualified Control.Monad.ST.Strict as Strict (ST)
import qualified Control.Monad.ST.Lazy as Lazy (ST)
import GHC.Conc (STM)
import GHC.Exts (Constraint)
import qualified Control.Newtype as NT
import Control.Ether.Util (type (++), MaybeToList)
import qualified Control.Monad.Trans.Cont as Trans
import qualified Control.Monad.Trans.Except as Trans
import qualified Control.Monad.Trans.Identity as Trans
import qualified Control.Monad.Trans.List as Trans
import qualified Control.Monad.Trans.Maybe as Trans
import qualified Control.Monad.Trans.Reader as Trans
import qualified Control.Monad.Trans.State.Lazy as Trans.Lazy
import qualified Control.Monad.Trans.State.Strict as Trans.Strict
import qualified Control.Monad.Trans.Writer.Lazy as Trans.Lazy
import qualified Control.Monad.Trans.Writer.Strict as Trans.Strict
class UniqueTag a
type family IsUnique (x :: k) (as :: [k]) :: Constraint where
IsUnique x (x ': as) = UniqueTag x
IsUnique x (a ': as) = IsUnique x as
IsUnique x '[] = ()
type family Unique (as :: [k]) :: Constraint where
Unique '[] = ()
Unique (a ': as) = (IsUnique a as, Unique as)
type family UniqueTags (m :: * -> *) :: Constraint where
UniqueTags m = Unique (Tags m)
ensureUniqueTags :: UniqueTags m => m a -> m a
ensureUniqueTags = id
type family ListMapTag (as :: [* -> *]) :: [*] where
ListMapTag '[] = '[]
ListMapTag (a ': as) = MaybeToList (Tag a) ++ ListMapTag as
class Taggable (m :: * -> *) where
type Tag m :: Maybe *
type instance Tag m = 'Nothing
type Inner m :: Maybe (* -> *)
type instance Inner m = 'Nothing
type family Inners' m where
Inners' 'Nothing = '[]
Inners' ('Just n) = n ': Inners n
type Inners m = Inners' (Inner m)
instance Taggable IO
instance Taggable Identity
instance Taggable Maybe
instance Taggable Last
instance Taggable First
instance Taggable ((->) r)
instance Taggable STM
instance Taggable (Either e)
instance Taggable Proxy
instance Taggable (Strict.ST s)
instance Taggable (Lazy.ST s)
instance Taggable (Trans.ContT r m) where
type Inner (Trans.ContT r m) = 'Just m
instance Taggable (Trans.ExceptT e m) where
type Inner (Trans.ExceptT e m) = 'Just m
instance Taggable (Trans.IdentityT m) where
type Inner (Trans.IdentityT m) = 'Just m
instance Taggable (Trans.ListT m) where
type Inner (Trans.ListT m) = 'Just m
instance Taggable (Trans.MaybeT m) where
type Inner (Trans.MaybeT m) = 'Just m
instance Taggable (Trans.ReaderT r m) where
type Inner (Trans.ReaderT r m) = 'Just m
instance Taggable (Trans.Lazy.StateT s m) where
type Inner (Trans.Lazy.StateT s m) = 'Just m
instance Taggable (Trans.Strict.StateT s m) where
type Inner (Trans.Strict.StateT s m) = 'Just m
instance Taggable (Trans.Lazy.WriterT w m) where
type Inner (Trans.Lazy.WriterT w m) = 'Just m
instance Taggable (Trans.Strict.WriterT w m) where
type Inner (Trans.Strict.WriterT w m) = 'Just m
type Tags (m :: * -> *) = MaybeToList (Tag m) ++ ListMapTag (Inners m)
class (Taggable m, Tag m ~ 'Just tag) => Tagged m tag | m -> tag where
type Untagged m :: * -> *
tagged :: proxy tag -> Untagged m a -> m a
default tagged :: NT.Newtype (m a) => proxy tag -> NT.O (m a) -> m a
tagged _ = NT.pack
untagged :: proxy tag -> m a -> Untagged m a
default untagged :: NT.Newtype (m a) => proxy tag -> m a -> NT.O (m a)
untagged _ = NT.unpack