Quick implementation of CBV evaluation for lambda calculus + some primitives + fix.

interp.hs

{-# OPTIONS_GHC -Wincomplete-patterns #-}
module Main where

{- Quick implementation of CBV evaluation for lambda calculus + some primitives + fix. -}
data BinOp = Add | Mul
  deriving Show

evalBinOp :: BinOp -> Int -> Int -> Int
evalBinOp Add = (+)
evalBinOp Mul = (*)

data Term
  = Abs Term
  | App Term Term
  | Var Int
  | Fix Term
  | IntLit Int
  | Bin BinOp Term Term
  | Dec Term
  | If0 {- cond -} Term {- then -} Term {- else -} Term
  deriving Show

data Val
  = Closure [Val] Term
  | IntVal Int

-- Avoid infinite loops when showing infinite closures with a custom Show instance.

-- instance Show Val where
--   show (IntVal i) = "IntVal " ++ show i
--   show (Closure env t) = "Closure <env> " ++ show t

app_prec = 10

instance Show Val where
  showsPrec d (IntVal i) =
    showParen (d > app_prec) $ showString "IntVal " . showsPrec (app_prec + 1) i
  showsPrec d (Closure env t) =
    showParen (d > app_prec) $
    -- TODO: hacky attempt at showing part of the environment, minus the cycle. For debugging only.
    -- showString "Closure [<envHead>] " . showsPrec app_prec (tail (tail env)) . showString " " .
    showString "Closure <env> " .
    showsPrec (app_prec + 1) t

type Env = [Val]

eval :: Env -> Term -> Val
eval env = go where
  go (IntLit pv) = IntVal pv
  go (Var n) = env !! n
  go (Abs t) = Closure env t
  go (Fix t) =
    let Closure tEnv tBody = go t
        res = Closure (res : tEnv) tBody
    in res
  go (App ft at) =
    let av = go at
        Closure fEnv fBody = go ft
    in eval (av : fEnv) fBody
  go (Bin op t1 t2) =
    let IntVal v1 = go t1
        IntVal v2 = go t2
    in IntVal $ evalBinOp op v1 v2
  go (Dec t) =
    let IntVal v = go t
    in IntVal $ v - 1
  go (If0 c t e) =
    let IntVal cv = go c in
    if cv == 0 then
      go t
    else
      go e

-- Example term.
fact :: Term
fact = Fix (Abs factBody)
  where
    factParam = Var 1
    nParam = Var 0
    factBody =
      If0 nParam
        (IntLit 0) $
        If0 (Dec nParam)
          (IntLit 1)
          (Bin Mul nParam (App factParam (Dec nParam)))

main =
  print $ eval [] . App fact . IntLit <$> [0..10]