Composing algebras using Arrow and Applicative.

g1.hs

{-# LANGUAGE GADTs, TypeOperators, TupleSections #-}
module Generics.Algebra where

import Control.Category
import Control.Arrow
import Control.Applicative
import Prelude hiding ((.), id)

import Generics.Combinator

-------------------------------------------------------------------------------

-- | Generic algebra type.

type Alg i -- ^ An additional value used for algebra composition.
         f -- ^ The recursive functor to decompose into a result.
         a -- ^ Additional input for the algebra.
         b -- ^ Result of running the algebra.
  = a -> f (i, b) -> (i, b)

data Algebra f a b where
  Algebra :: Alg i f a b -> Algebra f a b

algebra :: Functor f => (a -> f b -> b) -> Algebra f a b
algebra alg = Algebra (\a -> (,) () . alg a . fmap snd)

type Phi f b = Algebra f () b

phi :: Functor f => (f b -> b) -> Phi f b
phi f = algebra (const f)

-------------------------------------------------------------------------------

-- | Generic coalgebra type.

type Coalg f -- ^ The recursive functor to construct from a seed value.
           a -- ^ Additional input for the coalgebra.
           b -- ^ Type of the input seed.
  = a -> b -> f b

data Coalgebra f a b where
  Coalgebra :: Coalg f a b -> Coalgebra f a b

coalgebra :: Functor f => (a -> b -> f b) -> Coalgebra f a b
coalgebra coalg = Coalgebra coalg

type Psi f b = Coalgebra f () b

psi :: Functor f => (b -> f b) -> Psi f b
psi f = coalgebra (const f)

-------------------------------------------------------------------------------

instance Functor f => Category (Algebra f) where
  id                    = Algebra (const . (,) ())
  Algebra a . Algebra b = Algebra (compose a b)

instance Functor f => Functor (Algebra f a) where
  fmap f (Algebra g) = Algebra (amap f g)

instance Functor f => Applicative (Algebra f a) where
  pure = Algebra . const . const . (,) ()
  Algebra f <*> Algebra g = Algebra (ap f g)

instance Functor f => Arrow (Algebra f) where
  arr f = Algebra (const . (,) () . f)
  first (Algebra f) = Algebra (\(b, d) -> second (, d) . f b . fmap (second fst))

instance Functor f => ArrowLoop (Algebra f) where
  loop (Algebra f) = Algebra $ \b inp ->
    let (i, (c, d)) = f (b, d) (second (, d) <$> inp) in (i, c)

compose :: Functor f => Alg j f b c -> Alg i f a b -> Alg (j, (i, b)) f a c
compose f g a input =
  let (i, b) = g a (prj_g <$> input)
      (j, c) = f b (prj_f <$> input)
   in ((j, (i, b)), c)
 where prj_f ((j, (_, _)), c) = (j, c)
       prj_g ((_, (i, b)), _) = (i, b)

ap :: Functor f => Alg j f c (a -> b) -> Alg i f c a -> Alg ((i, a), (j, a -> b)) f c b
ap f g c input =
  let (i, a ) = g c (prj_g <$> input)
      (j, ab) = f c (prj_f <$> input)
   in (((i, a), (j, ab)), ab a)
 where prj_f (((_, _), (j, ab)), _) = (j, ab)
       prj_g (((i, a), (_, _ )), _) = (i, a)

amap :: Functor f => (a -> b) -> Alg i f c a -> Alg (i, a) f c b
amap fn f c input =
    let (i, a) = f c (prj <$> input)
     in ((i, a), fn a)
    where prj ((i, a), _) = (i, a)

-------------------------------------------------------------------------------

-- Running algebras.

para :: Functor f => Algebra f (a, Fix f) b -> a -> Fix f -> b
para (Algebra alg) a = snd . recurse
  where recurse g = alg (a, g) (recurse <$> out g)

cata :: Functor f => Algebra f a b -> a -> Fix f -> b
cata (Algebra alg) a = para (Algebra alg .  arr fst) a

-- Like para but without an additional input.

para1 :: Functor f => Algebra f (Fix f) b -> Fix f -> b
para1 alg = para (alg . arr snd) ()

-- Running coalgebras.

ana :: Functor f => Coalgebra f a b -> a -> b -> Fix f
ana (Coalgebra coalg) a = In . fmap (ana (Coalgebra coalg) a) . coalg a

-- Lifting algebras to annotated structures.

lift :: Copointed n => Algebra f a b -> Algebra (n / f) a b
lift (Algebra alg) = Algebra (\n -> alg n . copoint . deC)

liftEndo :: (Copointed n, Functor n) => Algebra f (f r -> r) s -> Algebra (n / f) ((n / f) r -> r) s
liftEndo (Algebra alg) = Algebra (\en inp -> alg (\i -> en (mapC (const i) inp)) (copoint (deC inp)))

endoish :: (Copointed n, Functor n) => Algebra f (f r -> r, a) s -> Algebra (n / f) ((n / f) r -> r, a) s
endoish (Algebra alg) = Algebra (\(en, a) inp -> alg (\i -> en (mapC (const i) inp), a) (copoint (deC inp)))