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
|
-- 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 = jClass
jClass :: JackParser JClass
jClass = undefined
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
jClassVarDec :: JackParser JClassVarDec
jClassVarDec = do
scope <- jClassVarScope
many1 space
typeAndId <- jVarDec
many space >> char ';'
return $ JClassVarDec scope typeAndId
jTypeAndId :: JackParser JTypeAndId
jTypeAndId = do
type_ <- jType'
many1 space
id <- jIdentifier
return (type_, id)
jParameter :: JackParser JParameter
jParameter = many space >> jTypeAndId <* many space
jSubroutineHeader :: JackParser JSubroutineHeader
jSubroutineHeader = do
subtype <- jSubroutineType
many1 space
typeAndId <- jTypeAndId
char '('
params <- sepBy jParameter (char ',')
char ')'
return $ JSubroutineHeader subtype typeAndId params
jTerm :: JackParser JTerm
jTerm = choice [jIntConst, jStrConst, jKeywordConst, jLeftVarId, 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)
jLeftVarId :: JackParser JTerm
jLeftVarId = do
id <- jIdentifier
maybeArray <- option Nothing $ 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)
jClass :: JackParser JClass
jClass = do
string "class" >> many space >> char '{' >> many space
id <- jIdentifier
many space
classVarDecs <- sepBy jClassVarDec (many space)
subroutineDecs <- sepBy jSubroutineDec (many space)
many space >> char '}'
return $ JClass id classVarDecs subroutineDecs
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 jVarDec (many space)
stmts <- sepBy jStatement (many space)
many space >> char '}'
return JSubroutineBody varDecs stmts
|
