{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 707
{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, Safe, DefaultSignatures #-}
#elif __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy, DefaultSignatures #-}
#endif
#if __GLASGOW_HASKELL__ >= 706
{-# LANGUAGE PolyKinds #-}
#endif
module Control.Comonad (
Comonad(..)
, liftW
, wfix
, cfix
, kfix
, (=>=)
, (=<=)
, (<<=)
, (=>>)
, ComonadApply(..)
, (<@@>)
, liftW2
, liftW3
, Cokleisli(..)
, Functor(..)
, (<$>)
, ($>)
) where
import Data.Functor
import Control.Applicative
import Control.Arrow
import Control.Category
import Control.Monad (ap)
#if MIN_VERSION_base(4,7,0)
#else
import Control.Monad.Instances
#endif
import Control.Monad.Trans.Identity
import Data.Functor.Identity
import qualified Data.Functor.Sum as FSum
import Data.List.NonEmpty hiding (map)
import Data.Semigroup hiding (Product)
import Data.Tagged
import Prelude hiding (id, (.))
import Control.Monad.Fix
import Data.Typeable
#ifdef MIN_VERSION_containers
import Data.Tree
#endif
infixl 4 <@, @>, <@@>, <@>
infixl 1 =>>
infixr 1 <<=, =<=, =>=
class Functor w => Comonad w where
extract :: w a -> a
duplicate :: w a -> w (w a)
duplicate = extend id
extend :: (w a -> b) -> w a -> w b
extend f = fmap f . duplicate
#if __GLASGOW_HASKELL__ >= 708
{-# MINIMAL extract, (duplicate | extend) #-}
#endif
instance Comonad ((,)e) where
duplicate p = (fst p, p)
{-# INLINE duplicate #-}
extract = snd
{-# INLINE extract #-}
instance Comonad (Arg e) where
duplicate w@(Arg a _) = Arg a w
{-# INLINE duplicate #-}
extend f w@(Arg a _) = Arg a (f w)
{-# INLINE extend #-}
extract (Arg _ b) = b
{-# INLINE extract #-}
instance Monoid m => Comonad ((->)m) where
duplicate f m = f . mappend m
{-# INLINE duplicate #-}
extract f = f mempty
{-# INLINE extract #-}
instance Comonad Identity where
duplicate = Identity
{-# INLINE duplicate #-}
extract = runIdentity
{-# INLINE extract #-}
#if __GLASGOW_HASKELL__ >= 706
#endif
instance Comonad (Tagged s) where
duplicate = Tagged
{-# INLINE duplicate #-}
extract = unTagged
{-# INLINE extract #-}
instance Comonad w => Comonad (IdentityT w) where
extend f (IdentityT m) = IdentityT (extend (f . IdentityT) m)
extract = extract . runIdentityT
{-# INLINE extract #-}
#ifdef MIN_VERSION_containers
instance Comonad Tree where
duplicate w@(Node _ as) = Node w (map duplicate as)
extract (Node a _) = a
{-# INLINE extract #-}
#endif
instance Comonad NonEmpty where
extend f w@ ~(_ :| aas) = f w :| case aas of
[] -> []
(a:as) -> toList (extend f (a :| as))
extract ~(a :| _) = a
{-# INLINE extract #-}
coproduct :: (f a -> b) -> (g a -> b) -> FSum.Sum f g a -> b
coproduct f _ (FSum.InL x) = f x
coproduct _ g (FSum.InR y) = g y
{-# INLINE coproduct #-}
instance (Comonad f, Comonad g) => Comonad (FSum.Sum f g) where
extend f = coproduct
(FSum.InL . extend (f . FSum.InL))
(FSum.InR . extend (f . FSum.InR))
extract = coproduct extract extract
{-# INLINE extract #-}
class Comonad w => ComonadApply w where
(<@>) :: w (a -> b) -> w a -> w b
#if __GLASGOW_HASKELL__ >= 702
default (<@>) :: Applicative w => w (a -> b) -> w a -> w b
(<@>) = (<*>)
#endif
(@>) :: w a -> w b -> w b
a @> b = const id <$> a <@> b
(<@) :: w a -> w b -> w a
a <@ b = const <$> a <@> b
instance Semigroup m => ComonadApply ((,)m) where
(m, f) <@> (n, a) = (m <> n, f a)
(m, a) <@ (n, _) = (m <> n, a)
(m, _) @> (n, b) = (m <> n, b)
instance ComonadApply NonEmpty where
(<@>) = ap
instance Monoid m => ComonadApply ((->)m) where
(<@>) = (<*>)
(<@ ) = (<* )
( @>) = ( *>)
instance ComonadApply Identity where
(<@>) = (<*>)
(<@ ) = (<* )
( @>) = ( *>)
instance ComonadApply w => ComonadApply (IdentityT w) where
IdentityT wa <@> IdentityT wb = IdentityT (wa <@> wb)
#ifdef MIN_VERSION_containers
instance ComonadApply Tree where
(<@>) = (<*>)
(<@ ) = (<* )
( @>) = ( *>)
#endif
liftW :: Comonad w => (a -> b) -> w a -> w b
liftW f = extend (f . extract)
{-# INLINE liftW #-}
wfix :: Comonad w => w (w a -> a) -> a
wfix w = extract w (extend wfix w)
cfix :: Comonad w => (w a -> a) -> w a
cfix f = fix (extend f)
{-# INLINE cfix #-}
kfix :: ComonadApply w => w (w a -> a) -> w a
kfix w = fix $ \u -> w <@> duplicate u
{-# INLINE kfix #-}
(=>>) :: Comonad w => w a -> (w a -> b) -> w b
(=>>) = flip extend
{-# INLINE (=>>) #-}
(<<=) :: Comonad w => (w a -> b) -> w a -> w b
(<<=) = extend
{-# INLINE (<<=) #-}
(=<=) :: Comonad w => (w b -> c) -> (w a -> b) -> w a -> c
f =<= g = f . extend g
{-# INLINE (=<=) #-}
(=>=) :: Comonad w => (w a -> b) -> (w b -> c) -> w a -> c
f =>= g = g . extend f
{-# INLINE (=>=) #-}
(<@@>) :: ComonadApply w => w a -> w (a -> b) -> w b
(<@@>) = liftW2 (flip id)
{-# INLINE (<@@>) #-}
liftW2 :: ComonadApply w => (a -> b -> c) -> w a -> w b -> w c
liftW2 f a b = f <$> a <@> b
{-# INLINE liftW2 #-}
liftW3 :: ComonadApply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d
liftW3 f a b c = f <$> a <@> b <@> c
{-# INLINE liftW3 #-}
newtype Cokleisli w a b = Cokleisli { runCokleisli :: w a -> b }
#if __GLASGOW_HASKELL__ >= 707
deriving Typeable
#else
#ifdef __GLASGOW_HASKELL__
instance Typeable1 w => Typeable2 (Cokleisli w) where
typeOf2 twab = mkTyConApp cokleisliTyCon [typeOf1 (wa twab)]
where wa :: Cokleisli w a b -> w a
wa = undefined
#endif
cokleisliTyCon :: TyCon
#if MIN_VERSION_base(4,4,0)
cokleisliTyCon = mkTyCon3 "comonad" "Control.Comonad" "Cokleisli"
#else
cokleisliTyCon = mkTyCon "Control.Comonad.Cokleisli"
#endif
{-# NOINLINE cokleisliTyCon #-}
#endif
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 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 = pure
Cokleisli k >>= f = Cokleisli $ \w -> runCokleisli (f (k w)) w
#if !(MIN_VERSION_base(4,7,0))
infixl 4 $>
($>) :: Functor f => f a -> b -> f b
($>) = flip (<$)
#endif