Catamorphic Lambda Calculus Interpreter (doodle made while following a tutorial).

Cata.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}

-- https://www.schoolofhaskell.com/user/bartosz/understanding-algebras
-- https://www.michaelpj.com/blog/2018/04/08/catamorphic-lc-interpreter.html

module Cata where

import Control.Monad.Reader

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

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

data ExprF a
  = Ref Int
  | Lam a
  | App a a
  | Num Integer
  deriving Functor

type Expr = Fix ExprF

data Value a
  = Number Integer
  | Closure [Value a] (a (Value a))

instance Show (Value a) where
  show (Number x)    = show x
  show (Closure _ _) = "<closure>"

newtype Env a = Env { unEnv :: Reader [Value Env] a }
  deriving (Functor, Applicative, Monad)

instance MonadReader [Value Env] Env where
  ask     = Env $ ask
  local x = Env . local x . unEnv

eval :: Expr -> Value Env
eval expr = runReader (unEnv (cata algebra expr)) []

algebra :: MonadReader [Value a] a => ExprF (a (Value a)) -> a (Value a)
algebra (Ref x) = do
  env <- ask
  return $ env !! x
algebra (Lam x) = do
  env <- ask
  return $ Closure env x
algebra (App x y) = x >>= \case
  Closure env x' -> do
    y' <- y
    local (const (y':env)) x'
  _ -> undefined
algebra (Num x) = return $ Number x

ref :: Int -> Expr
ref x = Fix $ Ref x

lam :: Expr -> Expr
lam x = Fix $ Lam x

app :: Expr -> Expr -> Expr
app x y = Fix $ App x y

num :: Integer -> Expr
num x = Fix $ Num x

s :: Expr
s = lam $ lam $ lam $ ((ref 2) `app` (ref 0)) `app` ((ref 1) `app` (ref 0))

k :: Expr
k = lam $ lam $ ref 1

i :: Expr
i = lam $ ref 0

-- eval $ i `app` num 10
-- eval $ s `app` k `app` k `app` num 10