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
|
-- 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
--turingParse :: Stream s Identity Char => Parsec s () (Int, Char, Rule)
--solve1 xs = let (initN, initSt, rule) = fromRight (0, 'A', Map.empty) $ parse turingParse "" xs in
--sum $ run initN 0 initSt [0] rule
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 [JParameter] deriving (Show, Eq)
data JSubroutineBody = JSubroutineBody [JVarDec] [JStatement] deriving (Show, Eq)
data JClassVarScope = JStatic | JField deriving (Show, Eq)
data JType = JInt | JChar | JBoolean | JVoid deriving (Show, Eq)
data JSubroutineType = JConstructor | JFunction | JMethod 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 JackParser = Parsec [Char] ()
type JTypeAndId = (JType, JIdentifier)
type JParameter = JTypeAndId
type JVarDec = JTypeAndId
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 ""
skipSpaces = space >> skipMany space
jack = jClass
jClass :: JackParser JClass
jClass = undefined
jBOp :: JackParser JBOp
jBOp = oneOf binaryOpChars
jUOp :: JackParser JUOp
jUOp = oneOf unaryOpChars
jType :: JackParser JType
jType = fmap str2JType $ choice $ fmap string typeStrs
jType' :: JackParser JType
jType' = fmap str2JType $ choice $ fmap string typeStrs'
jClassVarScope :: JackParser JClassVarScope
jClassVarScope = fmap str2JClassVarScope $ choice $ fmap string classVarScopeStrs
jIdentifier :: JackParser [Char]
jIdentifier = do
x <- oneOf alphaUnderscore
xs <- many $ oneOf alphaNumUnderscore
return $ x:xs
jClassVarDec :: JackParser JClassVarDec
jClassVarDec = do
scope <- jClassVarScope
skipSpaces
typeAndId <- jTypeAndId
many space >> char ';'
return $ JClassVarDec scope typeAndId
jTypeAndId :: JackParser JTypeAndId
jTypeAndId = do
type_ <- jType'
skipSpaces
id <- jIdentifier
return (type_, id)
jParameter = many space >> jTypeAndId <* many space
jSubroutineType :: JackParser JSubroutineType
jSubroutineType = fmap str2JSubroutineType $ choice $ fmap string subroutineTypeStrs
{--
jSubroutineHeader :: JackParser JSubroutineHeader
jSubroutineHeader = do
subtype <- jSubroutineType
skipSpaces
typeAndId <- jTypeAndId
char '('
params <- sepBy jParameter (char ',')
char ')'
--}
|
