1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
|
module DSL where
import Data.Char (isDigit, isSpace)
import Data.Foldable (foldlM)
import Parsers
------------------------------------------------------------------------------
-- Data types / instances
------------------------------------------------------------------------------
data StackData
= StackInt Integer
| StackBool Bool
instance Show StackData where
show (StackInt x) = show x
show (StackBool True) = "true"
show (StackBool False) = "false"
type Stack = [StackData]
data Intrinsic
-- core stack operations
= I_DUMP
| I_DROP
| I_SWAP
| I_DUP
| I_OVER
| I_ROT
-- core arithmetic operations
| I_PLUS
deriving (Show, Eq)
data Operation
= OpPushData StackData
| OpIntrinsic Intrinsic
deriving (Show)
type Program = [Operation]
data Machine = Machine { ok :: Bool
, stack :: Stack
}
data TokenData
= T_WHITESPACE
| T_INT_LITERAL Integer
| T_INTRINSIC Intrinsic
deriving (Show, Eq)
data DSLToken = DSLToken { tStr :: String -- original text
, tData :: TokenData -- actual data
} deriving (Show)
type DSLLexer = Parser Char DSLToken
type DSLParser = Parser DSLToken
------------------------------------------------------------------------------
-- Lexing
------------------------------------------------------------------------------
buildDSLLexer :: (Parser Char [Char]) -> ([Char] -> TokenData) -> DSLLexer
buildDSLLexer p f = do
str <- p
return DSLToken { tStr=str
, tData=f str
}
intrinsicL :: String -> Intrinsic -> DSLLexer
intrinsicL s i = buildDSLLexer (list s) (const $ T_INTRINSIC i)
wsL :: DSLLexer
wsL = buildDSLLexer (mult1 $ satisfy isSpace) (const T_WHITESPACE)
intLiteralL :: DSLLexer
intLiteralL = buildDSLLexer (mult1 $ satisfy isDigit) (T_INT_LITERAL . read)
mainLexer :: Parser Char [DSLToken]
mainLexer = phrase $ mult1 $ firstOf subLexers
where
subLexers = [wsL] ++ literals ++ intrinsics
literals = [ intLiteralL
]
intrinsics = map (uncurry intrinsicL) [ (".", I_DUMP)
, ("DROP", I_DROP)
, ("SWAP", I_SWAP)
, ("DUP", I_DUP)
, ("OVER", I_OVER)
, ("ROT", I_ROT)
, ("+", I_PLUS)
]
------------------------------------------------------------------------------
-- Parsing
------------------------------------------------------------------------------
wsP :: DSLParser ()
wsP = do
t <- anyToken
case tData t of
T_WHITESPACE -> result ()
_ -> flunk
dataLiteralP :: DSLParser StackData
dataLiteralP = do
t <- anyToken
case tData t of
T_INT_LITERAL x -> result $ StackInt x
_ -> flunk
pushDataP :: DSLParser Operation
pushDataP = OpPushData <$> dataLiteralP
intrinsicP :: DSLParser Operation
intrinsicP = do
t <- anyToken
case tData t of
T_INTRINSIC i -> result $ OpIntrinsic i
_ -> flunk
operationP :: DSLParser Operation
operationP = firstOf [ pushDataP
, intrinsicP
]
programP :: DSLParser Program
programP = do
optional wsP
ops <- operationP `sepBy1` wsP
optional wsP
eof
return ops
stringToProgram :: String -> Maybe Program
stringToProgram str = do
(_, tokens) <- parse mainLexer str
(_, program) <- parse programP tokens
return program
------------------------------------------------------------------------------
-- Intrinsics
------------------------------------------------------------------------------
dump :: Machine -> IO Machine
dump m@Machine{ stack=x:xs } = putStrLn (show x) >> return m{ stack=xs }
dump m = hcf m "DUMP: stack underflow"
drop' :: Machine -> IO Machine
drop' m@Machine{ stack=_:xs } = return m{ stack=xs }
drop' m = hcf m "DROP: stack underflow"
swap :: Machine -> IO Machine
swap m@Machine{ stack=x:y:xs } = return m{ stack=y:x:xs }
swap m = hcf m "SWAP: stack underflow"
dup :: Machine -> IO Machine
dup m@Machine{ stack=x:xs } = return m{ stack=x:x:xs }
dup m = hcf m "DUP: stack underflow"
over :: Machine -> IO Machine
over m@Machine{ stack=x:y:xs } = return m{ stack=y:x:y:xs }
over m = hcf m "OVER: stack underflow"
rot :: Machine -> IO Machine
rot m@Machine{ stack=x:y:z:xs } = return m{ stack=y:z:x:xs }
rot m = hcf m "ROT: stack underflow"
plus :: Machine -> IO Machine
plus m@Machine{ stack=StackInt x:StackInt y:xs } = return m{ stack=StackInt (x + y):xs }
plus m@Machine{ stack=_:_:_ } = hcf m "PLUS: type mis-match"
plus m = hcf m "PLUS: stack underflow"
------------------------------------------------------------------------------
-- Core operations
------------------------------------------------------------------------------
-- "halt and catch fire"
hcf :: Machine -> String -> IO Machine
hcf m msg = putStrLn msg >> return m{ ok=False }
pushData :: Machine -> StackData -> Machine
pushData m@Machine{ stack=xs } x = m{ stack=x:xs }
applyIntrinsic :: Intrinsic -> Machine -> IO Machine
applyIntrinsic I_DUMP = dump
applyIntrinsic I_DROP = drop'
applyIntrinsic I_SWAP = swap
applyIntrinsic I_DUP = dup
applyIntrinsic I_OVER = over
applyIntrinsic I_ROT = rot
applyIntrinsic I_PLUS = plus
------------------------------------------------------------------------------
-- Interpretation
------------------------------------------------------------------------------
newMachine :: Machine
newMachine = Machine { ok=True, stack=[] }
applyOperation :: Machine -> Operation -> IO Machine
-- take no action if a previous step failed
applyOperation m@Machine{ ok=False } _ = return m
applyOperation m (OpPushData x) = return $ pushData m x
applyOperation m (OpIntrinsic i) = applyIntrinsic i m
applyLinear :: Machine -> [Operation] -> IO Machine
applyLinear = foldlM applyOperation
interpret :: Program -> IO ()
interpret p = applyLinear newMachine p >> return ()
interpretFromString :: String -> IO ()
interpretFromString = maybe err interpret . stringToProgram
where
err = putStrLn "Unable to parse program"
interpretFromFile :: FilePath -> IO ()
interpretFromFile path = readFile path >>= interpretFromString
|
