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
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
|
-- Jack Parser, as the coursework of Project 10 of Nand2Tetris course.
-- Author: Yuchen Pei
{-# LANGUAGE FlexibleContexts #-}
import Text.Parsec.Prim
import Text.Parsec.Char
import Text.Parsec.Combinator
import Data.Functor.Identity
import Data.Either
data JClass = JClass JIdentifier [JClassVarDec] [JSubroutineDec] deriving (Show, Eq)
data JClassVarDec = JClassVarDec JClassVarScope JTypeAndId deriving (Show, Eq)
data JSubroutineDec = JSubroutineDec JSubroutineHeader JSubroutineBody deriving (Show, Eq)
data JSubroutineHeader = JSubroutineHeader JSubroutineType JTypeAndId [JTypeAndId] deriving (Show, Eq)
data JSubroutineBody = JSubroutineBody [JTypeAndId] [JStatement] deriving (Show, Eq)
data JStatement = JLetStatment JLeftVarId JExpression
| JIfStatement JExpression [JStatement] (Maybe [JStatement])
| JWhileStatment JExpression [JStatement]
| JDoStatement JSubroutineCall
| JReturnStatement (Maybe JExpression)
deriving (Show, Eq)
data JExpression = JExpression JTerm [(JBOp, JTerm)] deriving (Show, Eq) -- JBOp can only be one of +-*/&|<>=
data JTerm = JIntConst Int
| JStrConst [Char]
| JKeywordConst [Char] -- can only be true, false, null or this
| JTermVarId JLeftVarId
| JTermCall JSubroutineCall
| JTermExp JExpression
| JUnaryOpTerm JUOp JTerm -- JOp can only be - or ~ here
deriving (Show, Eq)
data JLeftVarId = JLeftVarId JIdentifier (Maybe JExpression) deriving (Show, Eq)
data JSubroutineCall = JSubroutineCall JIdentifier (Maybe JIdentifier) [JExpression] deriving (Show, Eq)
type JBOp = Char
type JUOp = Char
type JIdentifier = [Char]
type JTypeAndId = (JType, JIdentifier)
--type JParameter = JTypeAndId
--type JVarDec = JTypeAndId
type JClassVarScope = [Char]
type JType = [Char]
type JSubroutineType = [Char]
type JackParser = Parsec [Char] ()
binaryOpChars = "+-*/&|<>="
unaryOpChars = "-~"
keywordConstStrs = ["true", "false", "null", "this"]
typeStrs' = ["int", "char", "boolean"]
typeStrs = typeStrs' ++ ["void"]
classVarScopeStrs = ["static", "field"]
subroutineTypeStrs = ["constructor", "function", "method"]
alphaUnderscore = ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['_']
alphaNumUnderscore = alphaUnderscore ++ ['0'..'9']
--str2JType xs = case xs of "int" -> JInt; "char" -> JChar; "boolean" -> JBoolean; "void" -> JVoid;
--str2JClassVarScope xs = case xs of "static" -> JStatic; "field" -> JField;
--str2JSubroutineType xs = case xs of "constructor" -> JConstructor; "function" -> JFunction; "method" -> JMethod;
parse' parser = parse parser ""
jack = parse' jClass
jClass :: JackParser JClass
jClass = do
string "class" >> many1 space
id <- jIdentifier
many space >> char '{'
classVarDecs <- sepBy jClassVarDecs (many space)
subroutineDecs <- sepBy jSubroutineDec (many space)
many space >> char '}'
return $ JClass id (mconcat classVarDecs) subroutineDecs
jBOp :: JackParser JBOp
jBOp = oneOf binaryOpChars
jUOp :: JackParser JUOp
jUOp = oneOf unaryOpChars
jType :: JackParser JType
jType = choice $ string <$> typeStrs
jType' :: JackParser JType
jType' = choice $ string <$> typeStrs'
jClassVarScope :: JackParser JClassVarScope
jClassVarScope = choice $ string <$> classVarScopeStrs
jSubroutineType :: JackParser JSubroutineType
jSubroutineType = choice $ string <$> subroutineTypeStrs
jIdentifier :: JackParser [Char]
jIdentifier = do
x <- oneOf alphaUnderscore
xs <- many $ oneOf alphaNumUnderscore
return $ x:xs
jClassVarDecs :: JackParser [JClassVarDec]
jClassVarDecs = try $ do
scope <- jClassVarScope
many1 space
typeAndIds <- jTypeAndIds
many space >> char ';'
return $ JClassVarDec scope <$> typeAndIds
jVarDecs :: JackParser [JTypeAndId]
jVarDecs =
(string "var" >> many1 space) >> jTypeAndIds <* (many space >> char ';')
jTypeAndId :: JackParser JType -> JackParser JTypeAndId
jTypeAndId p = do
type_ <- p
many1 space
id <- jIdentifier
return (type_, id)
jTypeAndIds :: JackParser [JTypeAndId]
jTypeAndIds = do
type_ <- jType'
many1 space
ids <- sepBy jIdentifier (many space >> char ',' >> many space)
return $ (\x -> (type_, x)) <$> ids
jParameters :: JackParser [JTypeAndId]
jParameters = do
char '(' >> many space
params <- sepBy (jTypeAndId jType') (many space >> char ',' >> many space)
many space >> char ')'
return params
jSubroutineHeader :: JackParser JSubroutineHeader
jSubroutineHeader = do
subtype <- jSubroutineType
many1 space
typeAndId <- jTypeAndId jType
params <- jParameters
return $ JSubroutineHeader subtype typeAndId params
jTerm :: JackParser JTerm
jTerm = choice [jIntConst, jStrConst, jKeywordConst, jTermVarId, jTermCall, jTermExp, jUnaryOpTerm, jTermInBraces]
jIntConst :: JackParser JTerm
jIntConst = JIntConst <$> (read <$> many1 digit)
jStrConst :: JackParser JTerm
jStrConst = JStrConst <$> between (char '"') (char '"') (many $ noneOf "\"")
jKeywordConst :: JackParser JTerm
jKeywordConst = JKeywordConst <$> (choice $ string <$> keywordConstStrs)
jTermVarId :: JackParser JTerm
jTermVarId = JTermVarId <$> jLeftVarId
jLeftVarId :: JackParser JLeftVarId
jLeftVarId = do
id <- jIdentifier
maybeArray <- optionMaybe $ try (char '[' >> jExpression <* char ']')
return $ JLeftVarId id maybeArray
jTermCall :: JackParser JTerm
jTermCall = JTermCall <$> jSubroutineCall
jTermExp :: JackParser JTerm
jTermExp = JTermExp <$> jExpression
jUnaryOpTerm :: JackParser JTerm
jUnaryOpTerm = do
op <- oneOf unaryOpChars
many space
term <- jTerm
return $ JUnaryOpTerm op term
jTermInBraces :: JackParser JTerm
jTermInBraces = between (char '(') (char ')') jTerm
jExpression :: JackParser JExpression
jExpression = do
x <- jTerm
xs <- many jOpAndTerm
return $ JExpression x xs
jOpAndTerm :: JackParser (JBOp, JTerm)
jOpAndTerm = do
op <- many space >> jBOp
term <- many space >> jTerm
return (op, term)
jSubroutineDec :: JackParser JSubroutineDec
jSubroutineDec = do
header <- jSubroutineHeader
many space
body <- jSubroutineBody
return $ JSubroutineDec header body
jSubroutineBody :: JackParser JSubroutineBody
jSubroutineBody = do
char '{' >> many space
varDecs <- sepBy jVarDecs (many space)
stmts <- sepBy jStatement (many space)
many space >> char '}'
return $ JSubroutineBody (mconcat varDecs) stmts
jStatement :: JackParser JStatement
jStatement = choice [jLetStatement, jIfStatement, jWhileStatement, jDoStatement, jReturnStatement]
jLetStatement :: JackParser JStatement
jLetStatement = do
string "let" >> many1 space
leftVarId <- jLeftVarId
many space >> char '=' >> many space
exp <- jExpression
many space >> char ';'
return $ JLetStatment leftVarId exp
jIfStatement = do
string "if" >> many space >> char '(' >> many space
exp <- jExpression
many space >> char ')' >> many space >> char '{' >> many space
stmts <- many jStatement
many space >> char '}'
stmts' <- optionMaybe $ try jElseBlock
return $ JIfStatement exp stmts stmts'
jElseBlock :: JackParser [JStatement]
jElseBlock = do
many space >> string "else" >> many space >> char '{' >> many space
stmts <- many jStatement
many space >> char '}'
return stmts
jWhileStatement :: JackParser JStatement
jWhileStatement = do
string "while" >> many space >> char '(' >> many space
exp <- jExpression
many space >> char ')' >> many space >> char '{' >> many space
stmts <- many jStatement
return $ JWhileStatment exp stmts
jDoStatement :: JackParser JStatement
jDoStatement = do
jCall <- string "do" >> many space >> jSubroutineCall
many space >> char ';'
return $ JDoStatement jCall
jReturnStatement :: JackParser JStatement
jReturnStatement = do
string "return" >> many space
res <- optionMaybe $ try jExpression
many space >> char ';'
return $ JReturnStatement res
jSubroutineCall :: JackParser JSubroutineCall
jSubroutineCall = do
callee <- jIdentifier
method <- optionMaybe $ try (char '.' >> jIdentifier)
char '(' >> many space
exps <- sepBy jExpression (many space >> char ',' >> many space)
many space >> char ')'
return $ JSubroutineCall callee method exps
|