module Data.Functor.Trans.Tagged
(
TaggedT(..)
, tag, self, selfM, untag
, retag
, mapTaggedT
, reflected, reflectedM
, asTaggedTypeOf
) where
import Prelude hiding (foldr, foldl, mapM, sequence, foldr1, foldl1)
import Control.Applicative (Alternative(..), Applicative(..), (<$), (<$>))
import Control.Monad (liftM, MonadPlus(..))
import Control.Monad.Fix (MonadFix(..))
import Control.Monad.Trans (MonadIO(..), MonadTrans(..))
import Control.Monad.Reader (MonadReader(..))
import Control.Monad.Writer (MonadWriter(..))
import Control.Monad.State (MonadState(..))
import Control.Monad.Cont (MonadCont(..))
import Control.Comonad.Trans.Class (ComonadTrans(..))
import Control.Comonad.Hoist.Class (ComonadHoist(..))
import Control.Comonad (Comonad(..))
import Data.Traversable (Traversable(..))
import Data.Foldable (Foldable(..))
import Data.Distributive (Distributive(..))
import Data.Functor.Bind (Apply(..), Bind(..))
import Data.Functor.Extend (Extend(..))
import Data.Functor.Plus (Alt(..), Plus(..))
import Data.Functor.Identity (Identity(..))
import Data.Functor.Contravariant (Contravariant(..))
import Data.Proxy (Proxy(..))
import Data.Reflection (Reifies(..))
newtype TaggedT s m b = TagT { untagT :: m b }
deriving ( Eq, Ord, Read, Show )
instance Functor m => Functor (TaggedT s m) where
fmap f (TagT x) = TagT (fmap f x)
b <$ (TagT x) = TagT (b <$ x)
instance Contravariant m => Contravariant (TaggedT s m) where
contramap f (TagT x) = TagT (contramap f x)
instance Apply m => Apply (TaggedT s m) where
TagT f <.> TagT x = TagT (f <.> x)
TagT f .> TagT x = TagT (f .> x)
TagT f <. TagT x = TagT (f <. x)
instance Applicative m => Applicative (TaggedT s m) where
pure = TagT . pure
TagT f <*> TagT x = TagT (f <*> x)
TagT f *> TagT x = TagT (f *> x)
TagT f <* TagT x = TagT (f <* x)
instance Bind m => Bind (TaggedT s m) where
TagT m >>- k = TagT (m >>- untagT . k)
instance Monad m => Monad (TaggedT s m) where
return = TagT . return
TagT m >>= k = TagT (m >>= untagT . k)
TagT m >> TagT n = TagT (m >> n)
instance Alt m => Alt (TaggedT s m) where
TagT a <!> TagT b = TagT (a <!> b)
instance Alternative m => Alternative (TaggedT s m) where
empty = TagT empty
TagT a <|> TagT b = TagT (a <|> b)
instance Plus m => Plus (TaggedT s m) where
zero = TagT zero
instance MonadPlus m => MonadPlus (TaggedT s m) where
mzero = TagT mzero
mplus (TagT a) (TagT b) = TagT (mplus a b)
instance MonadFix m => MonadFix (TaggedT s m) where
mfix f = TagT $ mfix (untagT . f)
instance MonadTrans (TaggedT s) where
lift = TagT
instance MonadIO m => MonadIO (TaggedT s m) where
liftIO = lift . liftIO
instance MonadWriter w m => MonadWriter w (TaggedT s m) where
writer = lift . writer
tell = lift . tell
listen = lift . listen . untag
pass = lift . pass . untag
instance MonadReader r m => MonadReader r (TaggedT s m) where
ask = lift ask
local f = lift . local f . untag
reader = lift . reader
instance MonadState t m => MonadState t (TaggedT s m) where
get = lift get
put = lift . put
state = lift . state
instance MonadCont m => MonadCont (TaggedT s m) where
callCC f = lift . callCC $ \k -> untag (f (tag . k))
instance Foldable f => Foldable (TaggedT s f) where
foldMap f (TagT x) = foldMap f x
fold (TagT x) = fold x
foldr f z (TagT x) = foldr f z x
foldl f z (TagT x) = foldl f z x
foldl1 f (TagT x) = foldl1 f x
foldr1 f (TagT x) = foldr1 f x
instance Traversable f => Traversable (TaggedT s f) where
traverse f (TagT x) = TagT <$> traverse f x
sequenceA (TagT x) = TagT <$> sequenceA x
mapM f (TagT x) = liftM TagT (mapM f x)
sequence (TagT x) = liftM TagT (sequence x)
instance Distributive f => Distributive (TaggedT s f) where
distribute = TagT . distribute . fmap untagT
instance Extend f => Extend (TaggedT s f) where
extended f (TagT w) = TagT (extended (f . TagT) w)
instance Comonad w => Comonad (TaggedT s w) where
extract (TagT w) = extract w
instance ComonadTrans (TaggedT s) where
lower (TagT w) = w
instance ComonadHoist (TaggedT s) where
cohoist = TagT . Identity . extract . untagT
tag :: m b -> TaggedT s m b
tag = TagT
untag :: TaggedT s m b -> m b
untag = untagT
retag :: TaggedT s m b -> TaggedT t m b
retag = tag . untag
mapTaggedT :: (m a -> n b) -> TaggedT s m a -> TaggedT s n b
mapTaggedT f = tag . f . untag
self :: Applicative m => a -> TaggedT a m a
self = tag . pure
selfM :: Monad m => a -> TaggedT s m a
selfM = tag . return
reflected :: forall s m a. (Applicative m, Reifies s a) => TaggedT s m a
reflected = tag . pure . reflect $ (Proxy :: Proxy s)
reflectedM :: forall s m a. (Monad m, Reifies s a) => TaggedT s m a
reflectedM = tag . return . reflect $ (Proxy :: Proxy s)
asTaggedTypeOf :: s -> TaggedT s m b -> s
asTaggedTypeOf = const