Toyプログラムをファイルから読んで実行

import System.Environment (getArgs)

main :: IO ()
main = interact . drive . toy =<< readFile . head =<< getArgs

    get
    print
    stop

    get
    store x
    get
    store y
    load x
    add y
    print
    load x
    sub y
    print
    stop
x   0
y   0

top get
    ifzero bot
    add sum
    store sum
    goto top
bot load sum
    print
    stop
sum 0

% toy toyprog/id.toy
7
7
stopped
% toy toyprog/addsub.toy
7
11
18
-4
stopped
% toy toyprog/sum.toy
1
3
5
7
9
11
0
36
stopped

module Toy where

import Data.Char
import Data.Maybe
import Numeric

type SourceCode = String
type Input  = String
type Output = String

drive :: ([Input] -> [Output]) -> (String -> String)
drive f = unlines . f . lines 

toy :: SourceCode -> ([Input] -> [Output])
toy prog = mapMaybe output . eval . initState (load prog)

output :: ToyState -> Maybe Output
output state = case state of
    (_,_,_,_,out) -> out

load :: SourceCode -> Memory
load prog = (size, mem)
    where
        size      = length proglines
        mem       = cycle (map trans proglines)
        proglines = lines prog

trans :: String -> (Label, Content)
trans s = case break isSpace s' of
    ([], [])       -> error "empty line"
    (lab, content) -> (lab, read content)
    where
        s' = map toUpper s

initState :: Memory -> [Input] -> ToyState
initState mem inputs = (False, mem, 0, inputs, Nothing)

type ToyState = (Final, Memory, Acc, [Input], Maybe Output)
type Final = Bool
type Acc = Int

type Memory = (Int, [(Label, Content)])
type Label = String

data Content
    = Code Code
    | Data Int
    deriving (Show)

instance Read Content where
    readsPrec _ content = case words content of
        [cnt] -> case readSigned readDec cnt of
            [(num,"")] -> [(Data num, "")]
            _          -> [(Code (read cnt, None), "")]
        [op, arg]
              -> [(Code (read op, read arg), "")]
        _     -> []

type Code = (Operator, Operand)

data Operator
    = STOP
    | GET
    | PRINT
    | LOAD
    | STORE
    | ADD
    | SUB
    | GOTO
    | IFZERO
    | IFPOS
    deriving (Show, Read)

data Operand
    = None
    | Num Int
    | Lab Label
    deriving Show

instance Read Operand where
    readsPrec _ s = case words s of
        [oprd] -> case readSigned readDec oprd of
            [(num,"")] -> [(Num num, "")]
            _          -> [(Lab oprd, "")]
        _      -> []

eval :: ToyState -> [ToyState]
eval state = state : rests
    where
        rests | isFinal state = []
              | otherwise     = eval (step state)

isFinal :: ToyState -> Bool
isFinal state@(flg,_,_,_,_) = flg

step :: ToyState -> ToyState
step state = execute (decode (fetch state)) state

type Instruction = ToyState -> ToyState

fetch :: ToyState -> Code
fetch state = case state of
    (_,(_,top:_),_,_,_) -> case top of
        (_,Code code)       -> code
        _                   -> error "not a code"
    _                   -> error "empty memory"

decode :: Code -> Instruction
decode (op,oprd) = case op of
    { STOP   -> iStop
    ; GET    -> iGet
    ; PRINT  -> iPrint
    ; LOAD   -> iLoad
    ; STORE  -> iStore
    ; ADD    -> iAdd
    ; SUB    -> iSub
    ; GOTO   -> iGoto
    ; IFZERO -> iIfzero
    ; IFPOS  -> iIfpos
    } $ oprd

{- $setup
>>> test prog = putStr . drive (toy prog) . unlines 
-}

iStop :: Operand -> Instruction
iStop _ state = case state of
    (_,mem,acc,ins,_) -> (True, mem, acc, ins, Just"stopped")

iGet, iPrint :: Operand -> Instruction
iGet   _ state = case state of
    (flg,mem,_,ins,_) -> (flg, next mem, read (head ins), tail ins, Nothing)

iPrint _ state = case state of
    (flg,mem,acc,ins,_) -> (flg, next mem, acc, ins, Just (show acc))

next :: Memory -> Memory
next (sz, mem) = (sz, tail mem)

iLoad, iStore :: Operand -> Instruction
iLoad oprd state = case state of
    (flg,mem,_,ins,_) -> (flg, next mem, value oprd mem, ins, Nothing)

value :: Operand -> Memory -> Int
value oprd (sz, mem) = case oprd of
    Num num -> num
    Lab lab -> case lookup lab (take sz mem) of
        Just (Data num) -> num
        _               -> error $ "no data labeled " ++ show lab
    _       -> error "no argument"

iStore oprd state = case state of
    (flg,mem,acc,ins,_) -> (flg, next mem' , acc, ins, Nothing)
        where
            mem' = update oprd acc mem

update :: Operand -> Int -> Memory -> Memory
update oprd num (sz, mem) = case oprd of
    Lab lab -> case break ((lab ==) . fst) (take sz mem) of
        (xs,(_,Data _):ys) -> (sz, cycle $ xs ++ (lab, Data num) : ys)
        _                  -> error $ "no data labeled " ++ show lab
    _       -> error "not a label"

iAdd, iSub :: Operand -> Instruction
iAdd oprd state = case state of
    (flg,mem,acc,ins,_) -> (flg, next mem, acc + value oprd mem, ins, Nothing)

iSub oprd state = case state of
    (flg,mem,acc,ins,_) -> (flg, next mem, acc - value oprd mem, ins, Nothing)

iGoto, iIfzero, iIfpos :: Operand -> Instruction
iGoto oprd state = case state of
    (flg,(sz,mem),acc,ins,_) -> case oprd of
        Lab lab -> case break ((lab ==) . fst) (take sz mem) of
            (_,[])  -> error $ "no instruction labeled " ++ show lab
            (xs,ys) -> (flg, (sz, cycle $ ys ++ xs), acc, ins, Nothing)
        _       -> error "iGoto: not a label"

iIfzero = condJump (0 ==)
iIfpos  = condJump (0 <=)

condJump :: (Acc -> Bool) -> Operand -> ToyState -> ToyState
condJump p oprd state = case state of
    (flg,mem,acc,ins,_)
        | p acc     -> iGoto oprd state
        | otherwise -> (flg, next mem, acc, ins, Nothing)

execute :: Instruction -> ToyState -> ToyState
execute = id

{- |
入力した数値をそのまま表示する
>>> test prog00 ["3"]
3
stopped
-}
prog00 :: SourceCode
prog00 = unlines
    [ " get"
    , " print"
    , " stop"
    ]

{- |
2つの入力値の和と差
>>> test prog01 ["4","7"]
11
-3
0
stopped
-}
prog01 :: SourceCode
prog01 = unlines
    [ "  get"
    , "  store x"
    , "  get"
    , "  store y"
    , "  add x"
    , "  print"
    , "  load x"
    , "  sub y"
    , "  print"
    , "  add 3"
    , "  print"
    , "  stop"
    , "x 0"
    , "y 0"
    ]

{- | 
0 が入力されるまで、入力された数値を加算する
>>> test prog02 ["1","2","3","4","0"]
10
stopped
-}
prog02 :: String
prog02 = unlines
    [ "top get"
    , "    ifzero bot"
    , "    add sum"
    , "    store sum"
    , "    goto top"
    , "bot load sum"
    , "    print"
    , "    stop"
    , "sum 0"
    ]