Skip to content

Commit

Permalink
refactored ComonadZip into FunctorApply and ComonadApply
Browse files Browse the repository at this point in the history
  • Loading branch information
@ekmett
ekmett committed Jan 7, 2011
1 parent bd9b7e6 commit dd0a8b4
Show file tree
Hide file tree
Showing 2 changed files with 194 additions and 88 deletions.
280 changes: 193 additions & 87 deletions Control/Comonad.hs
View file
Expand Up @@ -11,37 +11,35 @@
-- --
-- A 'Comonad' is the categorical dual of a 'Monad'. -- A 'Comonad' is the categorical dual of a 'Monad'.
---------------------------------------------------------------------------- ----------------------------------------------------------------------------
module Control.Comonad module Control.Comonad (
( -- * Functors
-- * Functor and Comonad
Functor(..) Functor(..)
, Comonad(..) , ($>) -- :: Functor f => f a -> b -> f b
-- * Functions

-- ** Naming conventions
-- $naming

-- ** Operators
, (=>=) -- :: Comonad w => (w a -> b) -> (w b -> c) -> w a -> c
, (=<=) -- :: Comonad w => (w b -> c) -> (w a -> b) -> w a -> c
, (=>>) -- :: Comonad w => w a -> (w a -> b) -> w b
, (<<=) -- :: Comonad w => (w a -> b) -> w a -> w b

-- * Fixed points and folds
, wfix -- :: Comonad w => w (w a -> a) -> a
, unfoldW -- :: Comonad w => (w b -> (a,b)) -> w b -> [a]


-- ** Comonadic lifting -- * Comonads
, liftW -- :: Comonad w => (a -> b) -> w a -> w b , Comonad(..)

, (=>=) -- :: Comonad w => (w a -> b) -> (w b -> c) -> w a -> c
-- * Comonads with Zipping , (=<=) -- :: Comonad w => (w b -> c) -> (w a -> b) -> w a -> c
, ComonadZip(..) , (=>>) -- :: Comonad w => w a -> (w a -> b) -> w b
, (<..>) -- :: ComonadZip w => w a -> w (a -> b) -> w b , (<<=) -- :: Comonad w => (w a -> b) -> w a -> w b
, liftW2 -- :: ComonadZip w => (a -> b -> c) -> w a -> w b -> w c , liftW -- :: Comonad w => (a -> b) -> w a -> w b
, liftW3 -- :: ComonadZip w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d , wfix -- :: Comonad w => w (w a -> a) -> a


-- * Cokleisli Arrows -- * FunctorApply - strong lax symmetric semimonoidal endofunctors
, FunctorApply(..)
, (<..>) -- :: FunctorApply w => w a -> w (a -> b) -> w b
, liftF2 -- :: FunctorApply w => (a -> b -> c) -> w a -> w b -> w c
, liftF3 -- :: FunctorApply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d

-- * ComonadApply - strong lax symmetric semimonoidal comonads
, ComonadApply
, liftW2 -- :: ComonadApply w => (a -> b -> c) -> w a -> w b -> w c
, liftW3 -- :: ComonadApply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d

-- * Wrappers
, Cokleisli(..) , Cokleisli(..)
, WrappedApplicative(..)
, WrappedApply(..)
) where ) where


import Prelude hiding (id, (.)) import Prelude hiding (id, (.))
Expand All @@ -55,9 +53,13 @@ import Data.Monoid


infixl 1 =>> infixl 1 =>>
infixr 1 <<=, =<=, =>= infixr 1 <<=, =<=, =>=
infixl 4 <.>, <., .>, <..> infixl 4 <.>, <., .>, <..>, $>

($>) :: Functor f => f a -> b -> f b
($>) = flip (<$)


{- | {- |
There are two ways to define a comonad: There are two ways to define a comonad:
I. Provide definitions for 'extract' and 'extend' I. Provide definitions for 'extract' and 'extend'
Expand Down Expand Up @@ -143,10 +145,6 @@ f =<= g = f . extend g
f =>= g = g . extend f f =>= g = g . extend f
{-# INLINE (=>=) #-} {-# INLINE (=>=) #-}


-- | A generalized comonadic list anamorphism
unfoldW :: Comonad w => (w b -> (a,b)) -> w b -> [a]
unfoldW f w = fst (f w) : unfoldW f (w =>> snd . f)

-- | Comonadic fixed point -- | Comonadic fixed point
wfix :: Comonad w => w (w a -> a) -> a wfix :: Comonad w => w (w a -> a) -> a
wfix w = extract w (extend wfix w) wfix w = extract w (extend wfix w)
Expand Down Expand Up @@ -184,104 +182,212 @@ instance Comonad w => Comonad (IdentityT w) where
extract = extract . runIdentityT extract = extract . runIdentityT
extend f (IdentityT m) = IdentityT (extend (f . IdentityT) m) extend f (IdentityT m) = IdentityT (extend (f . IdentityT) m)


{- | -- | A strong lax symmetric semi-monoidal functor.


As a symmetric semi-monoidal comonad, an instance of ComonadZip is required to satisfy: class Functor f => FunctorApply f where
(<.>) :: f (a -> b) -> f a -> f b


> extract (a <.> b) = extract a (extract b) -- | a .> b = const id <$> a <.> b
(.>) :: f a -> f b -> f b
a .> b = const id <$> a <.> b


Minimal definition: '<.>' -- | a <. b = const <$> a <.> b
(<.) :: f a -> f b -> f a
a <. b = const <$> a <.> b


Based on the ComonadZip from \"The Essence of Dataflow Programming\" -- this only requires a Semigroup
by Tarmo Uustalu and Varmo Vene, but adapted to fit the programming style of instance Monoid m => FunctorApply ((,)m) where
Control.Applicative. (<.>) = (<*>)
(<. ) = (<* )
( .>) = ( *>)


-} -- this only requires a Semigroup
class Comonad w => ComonadZip w where instance Monoid m => FunctorApply ((->)m) where
(<.>) :: w (a -> b) -> w a -> w b (<.>) = (<*>)
(.>) :: w a -> w b -> w b (<. ) = (<* )
(<.) :: w a -> w b -> w a ( .>) = ( *>)


a .> b = const id <$> a <.> b instance FunctorApply ZipList where
a <. b = const <$> a <.> b (<.>) = (<*>)

(<. ) = (<* )
instance Monoid m => ComonadZip ((,)m) where ( .>) = ( *>)

instance FunctorApply [] where
(<.>) = (<*>)
(<. ) = (<* )
( .>) = ( *>)

instance FunctorApply IO where
(<.>) = (<*>) (<.>) = (<*>)
(<. ) = (<* )
( .>) = ( *>)


instance Monoid m => ComonadZip ((->)m) where instance FunctorApply Maybe where
(<.>) = (<*>) (<.>) = (<*>)
(<. ) = (<* )
( .>) = ( *>)


instance ComonadZip Identity where instance FunctorApply Identity where
(<.>) = (<*>) (<.>) = (<*>)
(<. ) = (<* )
( .>) = ( *>)


instance ComonadZip w => ComonadZip (IdentityT w) where instance FunctorApply w => FunctorApply (IdentityT w) where
IdentityT wa <.> IdentityT wb = IdentityT (wa <.> wb) 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
(<.>) = (<*>)
(<. ) = (<* )
( .>) = ( *>)

-- | Wrap Applicatives to be used as a member of FunctorApply
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)

-- | Transform a strong lax symmetric semi-monoidal endofunctor into a strong lax symmetric
-- monoidal endofunctor by adding a unit.
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)

-- | A variant of '<.>' with the arguments reversed. -- | A variant of '<.>' with the arguments reversed.
(<..>) :: ComonadZip w => w a -> w (a -> b) -> w b (<..>) :: FunctorApply w => w a -> w (a -> b) -> w b
(<..>) = liftW2 (flip id) (<..>) = liftF2 (flip id)
{-# INLINE (<..>) #-} {-# INLINE (<..>) #-}


-- | Lift a binary function into a comonad with zipping -- | Lift a binary function into a comonad with zipping
liftW2 :: ComonadZip w => (a -> b -> c) -> w a -> w b -> w c liftF2 :: FunctorApply w => (a -> b -> c) -> w a -> w b -> w c
liftW2 f a b = f <$> a <.> b liftF2 f a b = f <$> a <.> b
{-# INLINE liftF2 #-}

-- | Lift a ternary function into a comonad with zipping
liftF3 :: FunctorApply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d
liftF3 f a b c = f <$> a <.> b <.> c
{-# INLINE liftF3 #-}

{- |
A strong lax symmetric semi-monoidal comonad. As such an instance of
'ComonadApply' is required to satisfy:
> extract (a <.> b) = extract a (extract b)
This class is based on ComonadZip from \"The Essence of Dataflow Programming\"
by Tarmo Uustalu and Varmo Vene, but adapted to fit the programming style of
Control.Applicative. 'Applicative' can be seen as a similar law over and above
FunctorApply that:
> pure (a b) = pure a <.> pure b
-}

class (Comonad w, FunctorApply w) => ComonadApply w
-- | Only requires a Semigroup, but no such class exists
instance Monoid m => ComonadApply ((,)m)
-- | Only requires a Semigroup, but no such class exists
instance Monoid m => ComonadApply ((->)m)
instance ComonadApply Identity
instance ComonadApply w => ComonadApply (IdentityT w)

-- | Lift a binary function into a comonad with zipping
liftW2 :: ComonadApply w => (a -> b -> c) -> w a -> w b -> w c
liftW2 = liftF2
{-# INLINE liftW2 #-} {-# INLINE liftW2 #-}


-- | Lift a ternary function into a comonad with zipping -- | Lift a ternary function into a comonad with zipping
liftW3 :: ComonadZip w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d liftW3 :: ComonadApply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d
liftW3 f a b c = f <$> a <.> b <.> c liftW3 = liftF3
{-# INLINE liftW3 #-} {-# INLINE liftW3 #-}


-- | The 'Cokleisli' 'Arrow's of a given 'Comonad' -- | The 'Cokleisli' 'Arrow's of a given 'Comonad'
newtype Cokleisli w a b = Cokleisli { runCokleisli :: w a -> b } 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 instance Comonad w => Arrow (Cokleisli w) where
arr f = Cokleisli (f . extract) arr f = Cokleisli (f . extract)
first f = f *** id first f = f *** id
second f = id *** f second f = id *** f
Cokleisli f *** Cokleisli g = Cokleisli (f . fmap fst &&& g . fmap snd) Cokleisli f *** Cokleisli g = Cokleisli (f . fmap fst &&& g . fmap snd)
Cokleisli f &&& Cokleisli g = Cokleisli (f &&& g) Cokleisli f &&& Cokleisli g = Cokleisli (f &&& g)


instance Comonad w => Category (Cokleisli w) where
id = Cokleisli extract
Cokleisli f . Cokleisli g = Cokleisli (f =<= g)

instance Comonad w => ArrowApply (Cokleisli w) where instance Comonad w => ArrowApply (Cokleisli w) where
app = Cokleisli $ \w -> runCokleisli (fst (extract w)) (snd <$> w) app = Cokleisli $ \w -> runCokleisli (fst (extract w)) (snd <$> w)


instance Comonad w => ArrowChoice (Cokleisli w) where instance Comonad w => ArrowChoice (Cokleisli w) where
left = leftApp left = leftApp


instance ComonadZip d => ArrowLoop (Cokleisli d) where instance ComonadApply w => ArrowLoop (Cokleisli w) where
loop (Cokleisli f) = Cokleisli (fst . wfix . extend f') where loop (Cokleisli f) = Cokleisli (fst . wfix . extend f') where
f' wa wb = f ((,) <$> wa <.> (snd <$> wb)) f' wa wb = f ((,) <$> wa <.> (snd <$> wb))


-- Cokleisli arrows are actually just a special case of a reader monad:

instance Functor (Cokleisli w a) where instance Functor (Cokleisli w a) where
fmap f (Cokleisli g) = Cokleisli (f . g) fmap f (Cokleisli g) = Cokleisli (f . g)


instance Monad (Cokleisli w a) where instance FunctorApply (Cokleisli w a) where
return a = Cokleisli (const a) Cokleisli f <.> Cokleisli a = Cokleisli (\w -> (f w) (a w))
Cokleisli k >>= f = Cokleisli $ \w -> runCokleisli (f (k w)) w

{- $naming
The functions in this library use the following naming conventions, based
on those of Control.Monad.


* A postfix \'@W@\' always stands for a function in the Cokleisli category: instance Applicative (Cokleisli w a) where
The monad type constructor @w@ is added to function results pure = Cokleisli . const
(modulo currying) and nowhere else. So, for example, Cokleisli f <*> Cokleisli a = Cokleisli (\w -> (f w) (a w))


> filter :: (a -> Bool) -> [a] -> [a] instance Monad (Cokleisli w a) where
> filterW :: Comonad w => (w a -> Bool) -> w [a] -> [a] return = Cokleisli . const
Cokleisli k >>= f = Cokleisli $ \w -> runCokleisli (f (k w)) w
* A prefix \'@w@\' generalizes an existing function to a comonadic form.
Thus, for example:
> fix :: (a -> a) -> a
> wfix :: w (w a -> a) -> a
When ambiguous, consistency with existing Control.Monad combinator naming
supercedes these rules (e.g. 'liftW')
-}
2 changes: 1 addition & 1 deletion comonad.cabal
View file
@@ -1,6 +1,6 @@
name: comonad name: comonad
category: Control, Comonads category: Control, Comonads
version: 0.3.1 version: 0.4.0
license: BSD3 license: BSD3
cabal-version: >= 1.2 cabal-version: >= 1.2
license-file: LICENSE license-file: LICENSE
Expand Down

0 comments on commit dd0a8b4

Please sign in to comment.