Catamorphisms in Haskell

gistfile1.txt

{-# LANGUAGE DeriveFoldable      #-}
{-# LANGUAGE DeriveFunctor       #-}
{-# LANGUAGE DeriveTraversable   #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Catamorphisms where

import Data.Foldable
import Data.Monoid

data ExprSimp =
    LitSimp Int
  | StrSimp String
  | AddSimp ExprSimp ExprSimp
  | ConcatSimp ExprSimp ExprSimp

foldExprSimp
  :: (Int -> b)
  -> (String -> b)
  -> (b -> b -> b)
  -> (b -> b -> b)
  -> ExprSimp
  -> b
foldExprSimp handleLit handleStr handleAdd handleConcat expr =
  case expr of
    LitSimp n      -> handleLit n
    StrSimp s      -> handleStr s
    AddSimp x y    -> handleAdd (go x) (go y)
    ConcatSimp x y -> handleConcat (go x) (go y)
  where
    go = foldExprSimp handleLit handleStr handleAdd handleConcat

data ExprSimpAlg b = ExprSimpAlg
  { algLit    :: Int    -> b
  , algStr    :: String -> b
  , algAdd    :: b      -> b -> b
  , algConcat :: b      -> b -> b
  }

foldExprSimpWithAlg :: ExprSimpAlg b -> ExprSimp -> b
foldExprSimpWithAlg (ExprSimpAlg a b c d) = foldExprSimp a b c d

data ExprF e =
    Lit Int
  | Str String
  | Add e e
  | Concat e e
  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)

test :: ExprF (ExprF a)
test = Concat (Str "foo") (Str "bar")

-- f (f (f (f ...)))
newtype Fix (f :: * -> *) = Fix { unFix :: f (Fix f) }

type Expr = Fix ExprF

testExpr :: Expr
testExpr =
  Fix (Concat
         (Fix (Concat
                 (Fix (Str "foo"))
                 (Fix (Str "bar"))))
         (Fix (Str "baz")))

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

cataExpr :: (ExprF a -> a) -> Fix ExprF -> a
cataExpr = cata

evalInt :: Expr -> Int
evalInt = cata alg
  where
    alg :: ExprF Int -> Int
    alg (Lit n)   = n
    alg (Add x y) = x + y
    alg _         = error "Impossible"

hasLits :: Expr -> Bool
hasLits = getAny . cata alg
  where
    alg :: ExprF Any -> Any
    alg (Lit _)   = Any True
    alg e         = fold' e

newtype Size = Size { getSize :: Int }
  deriving (Show)

instance Monoid Size where
  mempty = Size 0
  mappend (Size x) (Size y) = Size $ x + y

fold' :: (Foldable f, Monoid a) => f a -> a
fold' = fold

size :: forall f. (Functor f, Foldable f) => Fix f -> Int
size = getSize . cata alg
  where
    alg :: f Size -> Size
    alg x = Size 1 <> fold' x

testIntExpr :: Expr
testIntExpr =
  Fix (Add
        (Fix (Lit 1))
        (Fix (Add
               (Fix (Lit 5))
               (Fix (Lit 3)))))

data ListSimp a = NilSimp | ConsSimp a (ListSimp a)

foldr'' :: (a -> b -> b) -> b -> ListSimp a -> b
foldr'' _ acc NilSimp         = acc
foldr'' f acc (ConsSimp x xs) = f x $ foldr'' f acc xs

data ListF a r = Nil | Cons a r
  deriving (Show, Eq, Ord, Functor, Foldable, Traversable)

type List a = Fix (ListF a)

testList :: List String
testList =
  Fix (Cons "foo"
            (Fix (Cons "bar"
                       (Fix (Cons "baz"
                                  (Fix Nil))))))

testList' :: List Int
testList' =
  Fix (Cons 1
            (Fix (Cons 3
                       (Fix (Cons 2
                                  (Fix Nil))))))

sumList :: List Int -> Int
sumList = cata alg
  where
    alg :: ListF Int Int -> Int
    alg Nil        = 0
    alg (Cons x y) = x + y

foldrViaCata :: forall a b. (a -> b -> b) -> b -> List a -> b
foldrViaCata handleCons handleNil = cata alg
  where
    alg :: ListF a b -> b
    alg Nil        = handleNil
    alg (Cons x y) = handleCons x y