Sestoft Lazy Abstract Machine

AbstractMachine.hs

import qualified Data.Map.Strict as Map

data Exp = Var String | Lam String Exp | App Exp String | Let String Exp Exp
  | Con String [String] | Case Exp (Map.Map String ([String], Exp))
  deriving Show

data State = State Heap Control Environment Stack deriving Show

data Heap = Heap !Int !(Map.Map String (Exp, Environment)) deriving Show
type Control = Exp
type Environment = Map.Map String String
type Stack = [StackEl]

data StackEl = SVar String | AVar String | SCases !(Map.Map String ([String], Exp)) Environment deriving Show

alloc :: Heap -> (String, Heap)
alloc (Heap i m) = (show i, Heap (i + 1) m)

set :: Heap -> String -> Exp -> Environment -> Heap
set (Heap i m) p e ev = Heap i (Map.insert p (e, ev) m)

get :: Heap -> String -> (Exp, Environment)
get (Heap _ m) p = m Map.! p

machine :: State -> Maybe State
-- app 1
machine (State g (App e x) ev s) = let p = ev Map.! x in
  Just $ State g e         ev (SVar p : s)
-- app 2
machine (State g (Lam y e) ev                  (SVar p : s)) = 
  Just $ State g e         (Map.insert y p ev) s 
-- var 1
machine (State g (Var x) ev  s) = let p = ev Map.! x; (e', ev') = get g p in
  Just $ State g e'     ev' (AVar p : s) 
-- var 2
machine (State g              e@Lam{} ev (AVar p : s)) =
  Just $ State (set g p e ev) e       ev s 
-- let
machine (State g                (Let x e e') ev  s) = let (p, g') = alloc g; ev' = Map.insert x p ev in 
  Just $ State (set g' p e ev') e'           ev' s
-- case 1
machine (State g (Case e alts) ev s) =
  Just $ State g e ev (SCases alts ev : s)
-- case 2
machine (State g (Con c xs) ev' (SCases alts ev : s)) = let (ys, ek) = alts Map.! c; ps = map (ev' Map.!) xs in
  Just $ State g ek (Map.union ev (Map.fromList (zip ys ps))) s
-- var 3
machine (State g e@Con{} ev' (AVar p : s)) =
  Just $ State (set g p e ev') e ev' s
-- halt
machine _ = Nothing

loop :: State -> State
loop x = maybe x loop $ machine x