MLC.hs

{-# LANGUAGE GADTs #-} 
{-# LANGUAGE DeriveFunctor #-} 
module MLC where

import Foreign.Ptr

-- machine lambda calculus

data E
  = Var Integer
  | Ctor String [E]
  | App E E
  | Lam E
  | Fix E
  | Case E [Alt E]
  | MInt Integer
  | MFloat Double
  | MRef Pointer
  | MPrim Prim [E] 
    deriving Show

data Alt a = Alt String a
  deriving (Show, Functor)

data Prim = Lt | Add | DivMod | FSin
  deriving Show

data Pointer where
  MkPointer :: Ptr a -> Pointer

instance Show Pointer where
  show _ = "#"

-- big step evaluation, note the result is only in "weak head normal form", lazy.
-- *might not terminate!*
eval :: E -> E
eval arg =
  let e = step arg in
  case e of
    App _ _   -> eval e
    Case _ _  -> eval e
    Fix _     -> eval e
    MPrim _ _ -> eval e
    _         -> e

-- compute expression by 1 step
--   might loop in the presence of prim ops which fully evaluate arguments
step :: E -> E
step e = case e of
  App e1 e2 -> case e1 of
    Lam body  -> sub e2 body
    _         -> App (step e1) e2
  Case scrut alts -> case scrut of
    Ctor c es -> match e c es alts
    _         -> Case (eval scrut) alts
  Fix (Lam body) -> sub e body
  MPrim p args   -> evalPrim p (map eval args)
  _              -> e

-- resolve a pattern match
match e c es [] = e
match e c es (Alt c' e' : alts)
  | c' == "_" = e'
  | c' == c   = foldr (\x ans -> App ans x) e' es
  | otherwise = match e c es alts

-- substitute peg for every hole (de bruijn index 0) in holes
sub :: E -> E -> E
sub peg holes = go 0 holes where
  go i e = case e of
    Var i'
      | i == i'   -> peg
      | otherwise -> e
    Ctor c es -> Ctor c (map (go i) es)
    App e1 e2 -> App (go i e1) (go i e2)
    Case y alts -> Case (go i y) (map (fmap (go i)) alts)
    Lam body -> Lam (go (i+1) body)
    Fix body -> Fix (go i body)
    MPrim p es -> MPrim p (map (go i) es)
    _ -> e

-- implementation of machine primitives
evalPrim p = case p of
  Lt     -> \[MInt x, MInt y] -> if x < y then Ctor "T" [] else Ctor "F" []
  Add    -> \[MInt x, MInt y] -> MInt (x + y)
  DivMod ->
    \[MInt x, MInt y] ->
      let (q,r) = divMod x y
      in Ctor "Pair" [MInt q, MInt r]
  FSin   -> \[MFloat x] -> MFloat (sin x)