rearranged the dir for github

- removed tools and pdfs
- rearranged the projects dirs
- added md files
- other minor changes

1 files changed, 537 insertions, 0 deletions

diff --git a/JackCompiler.hs b/JackCompiler.hs
new file mode 100644
index 0000000..f651f62
--- /dev/null
+++ b/JackCompiler.hs
@@ -0,0 +1,537 @@
+-- Jack Compiler, as the coursework of Project 11 of Nand2Tetris course (http://nand2tetris.org/).
+-- Author: Yuchen Pei (me@ypei.me)
+-- Date: 2018-01-15
+{-# 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.Char
+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] ()
+-- For variable tables: map name (type, (seg, n))
+-- For the subroutine table: map name (kind, (type, nArgs))
+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']
+alphaNumUnderscoredot = '.':alphaNumUnderscore
+
+parse' parser = parse parser ""
+
+jackReader = 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
+
+
+-- vm writer starts from here
+
+buildCTable :: [JClassVarDec] -> (Table, Int)
+buildCTable xs = go 0 0 Map.empty xs
+  where go n _ t [] = (t, n)
+        go nField nStatic t ((JClassVarDec "field" (ty, jId)):ys) =
+          go (nField + 1) nStatic (Map.insert jId (ty, ("this", 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, (kind, (ty, nArgs))) where
+        nArgs = length args + if kind == "method" then 1 else 0
+
+buildLTable :: Bool -> [JTypeAndId] -> [JTypeAndId] -> Table
+buildLTable isMethod args lcls = 
+  (go "argument" args (if isMethod then 1 else 0) Map.empty) `Map.union` (go "local" lcls 0 Map.empty) where
+    go _ [] _ t = t
+    go kind ((ty, name):xs) n t = go kind xs (n + 1) $ Map.insert name (ty, (kind, n)) t
+       
+--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)
+
+jackCompiler :: Table -> [[Char]] -> [[Char]]
+jackCompiler initTable = vmWriter initTable . fmap (fromRight (JClass "" [] []) . jackReader)
+
+vmWriter :: Table -> [JClass] -> [[Char]]
+vmWriter initTable xs = vClass (buildSRTable xs `Map.union` initTable) <$> xs
+
+vClass :: Table -> JClass -> [Char]
+vClass u (JClass name vars subs) = mconcat $ vSubroutineDec name t u n <$> subs where
+  (t, n) = buildCTable vars
+
+vSubroutineDec :: [Char] -> Table -> Table -> Int -> JSubroutineDec -> [Char]
+vSubroutineDec cName t u n sub = 
+  vFunction (cName ++ "." ++ sName) nLcls ++ kindSpec ++
+  vStatement t s u cName sName 0 stmts where 
+    JSubroutineDec (JSubroutineHeader _ (_, sName) args) (JSubroutineBody lcls stmts) = sub
+    nLcls = length lcls
+    kind = fst $ u Map.! (cName ++ "." ++ sName)
+    s = buildLTable (kind == "method") args lcls
+    kindSpec = if kind == "constructor" 
+      then vNew n 
+      else if kind == "method"
+        then vPush "argument" 0 ++ vPop "pointer" 0
+        else ""
+
+-- data JStatement = JLetStatment JVarId JExpression 
+                -- | JIfStatement JExpression [JStatement] (Maybe [JStatement])
+                -- | JWhileStatment JExpression [JStatement]
+                -- | JDoStatement JSubroutineCall
+                -- | JReturnStatement (Maybe JExpression) 
+
+vStatement _ _ _ _ _ _ [] = ""
+
+-- vExpression: push the result of exp; vPopToVar: pop to the var addr
+
+vStatement t s u cName name n ((JLetStatment var exp):stmts) =
+  vExpression t s u cName exp ++ vPopToVar t s u cName var ++ vStatement t s u cName name n stmts 
+
+vStatement t s u cName name n ((JIfStatement cond thenStmts elseStmts):stmts) =
+  vExpression t s u cName cond ++ vNot ++ vThen thenStmts ++ 
+  maybe (vLabel labelElse) vElse elseStmts ++ vStatement t s u cName name (n + 1) stmts where 
+    labelElse = name ++ ".Else" ++ show n
+    labelEndIf = name ++ ".Endif" ++ show n
+    labelIf = name ++ ".If" ++ show n
+    vThen xs = vIfGoto labelElse ++ vStatement t s u cName labelElse 0 xs
+    vElse xs = vGoto labelEndIf ++ vLabel labelElse ++ 
+               vStatement t s u cName labelIf 0 xs ++ vLabel labelEndIf
+
+vStatement t s u cName name n ((JWhileStatment cond loopStmts):stmts) = 
+  vLabel labelWhile ++ vExpression t s u cName cond ++ vNot ++ vIfGoto labelEndWhile ++ 
+  vStatement t s u cName labelWhile 0 loopStmts ++ vGoto labelWhile ++ 
+  vLabel labelEndWhile ++ vStatement t s u cName name (n + 1) stmts where
+    labelWhile = name ++ ".While" ++ show n
+    labelEndWhile = name ++ ".EndWhile" ++ show n
+
+vStatement t s u cName name n ((JDoStatement subCall):stmts) =
+  vSubroutineCall t s u cName subCall ++ vPop "temp" 0 ++ vStatement t s u cName name n stmts
+
+vStatement t s u cName name n ((JReturnStatement ret):stmts) =
+  maybe (vPush "constant" 0) (vExpression t s u cName) ret ++ vReturn ++
+  vStatement t s u cName name n stmts
+
+-- 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)]
+
+vExpression :: Table -> Table -> Table -> [Char] -> JExpression -> [Char]
+
+vExpression t s _ _ (JIntConst n) = vPush "constant" n
+
+vExpression t s _ _ (JStrConst xs) = 
+  vPush "constant" (length xs) ++ vCall "String.new" 1 ++ mconcat (go <$> xs) where
+    go x = vPush "constant" (ord x) ++ vCall "String.appendChar" 2
+
+vExpression t s _ _ (JKeywordConst x) 
+  | x == "null" || x == "false" = vPush "constant" 0
+  | x == "true" = vPush "constant" 1 ++ vNeg
+  | x == "this" = vPush "pointer" 0
+
+vExpression t s u cName (JExpVar (JVarId name idx)) = vVar t s u cName name idx vPush
+
+vExpression t s u cName (JExpCall subCall) = vSubroutineCall t s u cName subCall
+
+vExpression t s u cName (JExpUna op exp) = vExpression t s u cName exp ++ vOp op
+  where vOp '~' = vNot; vOp '-' = vNeg;
+
+vExpression t s u cName (JExpBin exp xs) = 
+  vExpression t s u cName exp ++ mconcat (go <$> xs) 
+    where go (op, exp) = vExpression t s u cName exp ++ vOp op
+          vOp '+' = vAdd; vOp '-' = vSub; vOp '*' = vMul; vOp '/' = vDiv;
+          vOp '&' = vAnd; vOp '|' = vOr;  vOp '<' = vLt;  vOp '>' = vGt;
+          vOp '=' = vEq;
+
+vPopToVar t s u cName (JVarId name idx) = vVar t s u cName name idx vPop
+
+vVar :: Table -> Table -> Table -> [Char] -> [Char] -> Maybe JExpression -> ([Char] -> Int -> [Char]) -> [Char]
+vVar t s u cName name idx vPushOrPop = 
+  let (seg, n) = getSegN t s name in 
+    case idx of
+      Nothing -> vPushOrPop seg n
+      Just exp -> vPush seg n ++ vExpression t s u cName exp ++ vAdd 
+                       ++ vPop "pointer" 1 ++ vPushOrPop "that" 0
+      
+
+getRecord :: Table -> Table -> [Char] -> ([Char], ([Char], Int))
+getRecord t s name = case Map.lookup name s of
+  Just x -> x
+  Nothing -> t Map.! name
+
+getSegN :: Table -> Table -> [Char] -> ([Char], Int)
+getSegN t s name = snd $ getRecord t s name
+
+getType :: Table -> Table -> [Char] -> [Char]
+getType t s name = fst $ getRecord t s name
+
+-- data JSubroutineCall = JSubroutineCall JIdentifier (Maybe JIdentifier) [JExpression] deriving (Show, Eq)
+vSubroutineCall t s u cName (JSubroutineCall name name' args) = 
+  method ++ mconcat (vExpression t s u cName <$> args) ++ vCall name'' nArgs
+    where 
+      name'' = if name' == Nothing 
+                 then cName ++ "." ++ name
+                 else if head name `elem` ['A' .. 'Z'] 
+                        then name ++ "." ++ fromJust name'
+                        else getType t s name ++ "." ++ fromJust name'
+      -- u is the SRTable
+      (method, nArgs) = 
+         if fst (u Map.! name'') == "method"
+           then if name' == Nothing 
+                  then (vPush "pointer" 0, length args + 1)
+                  else let (seg, n) = getSegN t s name in (vPush seg n, length args + 1)
+           else ("", length args)
+
+vNew n = vPush "constant" n ++ vCall "Memory.alloc" 1 ++ vPop "pointer" 0
+vAdd = "add\n"
+vNot = "not\n"
+vNeg = "neg\n"
+vSub = "sub\n"
+vMul = "call Math.multiply 2\n"
+vDiv = "call Math.divide 2\n"
+vAnd = "and\n"
+vOr = "or\n"
+vLt = "lt\n"
+vGt = "gt\n"
+vEq = "eq\n"
+vReturn = "return\n"
+vLabel xs = "label " ++ xs ++ "\n"
+vGoto xs = "goto " ++ xs ++ "\n"
+vIfGoto xs = "if-goto " ++ xs ++ "\n"
+vFunction xs n = "function " ++ xs ++ " " ++ show n ++ "\n"
+vCall xs n = "call " ++ xs ++ " " ++ show n ++ "\n"
+vPush xs n = "push " ++ xs ++ " " ++ show n ++ "\n"
+vPop xs n = "pop " ++ xs ++ " " ++ show n ++ "\n"
+
+
+-- IO
+
+-- reader of system subroutines' headers
+jClasses :: JackParser [JClass]
+jClasses = many (try $ many jSpace >> jClass)
+
+sysSubroutineTable :: IO Table
+sysSubroutineTable = do
+  x <- readFile "./systemsub.txt"
+  return $ buildSRTable $ head $ rights [parse' jClasses x]
+
+main = do
+  dir <- head <$> getArgs
+  filesWODir <- filter isJackFile <$> listDirectory dir 
+  let jackFiles = (dir++) <$> filesWODir
+  codes <- sequence $ readFile <$> jackFiles
+  initTable <- sysSubroutineTable
+  zipWithM writeFile (chExt <$> jackFiles) (jackCompiler initTable codes)
+    where isJackFile xs = drop (length xs - 5) xs == ".jack"
+          chExt xs = take (length xs - 4) xs ++ "vm"
+          --}
+
+
+--testing
+
+testCompiler :: [[Char]] -> IO ()
+testCompiler xs = do
+  initTable <- sysSubroutineTable
+  print $ jackCompiler initTable xs
+
+testCompiler' :: IO ()
+testCompiler' = do
+  --xs <- readFile "./Square/Square.jack"
+  xs <- readFile "./Pong/Ball.jack"
+  testCompiler [xs]
+
+testReader :: IO ()
+testReader = do
+  --xs <- readFile "./Square/Square.jack"
+  xs <- readFile "./Pong/Ball.jack"
+  --print $ buildSRTable $ rights $ [jackReader $ xs]
+  print $ jackReader $ xs
+
+
+--test reader writer x = let Right y = parse' reader x in writer y
+--test' x = let Right y = parse' jStatement x in vStatement Map.empty Map.empty Map.empty "" 0 [y]
+
+