path: root/projects/11/JackCompiler.hs

-- Jack Compiler, as the coursework of Project 11 of Nand2Tetris course.
-- 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
import Debug.Trace

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]