デコードの実装

module Toy where

import Data.Char
import Numeric

type SourceCode  = String
type Interactive = [Input] -> [Output]
type Input  = String
type Output = String

drive :: Interactive -> (String -> String)
drive f = unlines . f . lines

toy :: SourceCode -> Interactive
toy prog = map output . eval . initState (load prog)

output :: ToyState -> Output
output = undefined

load :: SourceCode -> Memory
load = cycle . map trans . lines

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

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

type Memory = [(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, "")]
        _      -> []

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

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

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

type Instruction = ToyState -> ToyState

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

-- 

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

iStop :: Operand -> Instruction
iStop _ = undefined

iGet, iPrint :: Operand -> Instruction
iGet   _ = undefined
iPrint _ = undefined

iLoad, iStore :: Operand -> Instruction
iLoad _  = undefined
iStore _ = undefined

iAdd, iSub :: Operand -> Instruction
iAdd oprd = undefined
iSub oprd = undefined

iGoto, iIfzero, iIfpos :: Operand -> Instruction
iGoto oprd   = undefined
iIfzero oprd = undefined
iIfpos oprd  = undefined

--

execute :: Instruction -> Instruction
execute = id