module Control.Monad.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 Data.Traversable (Traversable(..))
import Data.Foldable (Foldable(..))
import Data.Functor.Identity
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 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 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 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)
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