Javascript backend using jison

source/src/BNFC/Backend/Javascript.hs

@@ -0,0 +1,31 @@
+module BNFC.Backend.Javascript (makeJavascript) where
+
+import Text.Printf
+
+import BNFC.CF
+import BNFC.Options
+
+import BNFC.Backend.Base
+import BNFC.Backend.Javascript.CFtoJSLex
+import BNFC.Backend.Javascript.CFtoJison
+import BNFC.Backend.Javascript.CFtoJSPrinter
+import BNFC.Backend.Javascript.CFtoJSSkeleton
+import BNFC.Backend.Javascript.CFtoJS
+import qualified BNFC.Backend.Common.Makefile as Makefile
+
+makeJavascript :: SharedOptions -> CF -> MkFiles ()
+makeJavascript opts cf = do
+    let (lex, env) = cf2jsLex cf
+    mkfile (name ++ ".jisonlex") lex
+    mkfile (name ++ ".jison") (cf2Jison name cf env)
+    mkfile ("Printer" ++ name ++ ".js") (jSPrinter cf env)
+    mkfile ("Skeleton" ++ name ++ ".js") (jSSkeleton cf env)
+    mkfile ("Test" ++ name ++ ".js") (jSTest name)
+    Makefile.mkMakefile opts (makefile name)
+    where name = lang opts
+
+makefile :: String -> String
+makefile name = unlines $ [
+        printf "Parser%s.js: %s.jison %s.jisonlex" name name name
+        , printf "\tjison %s.jison %s.jisonlex -o Parser%s.js" name name name
+    ]

source/src/BNFC/Backend/Javascript/CFtoJS.hs

@@ -0,0 +1,27 @@
+module BNFC.Backend.Javascript.CFtoJS (jSTest) where
+
+import Text.Printf
+
+jSTest :: String -> String
+jSTest name = unlines $ [
+        printf "var parser = require('./Parser%s').parser;" name
+        , "var fs = require('fs');"
+        , printf "var Printer = require('./Printer%s').Visitor;\n" name
+        , "function abstractTree(file) {"
+        , "\tvar input = fs.readFileSync(file, 'utf-8');"
+        , "\tvar tree = parser.parse(input);"
+        , "\tconsole.log(JSON.stringify(tree));"
+        , "}\n"
+        , "function normalizedTree(file) {"
+        , "\tvar input = fs.readFileSync(file, 'utf-8');"
+        , "\tvar tree = parser.parse(input);"
+        , "\tvar printer = new Printer()"
+        , "\tprinter.visit(tree);"
+        , "\tconsole.log(printer.text);"
+        , "}\n"
+        , "console.log('[Abstract Tree]\\n');"
+        , "abstractTree(process.argv[2]);"
+        , "console.log('\\n');"
+        , "console.log('[Linearized Tree]\\n');"
+        , "normalizedTree(process.argv[2]);"
+    ]

source/src/BNFC/Backend/Javascript/CFtoJSLex.hs

@@ -0,0 +1,80 @@
+module BNFC.Backend.Javascript.CFtoJSLex (cf2jsLex) where
+
+import Data.List
+import Text.Printf
+import Data.Maybe
+
+import BNFC.CF
+import BNFC.Backend.Common.NamedVariables
+
+import BNFC.Backend.Javascript.RegToJSLex
+
+cf2jsLex :: CF -> (String, SymEnv)
+cf2jsLex cf = (unlines [
+        macros
+        , jsLex $ (userComments cf)
+                  ++ (userSymbols env)
+                  ++ (userTokens env' cf)
+                  ++ defaultTokens cf
+    ], env')
+    where
+       env = makeSymEnv tokens (0 :: Int)
+       env' = env ++ (makeSymEnv pragmas (length env))
+       pragmas = map show $ fst (unzip (tokenPragmas cf))
+       makeSymEnv [] _ = []
+       makeSymEnv (s:symbs) n = (s, "SYMB" ++ (show n)) : (makeSymEnv symbs (n+1))
+       -- The longest tokens first
+       tokens = sortBy (\a b -> compare (length b) (length a)) (map fst $ cfTokens cf)
+
+macros :: String
+macros = unlines [
+      "letter [a-zA-Z]"
+      , "capital [A-Z]"
+      , "small [a-z]"
+      , "digit [0-9]"
+      , "ident [a-zA-Z0-9\"_\"]"
+    ]
+
+jsLex :: [(Int, String -> String)] -> String
+jsLex s = unlines [
+      "/* Lexical grammar generated by BNFC */"
+      , "%%"
+      , concatMap (\(i, f) -> f $ spaces (maxDef - i)) s
+    ]
+    where maxDef = 1 + (maximum $ map fst s)
+          spaces i = replicate i ' '
+
+userComments :: CF -> [(Int, String -> String)]
+userComments cf = (map (indent . single) s) ++ (map (indent . multi) m)
+    where (m, s) = comments cf
+          single a = printf "\"%s\"[^\\n]*" a
+          multi (a, b) = printf "\"%s\"(.|\\n|\\r)*?\"%s\"" a b
+          indent a = (length a, \t -> printf (a ++ "%s/* comment */\n") t)
+
+userSymbols :: SymEnv -> [(Int, String -> String)]
+userSymbols se = map userSymbol se
+    where
+        userSymbol (s, r) = let e = quote s in (length e, \t -> printf "%s%sreturn '%s'\n" e t r)
+        quote s = "\"" ++ (concatMap escape s) ++ "\""
+        escape c = if c == '\\' then '\\':[c] else [c]
+
+userTokens :: SymEnv -> CF -> [(Int, String -> String)]
+userTokens se cf = map userToken $ tokenPragmas cf
+    where userToken (name, exp) = let s = (printRegJSLex exp) in
+                                   (length s, \t -> printf "%s%sreturn '%s'\n"
+                                                     s t (symb $ show name))
+          symb name = fromJust $ lookup name se
+
+defaultTokens :: CF -> [(Int, String -> String)]
+defaultTokens cf = special ++ [
+        (3, \t -> printf "\\s+%s/* skip whitespace */\n" t)
+        , (7, \t -> printf "<<EOF>>%sreturn 'EOF'\n" t)
+        , (1, \t -> printf ".%sreturn 'INVALID'\n" t)
+    ]
+    where special =
+            ifC "Double" "{digit}+\".\"{digit}+" "return 'DOUBLE'"
+            ++ ifC "Ident" "{letter}{ident}*" "return 'IDENT'"
+            ++ ifC "Integer" "{digit}+" "return 'INTEGER'"
+            ++ ifC "Char" "\\'(?:[^'\\\\]|\\\\.)*\\'" "yytext = yytext.substr(1,yyleng-2); return 'CHAR'"
+            ++ ifC "String" "\\\"(?:[^\"\\\\]|\\\\.)*\\\"" "yytext = yytext.substr(1,yyleng-2); return 'STRING'"
+          ifC cat s r = if isUsedCat cf (TokenCat cat) then [(length s, \t -> printf (s++"%s"++r++"\n") t)] else []

source/src/BNFC/Backend/Javascript/CFtoJSPrinter.hs

@@ -0,0 +1,114 @@
+module BNFC.Backend.Javascript.CFtoJSPrinter (jSPrinter) where
+
+import Data.List
+import Data.Either
+import Text.Printf
+
+import BNFC.CF
+import BNFC.Backend.Common.NamedVariables
+
+jSPrinter :: CF -> SymEnv -> String
+jSPrinter cf _ = unlines [
+    "var Visitor = exports.Visitor = function () {"
+    , "\tthis.text = '';"
+    , "\tthis.indent = 0;"
+    , "};\n"
+    , "Visitor.prototype.visit = function (node) {"
+    , "\treturn this[node.type](node);"
+    , "};\n"
+    , "Visitor.prototype.addIndent = function () {"
+    , "\tthis.text += Array(this.indent + 1).join('\\t');"
+    , "};\n"
+    , "Visitor.prototype.removeIndent = function () {"
+    , "\tif (this.text.substr(-1) == '\\t') this.text = this.text.slice(0, -1);"
+    , "};\n"
+    , "Visitor.prototype.visitPrec = function (node1, node2) {"
+    , printf "\tvar levels = { %s };" $ jSLevels $ jSNames cf
+    , "\tif (levels[node1.type] > levels[node2.type]) this.text += '(';"
+    , "\tthis.visit(node2);"
+    , "\tif (levels[node1.type] > levels[node2.type]) {"
+    , "\t\tif (this.text.substr(-1) == ' ') this.text = this.text.slice(0, -1);"
+    , "\t\tthis.text += ')';"
+    , "\t}"
+    , "};\n"
+    , intercalate "\n\n" $ jSMethods $ jSNames cf
+  ]
+
+
+jSLevels :: [Either String Rule] -> String
+jSLevels = intercalate ", " . (map level) . rights
+    where level r = printf "\"%s\": %d" (funRule r) (precRule r)
+
+jSNames :: CF -> [Either String Rule]
+jSNames cf = rules ++ tokens
+    where rules  = map Right $ filter remove $ concatMap snd $ ruleGroups cf
+          tokens = map (Left . show . fst) $ tokenPragmas cf
+          remove r = let x = funRule r in not $ isCoercion x
+
+jSMethods :: [Either String Rule] -> [String]
+jSMethods rs = map method rs
+    where
+        method r = printf "Visitor.prototype.%s = function (node) {\n%s\n};"
+                    (name r) (jSAction r)
+        name = either id ruleName
+
+ruleName :: Rule -> String
+ruleName r
+    | isNilFun (funRule r) = (cat r) ++ "Nil"
+    | isOneFun (funRule r) = (cat r) ++ "One"
+    | isConsFun (funRule r) = (cat r) ++ "Cons"
+    | otherwise = funRule r
+    where cat = identCat . valCat
+
+jSAction :: Either String Rule -> String
+jSAction (Left _) = "\tthis.text += node.args[0] + ' ';" -- Tokens
+jSAction (Right r) -- Rules
+    | isList (valCat r) = intercalate "\n" $ map f ts
+    | otherwise = intercalate "\n" $ map f cs
+    where cs = jSArgs 0 $ rhsRule r
+          ts = map (\l -> (0, Right l)) $ rights $ rhsRule r
+          f = uncurry (jSRhs $ precCat (valCat r))
+
+-- Arguments numbers, skip tokens as they are not in the argument array
+jSArgs :: Integer -> [Either Cat String] -> [(Integer, Either Cat String)]
+jSArgs _ [] = []
+jSArgs i (Left c:xs)  = (i, Left c):jSArgs (i+1) xs
+jSArgs i (Right s:xs) = (0, Right s):jSArgs i xs
+
+jSRhs :: Integer -> Integer -> Either Cat String -> String
+jSRhs _ 0 (Right s) -- User tokens
+    | s `elem` norspace = printf "\tthis.text += '%s';" (escape s)
+    | s `elem` nolspace = pop ++ (printf "\tthis.text += '%s '" (escape s))
+    | s == ";" = "\tthis.text += ';\\n'; this.addIndent();"
+    | s == "{" = "\tthis.text += '{\\n'; this.indent++; this.addIndent();"
+    | s == "}" = "\tthis.indent--; this.removeIndent(); this.text += '}\\n'; this.addIndent();"
+    | otherwise = printf "\tthis.text += '%s ';" (escape s)
+    where norspace = ["[", "("]
+          nolspace = ["]", ")", ","]
+          pop = unlines $ [
+            "\tif (this.text.substr(-1) === ' ')"
+            , "\t\tthis.text = this.text.slice(0, -1);"
+            ]
+jSRhs _ i (Left c) -- Cats
+    | isList c = printf listStr i i cat i cat cat i cat -- so many arguments ...
+    | (show c) `elem` specialCatsP = case (show c) of
+                                    "String" -> printf "\tthis.text += '\"' + node.args[%d] + '\" '" i
+                                    "Char" -> printf "\tthis.text += '\\'' + node.args[%d] + '\\' '" i
+                                    _ -> printf "\tthis.text += node.args[%d] + ' '" i
+    | otherwise = printf "\tthis.visitPrec(node, node.args[%d]);" i
+    where listStr = unlines $ [
+            "\tfor (var i=0; i < node.args[%d].length; i++) {"
+            , "\t\t" ++ action
+            , "\t\tif (this.%sCons && i+1 < node.args[%d].length) this.%sCons();"
+            , "\t\tif (!this.%sOne && i+1 == node.args[%d].length) this.%sCons();"
+            , "\t}"
+            ]
+          action = if (show $ catOfList c) `elem` specialCatsP
+                    then "\tthis.text += node.args[%d][i] + ' ';"
+                    else "\tthis.visitPrec(node, node.args[%d][i]);"
+          cat = identCat c
+jSRhs _ _ _ = error "unknown rhs"
+
+-- | Helpers
+escape s = concatMap (\c -> if c `elem` chars then '\\':[c] else [c]) s
+    where chars = "'"

source/src/BNFC/Backend/Javascript/CFtoJSSkeleton.hs

@@ -0,0 +1,37 @@
+module BNFC.Backend.Javascript.CFtoJSSkeleton (jSSkeleton) where
+
+import Data.List
+import Data.Either
+import Text.Printf
+
+import BNFC.CF
+import BNFC.Backend.Common.NamedVariables
+
+jSSkeleton :: CF -> SymEnv -> String
+jSSkeleton cf _ = unlines [
+    "var Visitor = exports.Visitor = function () {"
+    , "};\n"
+    , "Visitor.prototype.visit = function (node) {"
+    , "\treturn this[node.type](node);"
+    , "};\n"
+    , intercalate "\n\n" $ jSMethods $ jSNames cf
+  ]
+
+jSNames :: CF -> [Either String Rule]
+jSNames cf = rules ++ tokens
+    where rules  = map Right $ filter remove $ concatMap snd $ ruleGroups cf
+          tokens = map (Left . show . fst) $ tokenPragmas cf
+          remove r = let x = funRule r
+                      in not $ isCoercion x || isConsFun x
+                               || isOneFun x || isNilFun x
+
+jSMethods :: [Either String Rule] -> [String]
+jSMethods rs = map method rs
+    where method r = printf "Visitor.prototype.%s = function (node) {\n%s\n};"
+                      (name r) (jSAction r)
+          name = either id funRule
+
+jSAction :: Either String Rule -> String
+jSAction (Left _) = "return new Error(\"failure\");"
+jSAction (Right r) = printf "\t// args: %s\n\treturn new Error(\"failure\")"
+                      (intercalate ", " $ map show $ lefts $ rhsRule r)