checkpoint: added comment parser

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