CEK 기계에 기본제공연산 추가¶

type Nm = String

data Exp = Var Nm         -- x
         | App Exp Exp    -- e1 e2
         | Lam Nm Exp     -- \x.e
         | Lit Int        -- n
         | Prm Prim [Exp] -- f(x1,...,xn)
         deriving Show

data Prim = Suc | Add deriving Show

type CEK = (Code,Env,Kont)

data Code = OpE Exp
          | OpV Value
          | OpArg
          | OpCall
          deriving Show
type Env  = [(Nm,Value)]
type Kont = [Frame]

data Value = Vint Int      -- n
           | Clos Exp Env  -- < \x.e, env >
           deriving Show

data Frame = FrV Value   -- (v O)
           | FrE Exp Env -- (O e env)
           | FrP Prim [Value] [Exp] Env -- (f [vi,..] O [ei,...] env)
           deriving Show

lookup' x env = case lookup x env of Just v  -> v
                                     Nothing -> error("x is unknown")

-- 기본제공연산이 호출되었을 때 동작 정의
callPrim Suc [Vint n] = Vint (n+1)
callPrim Add [Vint n2, Vint n1] = Vint (n1+n2)

step :: CEK -> Maybe CEK
step (OpE(Var x),     env, k) = Just (OpV(lookup' x env), env, k)
step (OpE(App e1 e2), env, k) = Just (OpE e1, env, FrE e2 env : k)
step (OpE(e@Lam{}),   env, k) = Just (OpV(Clos e env), env, k)
step (OpE(Lit n),     env, k) = Just (OpV(Vint n), env, k)
-- step (OpE(Prm f es),  env, k) = Just (OpArg, env, FrP f [] es env : k) -- 기본제공연산식 처리 시작
step (OpV v,  env1, FrE e2 env2 : k) = Just (OpE e2, env2, FrV v : k)
step (OpV v,  env1, FrV(Clos (Lam x e) env2) : k) = Just (OpE e, (x,v) : env2, k)
-- step (OpArg,  env1, FrP f vs (e2:es) env2 : k) = undefined -- 다음 인자값 계산
-- step (OpV v,  env1, FrP f vs es env2 : k) = undefined -- 계산된 인자값 프레임에 추가
-- step (OpArg,  env1, FrP f vs [] env2 : k) = undefined -- 다음 인자값 계산 시도하지만 더 이상 인자 없는 경우 처리
-- step (OpCall, env1, FrP f vs [] env2 : k) = Just (OpV(callPrim f vs), env2, k) -- 모든 인자 계산 후 기본제공연산 호출
step _ = Nothing

{-# LANGUAGE FlexibleInstances #-}
import IHaskell.Display
import Data.List (intersperse)

class TeX a where
  toTeX :: a -> String

instance TeX Exp where
  toTeX (Var x) = x
  toTeX (App e1 e2) = "("++toTeX e1++"\\;"++toTeX e2++")" 
  toTeX (Lam x e) = "(\\lambda{}"++x++"."++toTeX e++")"
  toTeX (Lit n) = show n
  toTeX (Prm f es) = "\\textsf{"++show f++"}"++toTeX es

instance TeX Code where
  toTeX (OpE e) = toTeX e
  toTeX (OpV v) = toTeX v
  toTeX (OpArg) = "\\texttt{arg}"
  toTeX (OpCall) = "\\texttt{call}"

instance TeX Value where
  toTeX (Vint n) = show n
  toTeX (Clos e env) = "\\langle{}" ++ toTeX e ++ "," ++ revTeX env ++ "\\rangle{}"

instance TeX Frame where
  toTeX (FrV v) = "("++toTeX v++"\\,\\bigcirc{})"
  toTeX (FrE e env) = "(\\bigcirc{}\\,"++toTeX e++"\\;"++revTeX env++")"
  toTeX (FrP f vs es env) = "(\\textsf{"++show f++"}"++revTeX vs++"\\,\\bigcirc{}\\,"++toTeX es++"\\;"++revTeX env++")"

instance TeX (Nm,Value) where
  toTeX (x,v) = x++"\\mapsto{}"++toTeX v

instance TeX CEK where
  toTeX (c,env,k) = "\\big\\langle{}"
                 ++ toTeX c ++ "\\;\\big|\\;" ++ revTeX env ++ "\\;\\big|\\;" ++ toTeX k
                 ++ "\\big\\rangle{}"

instance TeX a => TeX (Maybe a) where
  toTeX (Just x)= "\\texttt{Just}("++toTeX x++")"
  toTeX Nothing = "\\texttt{Nothing}"

instance TeX a => TeX [a] where
  toTeX xs = "[" ++ (concat . intersperse "," $ map toTeX xs) ++ "]"

revTeX = toTeX . reverse

newtype LaTeX a = LaTeX a

htmlTeX a = html $ "$"++toTeX a++"$"

instance TeX a => IHaskellDisplay (LaTeX a) where
  display (LaTeX a) = return $ Display [htmlTeX a]