module Data.Functor.Trans.Tagged
(
Tagged
, TaggedT(..)
, retag
, tag, tagSelf
, untag, untagSelf
, asTaggedTypeOf
) where
import Prelude hiding (foldr, foldl, mapM, sequence, foldr1, foldl1)
import Control.Applicative
import Control.Monad (liftM, MonadPlus(..))
import Control.Monad.Fix
import Control.Monad.Trans.Class
import Control.Comonad.Trans.Class
import Control.Comonad.Hoist.Class
import Control.Comonad
import Data.Traversable (Traversable(..))
import Data.Foldable (Foldable(..))
import Data.Distributive
import Data.Functor.Bind
import Data.Functor.Plus
import Data.Functor.Identity
import Data.Functor.Contravariant
newtype TaggedT s m b = TagT { untagT :: m b }
deriving ( Eq, Ord, Read, Show )
type Tagged s = TaggedT s Identity
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 Alt m => Alt (TaggedT s m) where
TagT a <!> TagT b = TagT (a <!> b)
instance Plus m => Plus (TaggedT s m) where
zero = TagT zero
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 Alternative m => Alternative (TaggedT s m) where
empty = TagT empty
TagT a <|> TagT b = TagT (a <|> b)
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 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 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
extend f (TagT w) = TagT (extend (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
retag :: TaggedT s m b -> TaggedT t m b
retag = TagT . untagT
asTaggedTypeOf :: s -> TaggedT s m b -> s
asTaggedTypeOf = const
tag :: b -> Tagged s b
tag = TagT . Identity
untag :: Tagged s b -> b
untag = runIdentity . untagT
tagSelf :: a -> Tagged a a
tagSelf = tag
untagSelf :: Tagged a a -> a
untagSelf = untag