Recursion schemes from scratch

Rec.hs

{-# LANGUAGE RankNTypes, MultiParamTypeClasses, FunctionalDependencies #-}

module Main7 where

sumL :: [Int] -> Int
sumL [] = 0
sumL (x:xs) = x + sumL xs

sumL1 :: [Int] -> Int
sumL1 [] = 0
sumL1 (x:xs) = (+) x (sumL1 xs)

sumL2 :: Int -> [Int] -> Int
sumL2 z [] = z
sumL2 z (x:xs) = (+) x (sumL2 z xs)

sumL3 :: (Int -> Int -> Int) -> Int -> [Int] -> Int
sumL3 fn z [] = z
sumL3 fn z (x:xs) = fn x (sumL3 fn z xs)

sumL4 :: (a -> a -> a) -> a -> [a] -> a
sumL4 fn z [] = z
sumL4 fn z (x:xs) = fn x (sumL4 fn z xs)

foldrList :: (a -> b -> b) -> b -> [a] -> b
foldrList fn z [] = z
foldrList fn z (x:xs) = fn x (foldrList fn z xs)

-- (a -> b -> b) -> b -> [a] -> b
-- ((a, b) -> b) -> b -> [a] -> b
-- b -> ((a, b) -> b) -> [a] -> b
-- (() -> b) -> ((a, b) -> b) -> [a] -> b
-- ((() -> b), ((a, b) -> b)) -> [a] -> b

-- ((1 -> b) * (a * b -> b)) -> [a] -> b
-- (b ^ 1 * b ^ (a * b)) -> [a] -> b
-- (b ^ (1 + a * b)) -> [a] -> b

-- (Either () (a, b) -> b) -> [a] -> b
-- (Maybe (a, b) -> b) -> [a] -> b
-- (ListF a b -> b) -> [a] -> b

type Algebra f a = f a -> a

class Functor f => Recursive t f | t -> f where
  project :: t -> f t

data ListF a b = NilF | ConsF a b

instance Functor (ListF a) where
  fmap _ NilF = NilF
  fmap f (ConsF a b) = ConsF a (f b)

projectL :: [a] -> ListF a [a]
projectL [] = NilF
projectL (x:xs) = ConsF x xs

instance Recursive [a] (ListF a) where
  project = projectL

foldrListC :: Algebra (ListF a) b -> [a] -> b
foldrListC g = go where
  go = g . fmap go . project

data Expr = Lit Int | Add Expr Expr | Mul Expr Expr

evalExpr :: Expr -> Int
evalExpr = go where
  go (Lit x) = x
  go (Add e1 e2) = go e1 + go e2
  go (Mul e1 e2) = go e1 * go e2

evalExpr' :: (Int -> a) -> (a -> a -> a) -> (a -> a -> a) -> Expr -> a
evalExpr' fn _ _ (Lit a) = fn a
evalExpr' fn add mul (Add a b) = add (evalExpr' fn add mul a) (evalExpr' fn add mul b)
evalExpr' fn add mul (Mul a b) = mul (evalExpr' fn add mul a) (evalExpr' fn add mul b)

-- (Int -> a) -> (a -> a -> a) -> (a -> a -> a) -> Expr -> a
-- (Int -> a) -> ((a, a) -> a) -> ((a, a) -> a) -> Expr -> a
-- ((Int -> a), ((a, a) -> a)) -> ((a, a) -> a) -> Expr -> a
-- (((Int -> a), ((a, a) -> a)), ((a, a) -> a)) -> Expr -> a

-- (a ^ Int * a ^ a * a * a ^ a * a)
-- (Either Int (Either (a, a) (a, a)) -> a) -> Expr -> a
-- (ExprF a -> a) -> Expr -> a

projectE :: Expr -> ExprF Expr
projectE (Lit x) = LitF x
projectE (Add a b) = AddF a b
projectE (Mul a b) = MulF a b

data ExprF a = LitF Int | AddF a a | MulF a a

instance Recursive Expr ExprF where
  project = projectE

instance Functor ExprF where
  fmap _ (LitF x) = LitF x
  fmap f (AddF a b) = AddF (f a) (f b)
  fmap f (MulF a b) = MulF (f a) (f b)

evalExprC :: Algebra ExprF a -> Expr -> a
evalExprC g = go where
  go = g . fmap go . project

-- data Tree a = Empty | Node (Tree a) a (Tree a)
-- data RoseTree a = RoseNode a [RoseTree a]

-- () = 1
-- Void = 0
-- (,) = (*)
-- Either = (+)
-- a -> b = b ^ a

-- a ^ n * a ^ m = a ^ (n + m)

cata :: Recursive t f => Algebra f a -> t -> a
cata alg = go where
  go = alg . fmap go . project

foldMapL :: Monoid m => (a -> m) -> [a] -> m
foldMapL fn = cata alg where
  alg NilF = mempty
  alg (ConsF x xs) = fn x <> xs