stackeval2.hs

data Term
  = Lit Int
  | Pair Term Term
  | Fst Term
  | Snd Term
  | Lam (Term -> Term)
  | App Term Term

instance Show Term where
  show (Lit i) = show i
  show (Pair x y) = "pair(" ++ show x ++ ";" ++ show y ++ ")"
  show (Fst p) = "fst(" ++ show p ++ ")"
  show (Snd p) = "snd(" ++ show p ++ ")"
  show (Lam b) = "lam(...)"
  show (App f x) = "app(" ++ show f ++ ";" ++ show x ++ ")"

data Frame
  = InPairLeft Term
  | InPairRight Term
  | InFst
  | InSnd
  | InAppFun Term
  | InAppArg (Term -> Term)

type Stack = [Frame]

(>>>) :: Stack -> Term -> Term
s >>> Lit i     = s <<< Lit i
s >>> Pair x y  = (InPairLeft y : s) >>> x
s >>> Fst p     = (InFst : s) >>> p
s >>> Snd p     = (InSnd : s) >>> p
s >>> Lam b     = s <<< Lam b
s >>> (App f x) = (InAppFun x : s) >>> f

(<<<) :: Stack -> Term -> Term
[] <<< t                   = t
(InPairLeft y : s) <<< x   = (InPairRight x : s) >>> y
(InPairRight x : s) <<< y  = s <<< Pair x y
(InFst : s) <<< Pair x _   = s >>> x
(InSnd : s) <<< Pair _ y   = s >>> y
(InAppFun x : s) <<< Lam b = (InAppArg b : s) >>> x
(InAppArg b : s) <<< x     = s >>> b x

eval :: Term -> Term
eval t = [] >>> t

main :: IO ()
main = do print (eval ex0)
          print (eval ex1)
          print (eval ex2)
          print (eval ex3)
  where
    ex0 = Fst (Pair (Lit 0) (Lit 1))
      -- fst(pair(0;1)) = 0
    ex1 = App (Lam $ \x -> x) (Lit 2)
      -- app(lam(x.x) ; 2) = 2
    ex2 = App (Lam $ \p -> Fst p) (Pair (Lit 0) (Lit 1))
      -- app(lam(p.fst(p)) ; pair(0;1))
      -- = fst(pair(0;1))
      -- = 0
    ex3 = Pair ex0 ex0