aboutsummaryrefslogtreecommitdiff
path: root/projects/11
diff options
context:
space:
mode:
Diffstat (limited to 'projects/11')
-rw-r--r--projects/11/JackCompiler.hs358
1 files changed, 358 insertions, 0 deletions
diff --git a/projects/11/JackCompiler.hs b/projects/11/JackCompiler.hs
new file mode 100644
index 0000000..566065d
--- /dev/null
+++ b/projects/11/JackCompiler.hs
@@ -0,0 +1,358 @@
+-- Jack Parser, as the coursework of Project 10 of Nand2Tetris course.
+-- Author: Yuchen Pei (me@ypei.me)
+-- Date: 2018-01-11
+{-# 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
+import Control.Monad
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+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 JVarId JExpression
+ | JIfStatement JExpression [JStatement] (Maybe [JStatement])
+ | JWhileStatment JExpression [JStatement]
+ | JDoStatement JSubroutineCall
+ | JReturnStatement (Maybe JExpression)
+ deriving (Show, Eq)
+data JExpression = JIntConst Int
+ | JStrConst [Char]
+ | JKeywordConst [Char] -- can only be true, false, null or this
+ | JExpVar JVarId
+ | JExpCall JSubroutineCall
+ | JExpUna JUOp JExpression -- JOp can only be - or ~ here
+ | JExpBin JExpression [(JBOp, JExpression)]
+ deriving (Show, Eq)
+data JVarId = JVarId JIdentifier (Maybe JExpression) deriving (Show, Eq)
+data JSubroutineCall = JSubroutineCall JIdentifier (Maybe JIdentifier) [JExpression] deriving (Show, Eq)
+
+data ClassTable = C [Char] Table Int deriving (Show, Eq)
+
+type JBOp = Char
+type JUOp = Char
+type JIdentifier = [Char]
+type JTypeAndId = (JType, JIdentifier)
+type JClassVarScope = [Char]
+type JType = [Char]
+type JSubroutineType = [Char]
+type JackParser = Parsec [Char] ()
+type Table = Map [Char] ([Char], [Char], Int)
+
+
+binaryOpChars = "+-*/&|<>="
+unaryOpChars = "-~"
+keywordConstStrs = ["true", "false", "null", "this"]
+primTypeStrs = ["int", "char", "boolean"]
+primTypeStrs' = primTypeStrs ++ ["void"]
+classVarScopeStrs = ["static", "field"]
+subroutineTypeStrs = ["constructor", "function", "method"]
+alphaUnderscore = ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['_']
+alphaNumUnderscore = alphaUnderscore ++ ['0'..'9']
+
+parse' parser = parse parser ""
+
+--jack xs = parse' (many jSpace >> jClass) (replCrWithNl xs)
+jack = parse' (many jSpace >> jClass)
+
+jClass :: JackParser JClass
+jClass = do
+ string "class" >> many1 jSpace
+ id <- jIdentifier
+ 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]
+jClassType = do
+ x <- oneOf ['A' .. 'Z']
+ xs <- many $ oneOf alphaNumUnderscore
+ return $ x:xs
+
+jBOp :: JackParser JBOp
+jBOp = oneOf binaryOpChars
+
+jUOp :: JackParser JUOp
+jUOp = oneOf unaryOpChars
+
+jComment :: JackParser ()
+jComment = jInlineComment <|> jBlockComment
+
+jInlineComment :: JackParser ()
+jInlineComment = return () <*
+ try (string "//" >> manyTill (noneOf "\n\r") endOfLine)
+ --try (string "//" >> manyTill (noneOf "\n") newline)
+
+jSpace :: JackParser ()
+jSpace = (return () <* space) <|> jComment
+
+jBlockComment :: JackParser ()
+jBlockComment = return () <*
+ try (string "/*" >> manyTill anyChar (try $ string "*/"))
+
+jPrimType :: JackParser JType
+jPrimType = choice $ string <$> primTypeStrs
+
+jType :: JackParser JType
+jType = choice [jPrimType, jClassType]
+
+jPrimType' :: JackParser JType
+jPrimType' = choice $ string <$> primTypeStrs'
+
+jType' :: JackParser JType
+jType' = choice [jPrimType', jClassType]
+
+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 = do
+ scope <- jClassVarScope
+ many1 jSpace
+ typeAndIds <- jTypeAndIds
+ many jSpace >> char ';'
+ return $ JClassVarDec scope <$> typeAndIds
+
+jVarDecs :: JackParser [JTypeAndId]
+jVarDecs =
+ (string "var" >> many1 jSpace) >> jTypeAndIds <* (many jSpace >> char ';')
+
+jTypeAndId :: JackParser JType -> JackParser JTypeAndId
+jTypeAndId p = do
+ type_ <- p
+ many1 jSpace
+ id <- jIdentifier
+ return (type_, id)
+
+jTypeAndIds :: JackParser [JTypeAndId]
+jTypeAndIds = do
+ type_ <- jType
+ many1 jSpace
+ ids <- sepBy jIdentifier (try $ many jSpace >> char ',' >> many jSpace)
+ return $ (\x -> (type_, x)) <$> ids
+
+jParameters :: JackParser [JTypeAndId]
+jParameters = do
+ 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 jSpace
+ typeAndId <- jTypeAndId jType'
+ params <- jParameters
+ return $ JSubroutineHeader subtype typeAndId params
+
+jExpression :: JackParser JExpression
+jExpression = jExpBin <|> jTerm
+
+jTerm :: JackParser JExpression
+jTerm = choice [jIntConst, jStrConst, jKeywordConst, jExpCall, jExpVar, jExpUna, jExpInBraces]
+
+jIntConst :: JackParser JExpression
+jIntConst = JIntConst <$> (read <$> many1 digit)
+
+jStrConst :: JackParser JExpression
+jStrConst = JStrConst <$> between (char '"') (char '"') (many $ noneOf "\"")
+
+jKeywordConst :: JackParser JExpression
+jKeywordConst = JKeywordConst <$> (choice $ try <$> string <$> keywordConstStrs)
+
+jExpVar :: JackParser JExpression
+jExpVar = JExpVar <$> jVarId
+
+jVarId :: JackParser JVarId
+jVarId = do
+ id <- jIdentifier
+ maybeArray <- optionMaybe $ try (char '[' >> jExpression <* char ']')
+ return $ JVarId id maybeArray
+
+jExpCall :: JackParser JExpression
+jExpCall = JExpCall <$> jSubroutineCall
+
+jExpUna :: JackParser JExpression
+jExpUna = do
+ op <- oneOf unaryOpChars
+ many jSpace
+ x <- jTerm
+ return $ JExpUna op x
+
+jExpInBraces :: JackParser JExpression
+jExpInBraces = between (char '(') (char ')') jExpression -- expressions like a + () is not allowed
+
+jExpBin :: JackParser JExpression
+jExpBin = try $ do
+ x <- jTerm
+ xs <- many1 jOpAndTerm
+ return $ JExpBin x xs
+
+jOpAndTerm :: JackParser (JBOp, JExpression)
+jOpAndTerm = do
+ op <- many jSpace >> jBOp
+ x <- many jSpace >> jTerm
+ return (op, x)
+
+jSubroutineDec :: JackParser JSubroutineDec
+jSubroutineDec = do
+ header <- jSubroutineHeader
+ many jSpace
+ body <- jSubroutineBody
+ return $ JSubroutineDec header body
+
+jSubroutineBody :: JackParser JSubroutineBody
+jSubroutineBody = do
+ char '{'
+ varDecs <- many $ try (many jSpace >> jVarDecs)
+ stmts <- many $ try (many jSpace >> jStatement)
+ many jSpace >> char '}'
+ return $ JSubroutineBody (mconcat varDecs) stmts
+
+jStatement :: JackParser JStatement
+jStatement = choice [jLetStatement, jIfStatement, jWhileStatement, jDoStatement, jReturnStatement]
+
+jLetStatement :: JackParser JStatement
+jLetStatement = do
+ string "let" >> many1 jSpace
+ leftVarId <- jVarId
+ many jSpace >> char '=' >> many jSpace
+ exp <- jExpression
+ many jSpace >> char ';'
+ return $ JLetStatment leftVarId exp
+
+jIfStatement = do
+ string "if" >> many jSpace >> char '(' >> many jSpace
+ exp <- jExpression
+ many jSpace >> char ')' >> many jSpace >> char '{' >> many jSpace
+ stmts <- many (try $ many jSpace >> jStatement)
+ many jSpace >> char '}'
+ stmts' <- optionMaybe $ try jElseBlock
+ return $ JIfStatement exp stmts stmts'
+
+jElseBlock :: JackParser [JStatement]
+jElseBlock = do
+ many jSpace >> string "else" >> many jSpace >> char '{' >> many jSpace
+ stmts <- many (try $ many jSpace >> jStatement)
+ many jSpace >> char '}'
+ return stmts
+
+jWhileStatement :: JackParser JStatement
+jWhileStatement = do
+ string "while" >> many jSpace >> char '(' >> many jSpace
+ exp <- jExpression
+ many jSpace >> char ')' >> many jSpace >> char '{'
+ stmts <- many (try $ many jSpace >> jStatement)
+ many jSpace >> char '}'
+ return $ JWhileStatment exp stmts
+
+jDoStatement :: JackParser JStatement
+jDoStatement = do
+ jCall <- string "do" >> many jSpace >> jSubroutineCall
+ many jSpace >> char ';'
+ return $ JDoStatement jCall
+
+jReturnStatement :: JackParser JStatement
+jReturnStatement = do
+ string "return" >> many jSpace
+ res <- optionMaybe $ try jExpression
+ many jSpace >> char ';'
+ return $ JReturnStatement res
+
+jSubroutineCall :: JackParser JSubroutineCall
+jSubroutineCall = try $ do
+ callee <- jIdentifier
+ method <- optionMaybe $ try (char '.' >> jIdentifier)
+ args <- emptyArgs <|> someArgs
+ return $ JSubroutineCall callee method args
+
+emptyArgs :: JackParser [JExpression]
+emptyArgs = return [] <* (try $ char '(' >> many jSpace >> char ')')
+
+someArgs :: JackParser [JExpression]
+someArgs = do
+ char '(' >> many jSpace
+ exps <- sepBy jExpression (many jSpace >> char ',' >> many jSpace)
+ many jSpace >> char ')'
+ return exps
+
+
+buildCTable :: [Char] -> [JClassVarDec] -> ClassTable
+buildCTable name xs = go 0 0 Map.empty xs
+ where go n _ t [] = C name t n
+ go nField nStatic t ((JClassVarDec "field" (ty, jId)):ys) =
+ go (nField + 1) nStatic (Map.insert jId (ty, "field", nField) t) ys
+ go nField nStatic t ((JClassVarDec "static" (ty, jId)):ys) =
+ go nField (nStatic + 1) (Map.insert jId (ty, "static", nStatic) t) ys
+
+
+--data JClass = JClass JIdentifier [JClassVarDec] [JSubroutineDec] deriving (Show, Eq)
+buildSRTable :: [JClass] -> Table
+buildSRTable xs = Map.fromList $ mconcat $ go <$> xs where
+ go (JClass cName _ subs) = go' <$> subs where
+ go' (JSubroutineDec (JSubroutineHeader kind (ty, sName) args) _) =
+ (cName ++ "." ++ sName, (ty, kind, length args))
+
+--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)
+
+vSubroutine :: ClassTable -> JSubroutineDec -> [Char]
+vSubroutine cTable sub =
+ "function " ++ name ++ "." ++ sName ++ " " ++ show (nLcls - 1) ++ "\n" ++
+ (if sType == "constructor" vNew cTable else "")
+ mconcat $ vStatement <$> stmts where
+ JSubroutineDec (JSubroutineHeader kind)
+ vNew (C _ _ n) = "push constant " ++ show n ++ "\ncall Memory.alloc 1\n" ++
+ "pop pointer 0\n"
+
+--vClass :: JClass -> [Char]
+--vClass (JClass cName cVars subs) =
+ --vSubroutine (table cName cVars) <$> subs
+
+
+fst3 (x, y, z) = x
+snd3 (x, y, z) = y
+trd3 (x, y, z) = z
+
+{--
+replCrWithNl :: [Char] -> [Char]
+replCrWithNl = fmap cr2nl
+ where cr2nl '\r' = '\n'
+ cr2nl c = c
+ --}
+
+-- IO
+
+{--
+main = do
+ dir <- head <$> getArgs
+ filesWODir <- filter isJackFile <$> listDirectory dir
+ let jackFiles = (dir++) <$> filesWODir
+ codes <- sequence $ readFile <$> jackFiles
+ zipWithM writeFile (chExt <$> jackFiles) (show . jack <$> codes)
+ where isJackFile xs = drop (length xs - 5) xs == ".jack"
+ chExt xs = take (length xs - 4) xs ++ "ast"
+ --}