Applicative algebras

gistfile1.hs

{-# LANGUAGE GADTs, KindSignatures #-}

import Prelude hiding (length, sum)

import Control.Applicative
import Control.Arrow

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

data Alg :: (* -> *) -> * -> * -> * where
  Alg  :: (f r -> r) -> Alg f r r
  Fmap :: (s -> t) -> Alg f r s -> Alg f r t
  Par  :: Alg f r s -> Alg f r' t -> Alg f (r, r') (s, t)
  Pure :: s -> Alg f r s

cataAlg :: Functor f => Alg f r s -> Fix f -> s
cataAlg alg = uncurry ($) . cataAlg' alg

cataAlg' :: Functor f => Alg f r s -> Fix f -> (r -> s, r)
cataAlg' alg = applyAlg alg . fmap snd . fmap (cataAlg' alg) . out

data Algebra :: (* -> *) -> * -> * where
  Algebra :: Alg f r s -> Algebra f s

applyAlg :: Functor f => Alg f r s -> f r -> (r -> s, r)
applyAlg (Alg alg) fr = (id, alg fr)
applyAlg (Fmap f a) fr = let (rf, r) = applyAlg a fr in (f . rf, r)
applyAlg (Par as ar) fr = let (fs, rs) = applyAlg as (fmap fst fr)
                              (ft, rt) = applyAlg ar (fmap snd fr)
                          in ((fs *** ft), (rs, rt))
applyAlg (Pure x) _ = (const x, undefined)

dup r = (r, r)

instance Functor f => Functor (Algebra f) where
  fmap f (Algebra a) = Algebra (Fmap f a)

instance Functor f => Applicative (Algebra f) where
  pure x = Algebra (Pure x)
  (Algebra a1) <*> (Algebra a2) = Algebra (Fmap (uncurry ($)) (Par a1 a2))

cata :: Functor f => Algebra f r -> Fix f -> r
cata (Algebra alg) = cataAlg alg

data ListF a r = Nil | Cons a r
type List a = Fix (ListF a)
instance Functor (ListF a) where
  fmap _ Nil = Nil
  fmap f (Cons x xs) = Cons x (f xs)

lengthAlg = Algebra $ Alg lengthAlg'
  where
    lengthAlg' Nil = 0
    lengthAlg' (Cons _ l) = l + 1

sumAlg = Algebra $ Alg sumAlg'
  where
    sumAlg' Nil = 0
    sumAlg' (Cons x xs) = x + xs

length = cata lengthAlg
sum = cata sumAlg
lengthPlusSum = cata ((+) <$> lengthAlg <*> sumAlg)

nil = In Nil
cons x xs = In (Cons x xs)

l = cons 1 (cons 2 (cons 3 nil))

test = (length l, sum l, lengthPlusSum l)

Dit verdient je eerste tweet te worden. En dan zal ik hem retweeten. :-)