aboutsummaryrefslogtreecommitdiff
path: root/projects
diff options
context:
space:
mode:
Diffstat (limited to 'projects')
-rw-r--r--projects/10/JackParser.hs131
1 files changed, 78 insertions, 53 deletions
diff --git a/projects/10/JackParser.hs b/projects/10/JackParser.hs
index a2418c0..0138cac 100644
--- a/projects/10/JackParser.hs
+++ b/projects/10/JackParser.hs
@@ -1,11 +1,16 @@
-- Jack Parser, as the coursework of Project 10 of Nand2Tetris course.
--- Author: Yuchen Pei
+-- Author: Yuchen Pei (me@ypei.me)
+-- Date: January 2018
{-# LANGUAGE FlexibleContexts #-}
import Text.Parsec.Prim
import Text.Parsec.Char
import Text.Parsec.Combinator
import Data.Functor.Identity
import Data.Either
+import Data.Maybe
+import Data.List
+import System.Environment
+import System.Directory
data JClass = JClass JIdentifier [JClassVarDec] [JSubroutineDec] deriving (Show, Eq)
data JClassVarDec = JClassVarDec JClassVarScope JTypeAndId deriving (Show, Eq)
@@ -18,7 +23,6 @@ data JStatement = JLetStatment JVarId JExpression
| JDoStatement JSubroutineCall
| JReturnStatement (Maybe JExpression)
deriving (Show, Eq)
---data JExpression = JExpression JTerm [(JBOp, JTerm)] deriving (Show, Eq) -- JBOp can only be one of +-*/&|<>=
data JExpression = JIntConst Int
| JStrConst [Char]
| JKeywordConst [Char] -- can only be true, false, null or this
@@ -26,9 +30,6 @@ data JExpression = JIntConst Int
| JExpCall JSubroutineCall
| JExpUna JUOp JExpression -- JOp can only be - or ~ here
| JExpBin JExpression [(JBOp, JExpression)]
- -- | JTermVarId JLeftVarId
- -- | JTermCall JSubroutineCall
- -- | JTermExp JExpression
deriving (Show, Eq)
data JVarId = JVarId JIdentifier (Maybe JExpression) deriving (Show, Eq)
data JSubroutineCall = JSubroutineCall JIdentifier (Maybe JIdentifier) [JExpression] deriving (Show, Eq)
@@ -36,8 +37,6 @@ 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]
@@ -54,24 +53,18 @@ 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
+ string "class" >> many1 jSpace
id <- jIdentifier
- many space >> char '{'
- --classVarDecs <- sepBy jClassVarDecs (many space)
- classVarDecs <- many $ try (many space >> jClassVarDecs)
- --subroutineDecs <- sepBy jSubroutineDec (many space)
- subroutineDecs <- many $ try (many space >> jSubroutineDec)
- many space >> char '}'
+ many jSpace >> char '{'
+ classVarDecs <- many $ try (many jSpace >> jClassVarDecs)
+ subroutineDecs <- many $ try (many jSpace >> jSubroutineDec)
+ many jSpace >> char '}'
return $ JClass id (mconcat classVarDecs) subroutineDecs
jClassType :: JackParser [Char]
@@ -86,6 +79,20 @@ jBOp = oneOf binaryOpChars
jUOp :: JackParser JUOp
jUOp = oneOf unaryOpChars
+jComment :: JackParser ()
+jComment = jInlineComment <|> jBlockComment
+
+jInlineComment :: JackParser ()
+jInlineComment = return () <*
+ try (string "//" >> manyTill (noneOf "\n") newline)
+
+jSpace :: JackParser ()
+jSpace = (return () <* jSpace) <|> jComment
+
+jBlockComment :: JackParser ()
+jBlockComment = return () <*
+ try (string "/*" >> manyTill anyChar (try $ string "*/"))
+
jPrimType :: JackParser JType
jPrimType = choice $ string <$> primTypeStrs
@@ -113,40 +120,40 @@ jIdentifier = do
jClassVarDecs :: JackParser [JClassVarDec]
jClassVarDecs = do
scope <- jClassVarScope
- many1 space
+ many1 jSpace
typeAndIds <- jTypeAndIds
- many space >> char ';'
+ many jSpace >> char ';'
return $ JClassVarDec scope <$> typeAndIds
jVarDecs :: JackParser [JTypeAndId]
jVarDecs =
- (string "var" >> many1 space) >> jTypeAndIds <* (many space >> char ';')
+ (string "var" >> many1 jSpace) >> jTypeAndIds <* (many jSpace >> char ';')
jTypeAndId :: JackParser JType -> JackParser JTypeAndId
jTypeAndId p = do
type_ <- p
- many1 space
+ many1 jSpace
id <- jIdentifier
return (type_, id)
jTypeAndIds :: JackParser [JTypeAndId]
jTypeAndIds = do
type_ <- jType
- many1 space
- ids <- sepBy jIdentifier (many space >> char ',' >> many space)
+ many1 jSpace
+ ids <- sepBy jIdentifier (many jSpace >> char ',' >> many jSpace)
return $ (\x -> (type_, x)) <$> ids
jParameters :: JackParser [JTypeAndId]
jParameters = do
- char '(' >> many space
- params <- sepBy (jTypeAndId jType) (try $ many space >> char ',' >> many space)
- many space >> char ')'
+ char '(' >> many jSpace
+ params <- sepBy (jTypeAndId jType) (try $ many jSpace >> char ',' >> many jSpace)
+ many jSpace >> char ')'
return params
jSubroutineHeader :: JackParser JSubroutineHeader
jSubroutineHeader = do
subtype <- jSubroutineType
- many1 space
+ many1 jSpace
typeAndId <- jTypeAndId jType'
params <- jParameters
return $ JSubroutineHeader subtype typeAndId params
@@ -181,7 +188,7 @@ jExpCall = JExpCall <$> jSubroutineCall
jExpUna :: JackParser JExpression
jExpUna = do
op <- oneOf unaryOpChars
- many space
+ many jSpace
x <- jTerm
return $ JExpUna op x
@@ -196,23 +203,23 @@ jExpBin = try $ do
jOpAndTerm :: JackParser (JBOp, JExpression)
jOpAndTerm = do
- op <- many space >> jBOp
- x <- many space >> jTerm
+ op <- many jSpace >> jBOp
+ x <- many jSpace >> jTerm
return (op, x)
jSubroutineDec :: JackParser JSubroutineDec
jSubroutineDec = do
header <- jSubroutineHeader
- many space
+ many jSpace
body <- jSubroutineBody
return $ JSubroutineDec header body
jSubroutineBody :: JackParser JSubroutineBody
jSubroutineBody = do
char '{'
- varDecs <- many $ try (many space >> jVarDecs)
- stmts <- many $ try (many space >> jStatement)
- many space >> char '}'
+ varDecs <- many $ try (many jSpace >> jVarDecs)
+ stmts <- many $ try (many jSpace >> jStatement)
+ many jSpace >> char '}'
return $ JSubroutineBody (mconcat varDecs) stmts
jStatement :: JackParser JStatement
@@ -220,48 +227,48 @@ jStatement = choice [jLetStatement, jIfStatement, jWhileStatement, jDoStatement,
jLetStatement :: JackParser JStatement
jLetStatement = do
- string "let" >> many1 space
+ string "let" >> many1 jSpace
leftVarId <- jVarId
- many space >> char '=' >> many space
+ many jSpace >> char '=' >> many jSpace
exp <- jExpression
- many space >> char ';'
+ many jSpace >> char ';'
return $ JLetStatment leftVarId exp
jIfStatement = do
- string "if" >> many space >> char '(' >> many space
+ string "if" >> many jSpace >> char '(' >> many jSpace
exp <- jExpression
- many space >> char ')' >> many space >> char '{' >> many space
+ many jSpace >> char ')' >> many jSpace >> char '{' >> many jSpace
stmts <- many jStatement
- many space >> char '}'
+ many jSpace >> char '}'
stmts' <- optionMaybe $ try jElseBlock
return $ JIfStatement exp stmts stmts'
jElseBlock :: JackParser [JStatement]
jElseBlock = do
- many space >> string "else" >> many space >> char '{' >> many space
+ many jSpace >> string "else" >> many jSpace >> char '{' >> many jSpace
stmts <- many jStatement
- many space >> char '}'
+ many jSpace >> char '}'
return stmts
jWhileStatement :: JackParser JStatement
jWhileStatement = do
- string "while" >> many space >> char '(' >> many space
+ string "while" >> many jSpace >> char '(' >> many jSpace
exp <- jExpression
- many space >> char ')' >> many space >> char '{' >> many space
+ many jSpace >> char ')' >> many jSpace >> char '{' >> many jSpace
stmts <- many jStatement
return $ JWhileStatment exp stmts
jDoStatement :: JackParser JStatement
jDoStatement = do
- jCall <- string "do" >> many space >> jSubroutineCall
- many space >> char ';'
+ jCall <- string "do" >> many jSpace >> jSubroutineCall
+ many jSpace >> char ';'
return $ JDoStatement jCall
jReturnStatement :: JackParser JStatement
jReturnStatement = do
- string "return" >> many space
+ string "return" >> many jSpace
res <- optionMaybe $ try jExpression
- many space >> char ';'
+ many jSpace >> char ';'
return $ JReturnStatement res
jSubroutineCall :: JackParser JSubroutineCall
@@ -272,11 +279,29 @@ jSubroutineCall = try $ do
return $ JSubroutineCall callee method args
emptyArgs :: JackParser [JExpression]
-emptyArgs = return [] <* (try $ char '(' >> many space >> char ')')
+emptyArgs = return [] <* (try $ char '(' >> many jSpace >> char ')')
someArgs :: JackParser [JExpression]
someArgs = do
- char '(' >> many space
- exps <- sepBy jExpression (many space >> char ',' >> many space)
- many space >> char ')'
+ char '(' >> many jSpace
+ exps <- sepBy jExpression (many jSpace >> char ',' >> many jSpace)
+ many jSpace >> char ')'
return exps
+
+-- IO
+parseCodes :: [[Char]] -> [[Char]] -> [Char]
+parseCodes codes = jack <$> codes
+
+lastSplit c xs = (take (prefix - 1) xs, drop prefix xs)
+ where prefix = length xs - (fromJust . elemIndex c . reverse) xs
+
+main = do
+ dir <- head <$> getArgs
+ filesWODir <- filter isJackFile <$> listDirectory dir
+ let jackFiles = (dir++) <$> filesWODir
+ let ofPath = dir ++ (snd $ lastSplit '/' $ init dir) ++ ".ast"
+ let filenames = removeExt <$> filesWODir
+ codes <- sequence $ readFile <$> jackFiles
+ writeFile ofPath $ parseCodes codes filenames
+ where isJackFile xs = drop (length xs - 4) xs == ".jack"
+ removeExt xs = take (length xs - 4) xs