Type composition

{-# OPTIONS -fglasgow-exts #-}
-- Various type constructor compositions and instances for them.
-- References:
-- [1] [http://www.soi.city.ac.uk/~ross/papers/Applicative.html Applicative Programming with Effects]
 
module Control.Compose ((:.:)(..), (:.::)(..), (::.:)(..), App(..)) where
 
import Control.Applicative
import Control.Arrow hiding (pure)
import Data.Monoid
 
-- | Often useful for \"acceptors\" (consumers, sinks) of values.
class Cofunctor acc where
  cofmap :: (a -> b) -> (acc b -> acc a)
 
-- | Composition of type constructors: unary & unary.  Called "g . f"
-- in [1], section 5.
newtype (g :.: f) a = T_T { runT_T :: g (f a) }
 
instance (Functor g, Functor f) => Functor (g :.: f) where
  fmap f (T_T m) = T_T (fmap (fmap f) m)
 
instance (Applicative g, Applicative f) => Applicative (g :.: f) where
  pure                   = T_T . pure . pure
  T_T getf <*> T_T getx  = T_T (liftA2 (<*>) getf getx)
 
-- standard Monoid instance for Applicative applied to Monoid
instance (Applicative (f :.: g), Monoid a) => Monoid ((f :.: g) a) where
  { mempty = pure mempty; mappend = (*>) }
 
instance (Functor g, Cofunctor f) => Cofunctor (g :.: f) where
  cofmap h (T_T gf) = T_T (fmap (cofmap h) gf)
 
-- Or this alternative.  Having both yields "Duplicate instance
-- declarations".  How to decide between these instances?
-- instance (Cofunctor g, Functor f) => Cofunctor (g :.: f) where
--   cofmap h (T_T gf) = T_T (cofmap (fmap h) gf)
 
 
-- | Composition of type constructors: unary & binary.  Called
-- "StaticArrow" in [1], section 6.
 
newtype (f :.:: (~>)) a b = T_TT { runT_TT :: f (a ~> b) }
 
instance (Applicative f, Arrow (~>)) => Arrow (f :.:: (~>)) where
  arr                = T_TT . pure . arr
  T_TT g >>> T_TT h  = T_TT (liftA2 (>>>) g h)
  first (T_TT g)     = T_TT (liftA first g)
 
-- For instance, /\ a b. f (a -> m b) =~  f :.:: Kleisli m
 
 
-- | Composition of type constructors: unary & binary.
-- Wolfgang Jeltsch pointed out a problem with these definitions: 'splitA'
-- and 'mergeA' are not inverses.  The definition of 'first', e.g.,
-- violates the \"extension\" law and causes repeated execution.  Look for
-- a reformulation or a clarification of required properties of the
-- applicative functor @f@.
 
newtype ((~>) ::.: f) a b = TT_T {runTT_T :: f a ~> f b}
 
instance (Arrow (~>), Applicative f) => Arrow ((~>) ::.: f) where
  arr                = TT_T . arr . liftA
  TT_T g >>> TT_T h  = TT_T (g >>> h)
  first (TT_T a)     =
    TT_T (arr splitA >>> first a >>> arr mergeA)
 
instance (ArrowLoop (~>), Applicative f) => ArrowLoop ((~>) ::.: f) where
  -- loop :: UI (b,d) (c,d) -> UI b c
  loop (TT_T k) =
    TT_T (loop (arr mergeA >>> k >>> arr splitA))
 
mergeA :: Applicative f => (f a, f b) -> f (a,b)
mergeA ~(fa,fb) = liftA2 (,) fa fb
 
splitA :: Applicative f => f (a,b) -> (f a, f b)
splitA fab = (liftA fst fab, liftA snd fab)
 
 
-- | Flip type arguments
newtype Flip (~>) b a = Flip (a ~> b)
 
instance Arrow (~>) => Cofunctor (Flip (~>) b) where
  cofmap h (Flip f) = Flip (arr h >>> f)
 
 
-- | Type application
newtype App f a = App { runApp :: f a }
 
-- Example: App IO ()
instance (Applicative f, Monoid m) => Monoid (App f m) where
  mempty = App (pure mempty)
  App a `mappend` App b = App (a *> b)
 
{-
-- We can also drop the App constructor, but then we overlap with many
-- other instances, like [a].
instance (Applicative f, Monoid a) => Monoid (f a) where
  mempty = pure mempty
  mappend = (*>)
-}