krivines-machine.hs

{-# LANGUAGE TemplateHaskell #-}

import Control.Lens
import Control.Monad.Trans
import Control.Monad.State
import Data.Maybe

data Instr = Access Int
           | Closure Code
           | Apply
           | Return
           deriving Show

newtype Lambda = Lambda (Code, Env) deriving Show
type Code  = [Instr]
type Env   = [Lambda]
type Stack = [Lambda]

data VMState = VMState
               { _code :: Code
               , _env  :: Env
               , _stack :: Stack
               } deriving Show

makeLenses ''VMState

type VM = StateT VMState IO Lambda

run :: VM
run = do
  hd <- uses code listToMaybe
  case hd of
    Just instr -> code %= tail >> exec instr >> run
    Nothing -> ret
  where
    ret = uses stack head
    exec (Access n) = do
      x <- uses env (!!n)
      stack %= (x:)
    exec (Closure c') = do
      e <- use env
      stack %= (Lambda (c', e):)
    exec Apply = do
      c <- use code
      e <- use env
      (u : Lambda (c', e'): s) <- use stack
      code %= const c'
      env %= const (u:e')
      stack %= const (Lambda (c, e):s)
    exec Return = do
      (u : Lambda (c', e') : s) <- use stack
      code %= const c'
      env %= const e'
      stack %= const (u:s)

zeroCode = Closure [Closure [Access 0, Return], Return]
oneCode = Closure [Closure [Access 0, Access 1, Apply, Return], Return]
twoCode = Closure [Closure [Access 0, Access 1, Apply, Access 0, Access 1, Apply, Return], Return]
trueCode = Closure [Closure [Access 1, Return], Return]
falseCode = Closure [Closure [Access 0, Return], Return]

main = do
  print =<< (runStateT run $ VMState [trueCode, oneCode, Apply, twoCode, Apply] [] [])
  print =<< (runStateT run $ VMState [falseCode, oneCode, Apply, twoCode, Apply] [] [])