このチャプターの目次
出力の見直し (toy13)
前節最後の部分で、トイ・マシンの出力に期待した出力よりも余分な空行が 3 行現れていました。その理由は、状態遷移の各ステップで、必ず出力があるからです。空文字列であっても、文字列があれば、出力になります。
そこで、Maybe を使って出力のあるなしを表現し、出力の収集を工夫しましょう。
toy :: SourceCode -> Interaction
toy prog = mapMaybe output . eval . initState (load prog)
mapMaybe :: (a -> Maybe b) -> [a] -> [b] は Data.Maybe モジュールで定義されています。
import Data.Maybe
output は型シグネチャを変更します
output :: ToyState -> Maybe Output
ToyState および initState の出力フィールドを変更します。
type ToyState = (Final, Memory, Acc, [Input], Maybe Output)
initState :: Memory -> [Intput] -> ToyState
initState mem inputs = (False, mem, 0, inputs, Nothing)
iStop、iGet、iPrint の実装も変更します。
iStop _ state = case state of
(_,mem,acc,ins,_) -> (True,mem,acc,ins,Just "stopped")
iGet _ state = case state of
(flg,mem,acc,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))
テストしてみましょう。
% doctest src/Toy.hs
Examples: 1 Tried: 1 Errors: 0 Failures: 0
Good!
ここまでの Toy モジュール
src/Toy.hs
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 = mapMaybe output . eval . initState (load prog)
output :: ToyState -> Maybe Output
output (_,_,_,_,out) = out
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, Nothing)
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 _ 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 = tail
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
--
{- |
>>> test prog00 ["3"]
3
stopped
-}
test :: SourceCode -> [Input] -> IO ()
test prog = putStr . drive (toy prog) . unlines
prog00 :: SourceCode
prog00 = unlines
[ " get"
, " print"
, " stop"
]