Hoodlums 9/03/2017

Cata.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}

module Cata where

import Data.Foldable
import Text.Show.Functions()

data ExprF r
  = AppF r r
  | AbsF String r
  | VarF String
  | LitIF Int
  | AddF r r
  | MulF r r
  deriving (Foldable, Functor, Show)

newtype Fix f = Fix { unfix :: f (Fix f) }

deriving instance (Show (f (Fix f))) => Show (Fix f)

type Expr = Fix ExprF

pattern App :: Fix ExprF -> Fix ExprF -> Fix ExprF
pattern App a b = Fix (AppF a b)

pattern Abs :: String -> Fix ExprF -> Fix ExprF
pattern Abs s a = Fix (AbsF s a)

pattern Var :: String -> Fix ExprF
pattern Var   s = Fix (VarF s)

pattern LitI :: Int -> Fix ExprF
pattern LitI  i = Fix (LitIF i)

pattern Add :: Fix ExprF -> Fix ExprF -> Fix ExprF
pattern Add a b = Fix (AddF a b)

pattern Mul :: Fix ExprF -> Fix ExprF -> Fix ExprF
pattern Mul a b = Fix (MulF a b)

add1 :: Expr
add1 = Abs "n" (Add (Var "n") (LitI 1))

add1to4 :: Expr
add1to4 = App add1 (LitI 4)

type Env = [(String, Expr)]

eval :: Env -> Expr -> Expr
eval e (App (eval e -> Abs i a) (eval e -> b)) = eval ((i, b) : e) a
eval e (Var (flip lookup e -> Just v)) = v
eval e (Add (eval e -> LitI a) (eval e -> LitI b)) = LitI $ a + b
eval e (Mul (eval e -> LitI a) (eval e -> LitI b)) = LitI $ a * b
eval _ a = a

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

data Value
  = VLitI Int
  | VFunc (Value -> Value)

instance Show Value where
  show (VLitI i) = show i
  show (VFunc f) = show f

type VEnv = [(String, Value)]

evalAlg :: ExprF (VEnv -> Value) -> VEnv -> Value
evalAlg (AppF fa fb) e | (VFunc a) <- fa e = a (fb e)
evalAlg (AbsF i fb)  e                     = VFunc (\v -> fb ((i,v) : e))
evalAlg (VarF i) e | Just v <- lookup i e  = v
evalAlg (LitIF v) _                        = VLitI v
evalAlg (AddF fa fb) e | VLitI a <- fa e, VLitI b <- fb e = VLitI (a + b)
evalAlg (MulF fa fb) e | VLitI a <- fa e, VLitI b <- fb e = VLitI (a * b)

eval' :: Expr -> Value
eval' x = cata evalAlg x []

litAlg :: ExprF [Int] -> [Int]
litAlg (LitIF v) = [v]
litAlg x = fold x

-- > cata litAlg add1to4
-- [1,4]