SECD2.hs

-- An implementation of Peter Landin's SECD machine, as described in
-- "The Mechanical Evaluate of Expressions"
import Prelude hiding (lookup)

type Name = String

data Expr a = ID Name
            | Obj a
            | Fun Name (Expr a)
            | Apply (Expr a) (Expr a)
            deriving (Eq, Show)
            
data Value a = S Name
             | Closure Name (Expr a) (Environment a)
             | PrimFunc Name (Value a -> Value a)
             | V a

instance Eq a => Eq (Value a) where
  S n == S m = m == n
  V a == V b = a == b
  _   == _   = False

instance Show a => Show (Value a) where
  show (S n)           = "S " ++ show n
  show (Closure _ _ _) = "#<Closure>"
  show (PrimFunc f _)  = "#<primfunc " ++ f ++ ">"
  show (V a)           = "V " ++ show a
    
             
type Stack a = [Value a]

type Environment a = [(Name, Value a)]

data Controllee a = AP
                  | AE (Expr a)
                  deriving (Show)

type Control a = [Controllee a]

data Dump a = Dump (Stack a) (Environment a) (Control a) (Dump a)
            | InitState
            deriving (Show)

lookup :: Name -> Environment a -> Value a
lookup n [] = error $ "Not found: "
lookup n ((k,v):kvs)
  | n == k    = v
  | otherwise = lookup n kvs

transform :: Stack a -> Environment a -> Control a -> Dump a -> Value a
transform (s:_) e [] InitState           = s
transform (s:ss) e [] (Dump s' e' c' d') = transform (s:s') e' c' d'
transform s e (AE (ID i):cs) d           = transform (lookup i e : s) e cs d
transform s e (AE (Obj o):cs) d          = transform (V o : s) e cs d
transform s e (AE (Fun n b) : cs) d      = transform (Closure n b e : s) e cs d
transform s e (AE (Apply op arg) : cs) d = transform s e (AE arg : AE op : AP : cs) d
transform (Closure n b e' : s2 : ss) e (AP : cs) d = transform [] e'' [AE b] d'
  where e'' = (n, s2) : e'
        d'  = Dump ss e cs d
transform (PrimFunc _ f:s2:ss) e (AP : cs) d = transform (f s2:ss) e cs d
transform _ _ _ _ = error "crash"

runSECD' :: Environment a -> [Expr a] -> Value a
runSECD' initEnv es = transform [] initEnv initControl InitState
  where initControl = map AE es

runSECD :: [Expr a] -> Value a
runSECD = runSECD' []

test1 = runSECD [Apply (Fun "x" (ID "x")) (Obj 3)] == V 3
test2 = runSECD [Apply (Fun "x" (ID "x")) $ Apply (Fun "x" (ID "x")) (Obj 3)] == V 3
test3 = runSECD [Apply (Apply (Fun "x" (ID "x")) (Fun "x" (ID "x")))  (Obj 3)]  == V 3


liftPrim :: Name -> (a -> a) -> Value a
liftPrim name f = PrimFunc name f'
  where f' (V a) = V (f a)
        f' _     = error $ "primitive error: " ++ name

liftPrim2 :: Name -> (a -> a -> a) -> Value a
liftPrim2 name f = PrimFunc name f'
  where f' (V a) = PrimFunc (name ++ "(partial)") (g' a)
        f' _     = error $ "primitive error: " ++ name
        g' a (V b) = V (f a b)
        g' _ _     = error $ "primitive error: " ++ name

intEnv = [("succ", liftPrim "succ" (\x -> x + 1)),
          ("pred", liftPrim "pred" (\y -> y - 1)),
          ("+", liftPrim2 "+" (+)),
          ("-", liftPrim2 "-" (-)),
          ("*", liftPrim2 "*" (*))]

test4 = runSECD' intEnv [Apply (ID "succ") $ Apply (ID "succ") (Obj 3)] == V 5
test5 = runSECD' intEnv [Apply fun1 fun2] == V 5
  where fun1 = (Fun "g" (Apply (Apply (ID "-") (Apply (ID "g") (ID "*")))
                               (Apply (ID "g") (ID "+"))))
        fun2 = (Fun "f" (Apply (Apply (ID "f") (Obj 3)) (Obj 4)))

runTests = and [test1,test2,test3, test4, test5]