module Data.Functor.Yoneda.Contravariant
( Yoneda
, yoneda
, liftYoneda
, lowerYoneda
, liftYonedaT
, lowerYonedaT
, lowerM
, YonedaT(..)
) where
import Control.Applicative
import Control.Monad (MonadPlus(..), liftM)
import Control.Monad.Fix
import Control.Monad.Representable
import Control.Monad.Trans.Class
import Control.Comonad
import Control.Comonad.Trans.Class
import Data.Distributive
import Data.Function (on)
import Data.Functor.Bind
import Data.Functor.Plus
import Data.Functor.Identity
import Data.Functor.Adjunction
import Data.Key
import Prelude hiding (sequence)
import Text.Read hiding (lift)
type Yoneda = YonedaT Identity
data YonedaT f a where
YonedaT :: (b -> a) -> f b -> YonedaT f a
yoneda :: (b -> a) -> b -> Yoneda a
yoneda f = YonedaT f . Identity
liftYoneda :: a -> Yoneda a
liftYoneda = YonedaT id . Identity
lowerYoneda :: Yoneda a -> a
lowerYoneda (YonedaT f (Identity a)) = f a
liftYonedaT :: f a -> YonedaT f a
liftYonedaT = YonedaT id
lowerYonedaT :: Functor f => YonedaT f a -> f a
lowerYonedaT (YonedaT f m) = fmap f m
lowerM :: Monad f => YonedaT f a -> f a
lowerM (YonedaT f m) = liftM f m
instance Functor (YonedaT f) where
fmap f (YonedaT g v) = YonedaT (f . g) v
type instance Key (YonedaT f) = Key f
instance Keyed f => Keyed (YonedaT f) where
mapWithKey f (YonedaT k a) = YonedaT id $ mapWithKey (\x -> f x . k) a
instance Apply f => Apply (YonedaT f) where
m <.> n = liftYonedaT $ lowerYonedaT m <.> lowerYonedaT n
instance Applicative f => Applicative (YonedaT f) where
pure = liftYonedaT . pure
m <*> n = liftYonedaT $ lowerYonedaT m <*> lowerYonedaT n
instance Alternative f => Alternative (YonedaT f) where
empty = liftYonedaT empty
m <|> n = liftYonedaT $ lowerYonedaT m <|> lowerYonedaT n
instance Alt f => Alt (YonedaT f) where
m <!> n = liftYonedaT $ lowerYonedaT m <!> lowerYonedaT n
instance Plus f => Plus (YonedaT f) where
zero = liftYonedaT zero
instance Bind m => Bind (YonedaT m) where
YonedaT f v >>- k = liftYonedaT (v >>- lowerYonedaT . k . f)
instance Monad m => Monad (YonedaT m) where
return = YonedaT id . return
YonedaT f v >>= k = lift (v >>= lowerM . k . f)
instance MonadTrans YonedaT where
lift = YonedaT id
instance MonadFix f => MonadFix (YonedaT f) where
mfix f = lift $ mfix (lowerM . f)
instance MonadPlus f => MonadPlus (YonedaT f) where
mzero = lift mzero
m `mplus` n = lift $ lowerM m `mplus` lowerM n
instance (Functor f, Indexable f) => Indexable (YonedaT f) where
index = index . lowerYonedaT
instance Representable f => Representable (YonedaT f) where
tabulate = liftYonedaT . tabulate
instance Extend w => Extend (YonedaT w) where
extend k (YonedaT f v) = YonedaT id $ extend (k . YonedaT f) v
instance Comonad w => Comonad (YonedaT w) where
extract (YonedaT f v) = f (extract v)
instance ComonadTrans YonedaT where
lower (YonedaT f a) = fmap f a
instance Foldable f => Foldable (YonedaT f) where
foldMap f (YonedaT k a) = foldMap (f . k) a
instance FoldableWithKey f => FoldableWithKey (YonedaT f) where
foldMapWithKey f (YonedaT k a) = foldMapWithKey (\x -> f x . k) a
instance Foldable1 f => Foldable1 (YonedaT f) where
foldMap1 f (YonedaT k a) = foldMap1 (f . k) a
instance FoldableWithKey1 f => FoldableWithKey1 (YonedaT f) where
foldMapWithKey1 f (YonedaT k a) = foldMapWithKey1 (\x -> f x . k) a
instance Traversable f => Traversable (YonedaT f) where
traverse f (YonedaT k a) = YonedaT id <$> traverse (f . k) a
instance Traversable1 f => Traversable1 (YonedaT f) where
traverse1 f (YonedaT k a) = YonedaT id <$> traverse1 (f . k) a
instance TraversableWithKey f => TraversableWithKey (YonedaT f) where
traverseWithKey f (YonedaT k a) = YonedaT id <$> traverseWithKey (\x -> f x . k) a
instance TraversableWithKey1 f => TraversableWithKey1 (YonedaT f) where
traverseWithKey1 f (YonedaT k a) = YonedaT id <$> traverseWithKey1 (\x -> f x . k) a
instance Distributive f => Distributive (YonedaT f) where
collect f = liftYonedaT . collect (lowerYonedaT . f)
instance (Functor f, Show (f a)) => Show (YonedaT f a) where
showsPrec d (YonedaT f a) = showParen (d > 10) $
showString "liftYonedaT " . showsPrec 11 (fmap f a)
#ifdef __GLASGOW_HASKELL__
instance (Functor f, Read (f a)) => Read (YonedaT f a) where
readPrec = parens $ prec 10 $ do
Ident "liftYonedaT" <- lexP
liftYonedaT <$> step readPrec
#endif
instance (Functor f, Eq (f a)) => Eq (YonedaT f a) where
(==) = (==) `on` lowerYonedaT
instance (Functor f, Ord (f a)) => Ord (YonedaT f a) where
compare = compare `on` lowerYonedaT
instance Adjunction f g => Adjunction (YonedaT f) (YonedaT g) where
unit = liftYonedaT . fmap liftYonedaT . unit
counit = counit . fmap lowerYonedaT . lowerYonedaT