From 432e4142e53dc10ff3ba1527cacb7d833c0ebb77 Mon Sep 17 00:00:00 2001
From: Yuchen Pei <me@ypei.me>
Date: Thu, 11 Jan 2018 16:36:38 +0100
Subject: checkpoint.

---
 projects/11/JackCompiler.hs | 358 ++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 358 insertions(+)
 create mode 100644 projects/11/JackCompiler.hs

(limited to 'projects/11')

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"
+          --}
-- 
cgit v1.2.3