public
Created

Composing algebras.

  • Download Gist
g0.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85
{-# 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
1
Just another one!

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.