Composing algebras.

g0.hs

{-# LANGUAGE
    GADTs
  , KindSignatures
  , RankNTypes
  , TupleSections
  , TypeOperators
  #-}
module Generics.Morphism where

import Control.Arrow
import Control.Applicative
import Prelude hiding ((>>=), return)

-- The type level fixpoint combinator.

newtype Fix f = In { out :: f (Fix f) }

-- Natural transformations.

type Natural f g = forall a. f a -> g a

data Algebra :: * -> (* -> *) -> * -> * -> * where
  Algebra :: (f (p, r) -> r)                             -> Algebra p f ()          r
  Bind    :: Algebra p f i r -> (r -> Algebra p f j q)   -> Algebra p f ((i, r), j) q
  Natural :: Functor g => Natural f g -> Algebra p g i r -> Algebra p f i           r
  Compose :: Algebra p f i r -> (r -> Algebra p f j r)   -> Algebra p f (i, j)      r

instance Show (Algebra p f i r) where
  show (Algebra _  ) = "Algebra"
  show (Bind    a b) = "(Bind " ++ show a ++ " " ++ show (b undefined) ++ ")"
  show (Natural _ a) = "(Natural " ++ show a ++ ")"
  show (Compose a b) = "(Compose " ++ show a ++ " " ++ show (b undefined) ++ ")"

-------------------------------------------------------------------------------
-- Don't directly expose constructors.

algebra :: (f (p, r) -> r) -> Algebra p f () r
algebra = Algebra

compose :: Algebra p f i r -> (r -> Algebra p f j r) -> Algebra p f (i, j) r
compose = Compose

natural :: Functor g => Natural f g -> Algebra p g i r -> Algebra p f i r
natural = Natural

bind :: Algebra p f i r -> (r -> Algebra p f j q) -> Algebra p f ((i, r), j) q
bind = Bind

-- Construction algberas for paramorphisms and catamorphisms.

type Psi f r = Algebra (Fix f) f () r  -- ^ Paramorphisms.
type Phi f r = Algebra ()      f () r  -- ^ Catamorphisms.

psi :: (f (Fix f, r) -> r) -> Psi f r
psi = Algebra

phi :: Functor f => (f b -> b) -> Phi f b
phi f = Algebra (f . fmap snd)

-------------------------------------------------------------------------------
-- Running algebras.

fold :: Functor f => (Fix f -> p) -> Algebra p f i r -> Fix f -> r
fold pack alg =
  let f = apply alg
      recurse g =  f (pack g) (recurse <$> out g)
   in snd . recurse

apply :: Functor f => Algebra p f i r -> p -> f (i, r) -> (i, r)
apply (Algebra   p) z f = ((), p ((z,) . snd <$> f))
apply (Bind    p b) z f = let (i, r) = apply (p  ) z (fst . fst <$> f)
                              (j, q) = apply (b r) z (first snd <$> f)
                           in (((i, r), j), q)
apply (Natural n p) z f = apply p z (n f)
apply (Compose p b) z f = let (i, r) = apply p     z (first fst <$> f)
                              (j, q) = apply (b r) z (first snd <$> f)
                           in ((i, j), q)

-- Running paramorphisms and catamorphisms.

para :: Functor f => Algebra (Fix f) f i r -> Fix f -> r
para = fold id

cata :: Functor f => Algebra () f i r -> Fix f -> r
cata = fold (const ())

g1.txt

Just another one!