module Control.Comonad (
Functor(..)
, (<$>)
, ( $>)
, Comonad(..)
, (=>=)
, (=<=)
, (=>>)
, (<<=)
, liftW
, wfix
, FunctorApply(..)
, (<..>)
, liftF2
, liftF3
, ComonadApply
, liftW2
, liftW3
, Cokleisli(..)
, WrappedApplicative(..)
, WrappedApply(..)
) where
import Prelude hiding (id, (.))
import Control.Applicative
import Control.Arrow
import Control.Category
import Control.Monad.Trans.Identity
import Data.Functor
import Data.Functor.Identity
import Data.Monoid
infixl 1 =>>
infixr 1 <<=, =<=, =>=
infixl 4 <.>, <., .>, <..>, $>
($>) :: Functor f => f a -> b -> f b
($>) = flip (<$)
class Functor w => Comonad w where
extract :: w a -> a
duplicate :: w a -> w (w a)
extend :: (w a -> b) -> w a -> w b
extend f = fmap f . duplicate
duplicate = extend id
liftW :: Comonad w => (a -> b) -> w a -> w b
liftW f = extend (f . extract)
(=>>) :: Comonad w => w a -> (w a -> b) -> w b
(=>>) = flip extend
(<<=) :: Comonad w => (w a -> b) -> w a -> w b
(<<=) = extend
(=<=) :: Comonad w => (w b -> c) -> (w a -> b) -> w a -> c
f =<= g = f . extend g
(=>=) :: Comonad w => (w a -> b) -> (w b -> c) -> w a -> c
f =>= g = g . extend f
wfix :: Comonad w => w (w a -> a) -> a
wfix w = extract w (extend wfix w)
instance Comonad ((,)e) where
extract = snd
duplicate ~(e,a) = (e,(e,a))
instance Monoid m => Comonad ((->)m) where
extract f = f mempty
duplicate f m = f . mappend m
instance Comonad Identity where
extract = runIdentity
extend f = Identity . f
duplicate = Identity
instance Comonad w => Comonad (IdentityT w) where
extract = extract . runIdentityT
extend f (IdentityT m) = IdentityT (extend (f . IdentityT) m)
class Functor f => FunctorApply f where
(<.>) :: f (a -> b) -> f a -> f b
(.>) :: f a -> f b -> f b
a .> b = const id <$> a <.> b
(<.) :: f a -> f b -> f a
a <. b = const <$> a <.> b
instance Monoid m => FunctorApply ((,)m) where
(<.>) = (<*>)
(<. ) = (<* )
( .>) = ( *>)
instance Monoid m => FunctorApply ((->)m) where
(<.>) = (<*>)
(<. ) = (<* )
( .>) = ( *>)
instance FunctorApply ZipList where
(<.>) = (<*>)
(<. ) = (<* )
( .>) = ( *>)
instance FunctorApply [] where
(<.>) = (<*>)
(<. ) = (<* )
( .>) = ( *>)
instance FunctorApply IO where
(<.>) = (<*>)
(<. ) = (<* )
( .>) = ( *>)
instance FunctorApply Maybe where
(<.>) = (<*>)
(<. ) = (<* )
( .>) = ( *>)
instance FunctorApply Identity where
(<.>) = (<*>)
(<. ) = (<* )
( .>) = ( *>)
instance FunctorApply w => FunctorApply (IdentityT w) where
IdentityT wa <.> IdentityT wb = IdentityT (wa <.> wb)
instance Monad m => FunctorApply (WrappedMonad m) where
(<.>) = (<*>)
(<. ) = (<* )
( .>) = ( *>)
instance Monoid m => FunctorApply (Const m) where
(<.>) = (<*>)
(<. ) = (<* )
( .>) = ( *>)
instance Arrow a => FunctorApply (WrappedArrow a b) where
(<.>) = (<*>)
(<. ) = (<* )
( .>) = ( *>)
newtype WrappedApplicative f a = WrappedApplicative { unwrapApplicative :: f a }
instance Functor f => Functor (WrappedApplicative f) where
fmap f (WrappedApplicative a) = WrappedApplicative (f <$> a)
instance Applicative f => FunctorApply (WrappedApplicative f) where
WrappedApplicative f <.> WrappedApplicative a = WrappedApplicative (f <*> a)
WrappedApplicative a <. WrappedApplicative b = WrappedApplicative (a <* b)
WrappedApplicative a .> WrappedApplicative b = WrappedApplicative (a *> b)
instance Applicative f => Applicative (WrappedApplicative f) where
pure = WrappedApplicative . pure
WrappedApplicative f <*> WrappedApplicative a = WrappedApplicative (f <*> a)
WrappedApplicative a <* WrappedApplicative b = WrappedApplicative (a <* b)
WrappedApplicative a *> WrappedApplicative b = WrappedApplicative (a *> b)
newtype WrappedApply f a = WrapApply { unwrapApply :: Either (f a) a }
instance Functor f => Functor (WrappedApply f) where
fmap f (WrapApply (Right a)) = WrapApply (Right (f a ))
fmap f (WrapApply (Left fa)) = WrapApply (Left (f <$> fa))
instance FunctorApply f => FunctorApply (WrappedApply f) where
WrapApply (Right f) <.> WrapApply (Right a) = WrapApply (Right (f a ))
WrapApply (Right f) <.> WrapApply (Left fa) = WrapApply (Left (f <$> fa))
WrapApply (Left ff) <.> WrapApply (Right a) = WrapApply (Left (($a) <$> ff))
WrapApply (Left ff) <.> WrapApply (Left fa) = WrapApply (Left (ff <.> fa))
WrapApply a <. WrapApply (Right _) = WrapApply a
WrapApply (Right a) <. WrapApply (Left fb) = WrapApply (Left (a <$ fb))
WrapApply (Left fa) <. WrapApply (Left fb) = WrapApply (Left (fa <. fb))
WrapApply (Right _) .> WrapApply b = WrapApply b
WrapApply (Left fa) .> WrapApply (Right b) = WrapApply (Left (fa $> b ))
WrapApply (Left fa) .> WrapApply (Left fb) = WrapApply (Left (fa .> fb))
instance FunctorApply f => Applicative (WrappedApply f) where
pure a = WrapApply (Right a)
(<*>) = (<.>)
(<* ) = (<. )
( *>) = ( .>)
instance Comonad f => Comonad (WrappedApply f) where
extract (WrapApply (Right a)) = a
extract (WrapApply (Left fa)) = extract fa
duplicate w@(WrapApply Right{}) = WrapApply (Right w)
duplicate (WrapApply (Left fa)) = WrapApply (Left (extend (WrapApply . Left) fa))
instance ComonadApply f => ComonadApply (WrappedApply f)
(<..>) :: FunctorApply w => w a -> w (a -> b) -> w b
(<..>) = liftF2 (flip id)
liftF2 :: FunctorApply w => (a -> b -> c) -> w a -> w b -> w c
liftF2 f a b = f <$> a <.> b
liftF3 :: FunctorApply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d
liftF3 f a b c = f <$> a <.> b <.> c
class (Comonad w, FunctorApply w) => ComonadApply w
instance Monoid m => ComonadApply ((,)m)
instance Monoid m => ComonadApply ((->)m)
instance ComonadApply Identity
instance ComonadApply w => ComonadApply (IdentityT w)
liftW2 :: ComonadApply w => (a -> b -> c) -> w a -> w b -> w c
liftW2 = liftF2
liftW3 :: ComonadApply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d
liftW3 = liftF3
newtype Cokleisli w a b = Cokleisli { runCokleisli :: w a -> b }
instance Comonad w => Category (Cokleisli w) where
id = Cokleisli extract
Cokleisli f . Cokleisli g = Cokleisli (f =<= g)
instance Comonad w => Arrow (Cokleisli w) where
arr f = Cokleisli (f . extract)
first f = f *** id
second f = id *** f
Cokleisli f *** Cokleisli g = Cokleisli (f . fmap fst &&& g . fmap snd)
Cokleisli f &&& Cokleisli g = Cokleisli (f &&& g)
instance Comonad w => ArrowApply (Cokleisli w) where
app = Cokleisli $ \w -> runCokleisli (fst (extract w)) (snd <$> w)
instance Comonad w => ArrowChoice (Cokleisli w) where
left = leftApp
instance ComonadApply w => ArrowLoop (Cokleisli w) where
loop (Cokleisli f) = Cokleisli (fst . wfix . extend f') where
f' wa wb = f ((,) <$> wa <.> (snd <$> wb))
instance Functor (Cokleisli w a) where
fmap f (Cokleisli g) = Cokleisli (f . g)
instance FunctorApply (Cokleisli w a) where
Cokleisli f <.> Cokleisli a = Cokleisli (\w -> (f w) (a w))
instance Applicative (Cokleisli w a) where
pure = Cokleisli . const
Cokleisli f <*> Cokleisli a = Cokleisli (\w -> (f w) (a w))
instance Monad (Cokleisli w a) where
return = Cokleisli . const
Cokleisli k >>= f = Cokleisli $ \w -> runCokleisli (f (k w)) w