Create a gist now

Instantly share code, notes, and snippets.

Composing algebras.
{-# 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 ())
Just another one!
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment