Recursion schemes

Main.hs

{-# LANGUAGE DeriveFunctor     #-}
{-# LANGUAGE FlexibleInstances #-}
module Main where

import Prelude hiding (length, filter, succ, foldl, foldr, sum, head, reverse)
import qualified Prelude

-------------------------------------------------------------------------------

newtype Fix f = Fx { unFix :: f (Fix f) }

cata :: Functor f => (f a -> a) -> Fix f -> a
cata alg = alg . fmap (cata alg) . unFix

para :: Functor f => (f (Fix f, a) -> a) -> Fix f -> a
para coalg (Fx f) = coalg (fmap keep f) where
    keep x = (x, para coalg x)

ana :: Functor f => (a -> f a) -> a -> Fix f
ana coalg = Fx . fmap (ana coalg) . coalg

-------------------------------------------------------------------------------

data ListF a f = NilF | ConsF a f
    deriving (Show, Functor)

type List a = Fix (ListF a)

cons :: a -> List a -> List a
cons x xs = Fx (ConsF x xs)

nil :: List a
nil = Fx NilF

length :: List a -> Integer
length = cata alg where
    alg NilF = 0
    alg (ConsF _ len) = 1 + len

head :: List a -> Maybe a
head list = case unFix list of
    NilF -> Nothing
    ConsF x _ -> Just x

sum :: Num a => List a -> a
sum = cata alg where
    alg NilF = 0
    alg (ConsF e acc) = e + acc

filter :: (a -> Bool) -> List a -> List a
filter p = cata alg where
    alg NilF = nil
    alg (ConsF x xs)
        | p x = cons x xs
        | otherwise = xs

foldr :: (t -> s -> s) -> s -> List t -> s
foldr f s = cata alg where
    alg NilF = s
    alg (ConsF x xs) = f x xs

foldl :: (s -> t -> s) -> s -> List t -> s
foldl f = flip (cata alg) where
    alg NilF = id
    alg (ConsF x xs) = \r -> xs (f r x)

map :: (a -> b) -> List a -> List b
map f = cata alg where
    alg NilF = nil
    alg (ConsF x xs) = cons (f x) xs

reverse :: List a -> List a
reverse = foldl (flip cons) nil

-------------------------------------------------------------------------------

fromList :: [a] -> List a
fromList = ana coalg where
    coalg [] = NilF
    coalg (x:xs) = ConsF x xs

toList :: List a -> [a]
toList = cata alg where
    alg NilF = []
    alg (ConsF x xs) = x : xs

instance Show a => Show (List a) where
    show = show . toList

-------------------------------------------------------------------------------

data NatF f = ZeroF | SuccF f
    deriving (Show, Functor)

type Nat = Fix NatF

zero :: Nat
zero = Fx ZeroF

succ :: Nat -> Nat
succ = Fx . SuccF

plus :: Nat -> Nat -> Nat
plus n = cata alg where
    alg ZeroF = n
    alg (SuccF m) = succ m

factorial :: Nat -> Integer
factorial = para alg where
    alg ZeroF = 1
    alg (SuccF (n, f)) = fromNat (succ n) * f

countdown :: Nat -> List Nat
countdown = para alg where
    alg ZeroF = nil
    alg (SuccF (n, f)) = cons n f

-------------------------------------------------------------------------------

toNat :: Integer -> Nat
toNat = ana coalg where
    coalg n
      | n <= 0 = ZeroF
      | otherwise = SuccF (n - 1)

fromNat :: Nat -> Integer
fromNat = cata alg where
    alg ZeroF = 0
    alg (SuccF m) = 1 + m

instance Show Nat where
    show = show . fromNat

-------------------------------------------------------------------------------

data List1F a f = FinalF a | Cons1F a f
    deriving (Show, Functor)

-------------------------------------------------------------------------------

main :: IO ()
main = do
    let xs = [3,9]
    print ( Prelude.foldr (-) 5 xs                   
          , foldr (-) 5 (fromList xs)
          )
    print ( Prelude.foldr (-) 5 (Prelude.reverse xs) 
          , foldr (-) 5 (fromList (Prelude.reverse xs))
          )
    putStrLn "--"
    let ys = ["b","c","d"]
    print ( Prelude.foldl (<>) "a" ys                   
          , foldl (<>) "a" (fromList ys)
          )
    print ( Prelude.foldl (<>) "a" (Prelude.reverse ys) 
          , foldl (<>) "a" (fromList (Prelude.reverse ys))
          )