diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md diff --git a/language-js.cabal b/language-js.cabal new file mode 100644 --- /dev/null +++ b/language-js.cabal @@ -0,0 +1,58 @@ +-- This file has been generated from package.yaml by hpack version 0.21.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 7591d251e3d3f32efcbaeb9a161dd808d91cb30863aa52efc5609f564b8b9bc6 + +name: language-js +version: 0.1.0 +synopsis: javascript parser for es6 and es7. +description: Please see the README on Github at +category: Language +homepage: https://github.com/diasbruno/language-js#readme +bug-reports: https://github.com/diasbruno/language-js/issues +author: Bruno Dias +maintainer: Bruno Dias +copyright: 2018 Bruno Dias +license: BSD3 +license-file: license.md +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + changelog.md + readme.md + +source-repository head + type: git + location: https://github.com/diasbruno/language-js + +library + exposed-modules: + Language.JS.Common + Language.JS.Operators + Language.JS.Parser + Language.JS.Types + other-modules: + Paths_language_js + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , parsec + default-language: Haskell2010 + +test-suite language-js-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_language_js + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , hspec + , language-js + , parsec + default-language: Haskell2010 diff --git a/license.md b/license.md new file mode 100644 --- /dev/null +++ b/license.md @@ -0,0 +1,30 @@ +Copyright Bruno Dias (c) 2018 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/readme.md b/readme.md new file mode 100644 --- /dev/null +++ b/readme.md @@ -0,0 +1,13 @@ +# language-js + +javascript parser for es6 and es7. + +## todo + +- [] refactor. +- [] transform ast into json and/or xml. + +## references + +- [ECMAScript® 2017 Language Specification (ECMA-262, 8th edition, June 2017)](http://www.ecma-international.org/ecma-262/8.0/index.html) +- [MDN Operator precedence](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Operators/Operator_Precedence) diff --git a/src/Language/JS/Common.hs b/src/Language/JS/Common.hs new file mode 100644 --- /dev/null +++ b/src/Language/JS/Common.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE FlexibleContexts #-} +module Language.JS.Common where + +import qualified Text.Parsec as P + +parens, braces, angles, brackets :: P.Stream s m Char => + P.ParsecT s u m a -> P.ParsecT s u m a +parens = P.between (P.string "(") (P.string ")") +braces = P.between (P.string "{") (P.string "}") +angles = P.between (P.string "<") (P.string ">") +brackets = P.between (P.string "[") (P.string "]") + +semi, comma, dot, colon :: P.Stream s m Char => P.ParsecT s u m String +semi = P.string ";" +comma = P.string "," +dot = P.string "." +colon = P.string ":" + +dotSep, commaSep, semiSep :: P.Stream s m Char => P.ParsecT s u m a -> P.ParsecT s u m [a] +dotSep p = P.sepBy1 p dot +commaSep p = P.sepBy p comma +semiSep p = P.sepBy p semi + +commaSep1, semiSep1 :: P.Stream s m Char => P.ParsecT s u m a -> P.ParsecT s u m [a] +commaSep1 p = P.sepBy1 p comma +semiSep1 p = P.sepBy1 p semi + +whiteSpaces :: P.Stream s m Char => P.ParsecT s u m String +whiteSpaces = P.many (P.oneOf " \n\t") + +lexeme :: P.Stream s m Char => P.ParsecT s u m a -> P.ParsecT s u m a +lexeme p = p <* whiteSpaces + +keywordB :: P.Stream s m Char => String -> P.ParsecT s u m String +keywordB = P.try . lexeme . P.string + +-- | reserved words +reservedWords :: [String] +reservedWords = ["function", "return", "var", "let", "const", + "switch", "case", "break", "default", + "for", "while", "do", "in", "of", + "if", "else", + "delete", "void", "typeof", + "class", "extends", "staticn", "get", "set", + "async", + "import", "from", "export", "as", + "instanceof" + ] diff --git a/src/Language/JS/Operators.hs b/src/Language/JS/Operators.hs new file mode 100644 --- /dev/null +++ b/src/Language/JS/Operators.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE FlexibleContexts #-} +module Language.JS.Operators where + +import qualified Text.Parsec.Expr as P +import qualified Text.Parsec as P +import Language.JS.Types +import Language.JS.Common + +opNotFollowedBy op p = keywordB op <* P.notFollowedBy p + +table :: P.Stream s m Char => Bool -> P.ParsecT s u m Expression -> [[P.Operator s u m Expression]] +table withComma exp' = [[ P.Postfix (UnaryUpdate <$> keywordB "++" <*> pure False ) -- 17 + , P.Postfix (UnaryUpdate <$> keywordB "--" <*> pure False )] + ,[ P.Prefix (Unary <$> P.try (opNotFollowedBy "!" (P.char '=')) ) -- 16 + , P.Prefix (Unary <$> keywordB "~" ) + , P.Prefix (Unary <$> P.try (opNotFollowedBy "+" (P.oneOf "+=")) ) + , P.Prefix (Unary <$> P.try (opNotFollowedBy "-" (P.oneOf "-=")) ) + , P.Prefix (UnaryUpdate <$> keywordB "++" <*> pure True ) + , P.Prefix (UnaryUpdate <$> keywordB "--" <*> pure True ) + , P.Prefix (Unary <$> keywordB "typeof" ) + , P.Prefix (Unary <$> keywordB "void" ) + , P.Prefix (Unary <$> keywordB "delete" ) + , P.Prefix (Unary <$> keywordB "await" )] + ,[ P.Infix (Operation <$> P.try (opNotFollowedBy "**" (P.char '=')) ) P.AssocRight] -- 15 + ,[ P.Infix (Operation <$> P.try (opNotFollowedBy "*" (P.oneOf "*=")) ) P.AssocLeft -- 14 + , P.Infix (Operation <$> P.try (opNotFollowedBy "/" (P.oneOf "*=")) ) P.AssocLeft + , P.Infix (Operation <$> P.try (opNotFollowedBy "%" (P.oneOf "/=")) ) P.AssocLeft] + ,[ P.Infix (Operation <$> P.try (opNotFollowedBy "+" (P.oneOf "+=")) ) P.AssocLeft -- 13 + , P.Infix (Operation <$> P.try (opNotFollowedBy "-" (P.oneOf "-=")) ) P.AssocLeft] + ,[ P.Infix (Operation <$> P.try (opNotFollowedBy "<<" (P.oneOf "=")) ) P.AssocLeft -- 12 + , P.Infix (Operation <$> P.try (opNotFollowedBy ">>" (P.oneOf ">=")) ) P.AssocLeft + , P.Infix (Operation <$> P.try (opNotFollowedBy ">>>" (P.char '=')) ) P.AssocLeft] + ,[ P.Infix (Operation <$> P.try (opNotFollowedBy "<" (P.oneOf "<=")) ) P.AssocLeft -- 11 + , P.Infix (Operation <$> keywordB "<=" ) P.AssocLeft + , P.Infix (Operation <$> P.try (opNotFollowedBy ">" (P.oneOf ">=")) ) P.AssocLeft + , P.Infix (Operation <$> keywordB ">=" ) P.AssocLeft + , P.Infix (Operation <$> P.try (opNotFollowedBy "in" (P.char 's')) ) P.AssocLeft + , P.Infix (Operation <$> keywordB "instanceof" ) P.AssocLeft] + ,[ P.Infix (Operation <$> P.try (opNotFollowedBy "==" (P.char '=')) ) P.AssocLeft -- 10 + , P.Infix (Operation <$> P.try (opNotFollowedBy "!=" (P.char '=')) ) P.AssocLeft + , P.Infix (Operation <$> keywordB "===" ) P.AssocLeft + , P.Infix (Operation <$> keywordB "!==" ) P.AssocLeft] + ,[ P.Infix (Operation <$> P.try (opNotFollowedBy "&" (P.oneOf "&=")) ) P.AssocLeft] -- 9 + ,[ P.Infix (Operation <$> keywordB "^" ) P.AssocLeft] -- 8 + ,[ P.Infix (Operation <$> P.try (opNotFollowedBy "|" (P.oneOf "|=")) ) P.AssocLeft] -- 7 + ,[ P.Infix (Operation <$> P.try (opNotFollowedBy "&&" (P.char '=')) ) P.AssocLeft] -- 6 + ,[ P.Infix (Operation <$> keywordB "||" ) P.AssocLeft] -- 5 + ,[ P.Infix (flip Condition <$> (keywordB "?" *> lexeme exp' <* keywordB ":")) P.AssocNone] -- 4 + ,[ P.Infix (Assignment <$> P.try (opNotFollowedBy "=" (P.oneOf ">=")) ) P.AssocRight -- 3 + , P.Infix (Assignment <$> keywordB "+=" ) P.AssocRight + , P.Infix (Assignment <$> keywordB "-=" ) P.AssocRight + , P.Infix (Assignment <$> keywordB "**=" ) P.AssocRight + , P.Infix (Assignment <$> keywordB "*=" ) P.AssocRight + , P.Infix (Assignment <$> keywordB "/=" ) P.AssocRight + , P.Infix (Assignment <$> keywordB "%=" ) P.AssocRight + , P.Infix (Assignment <$> keywordB "<<=" ) P.AssocRight + , P.Infix (Assignment <$> keywordB ">>=" ) P.AssocRight + , P.Infix (Assignment <$> keywordB ">>>=" ) P.AssocRight + , P.Infix (Assignment <$> keywordB "&=" ) P.AssocRight + , P.Infix (Assignment <$> keywordB "^=" ) P.AssocRight + , P.Infix (Assignment <$> keywordB "|=" ) P.AssocRight] + ,[ P.Prefix (Unary <$> keywordB "yield" )] -- 2 + ,if withComma then ([ P.Infix (Comma <$ keywordB ",") P.AssocLeft]) else [] -- 1 + ] + +-- withComma = isLiteral (used when parsing arrays, objects and parenthesis expression) +operationExp withComma exp' p = P.buildExpressionParser (table withComma exp') (lexeme p) P. "[operations]" diff --git a/src/Language/JS/Parser.hs b/src/Language/JS/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Language/JS/Parser.hs @@ -0,0 +1,303 @@ +{-# LANGUAGE FlexibleContexts #-} +module Language.JS.Parser where + +import Control.Applicative ((<|>)) +import Control.Monad (liftM2) +import qualified Text.Parsec as P +import Language.JS.Types +import Language.JS.Common +import Language.JS.Operators + +-- | identifier +identifier = do h <- P.many (P.oneOf "_$") + t <- P.many1 P.alphaNum + return (h ++ t) + +identB = P.try (LI <$> (do i <- identifier + case i `elem` reservedWords of + True -> P.unexpected "reserved word" + _ -> return i)) P. "[identifier]" + +-- | numbers +numberB = LN <$> (P.many1 P.digit) P. "[number-literal]" + +-- | booleans +boolB = P.try (boolA "true" <|> boolA "false") P. "[boolean]" + where + boolA = fmap (LB . toHask) . keywordB + toHask s | s == "true" = True + | otherwise = False + +-- | this +thisB = const LThis <$> keywordB "this" P. "[this]" + +-- | null +nullB = const LNull <$> keywordB "null" P. "[null]" + +stringA ctor wc p = ctor <$> (P.try (P.between (P.char wc) (P.char wc) (p wc))) + +-- | strings literal +stringB = stringA LS '\"' allowed <|> stringA LS '\'' allowed P. "[string-literal]" + where + allowed e = P.many (P.satisfy (\c -> c /= '\n' && c /= e)) + +-- | template strings +templateStringB = stringA LTS '`' allowed P. "[template-string]" + where + allowed e = P.many (P.satisfy (\c -> c /= e)) + +regexB :: (P.Stream s m Char) => P.ParsecT s u m Expression +regexB = let re = (P.string "/" >> return "") <|> + (do es <- P.char '\\' -- escaped char + t <- P.anyToken + n <- re + return (es:t:n)) <|> + (liftM2 (:) P.anyToken re) + in RegExp <$> ((P.char '/') *> re) <*> P.many (P.oneOf "mgi") + +-- | array literal +arrayB = P.try (LA <$> brackets (commaSep (whiteSpaces *> checkSpread Spread (expressionNonEmpty False)))) P. "[array]" + +-- | parenthesis expression +parensB = LP <$> parens (whiteSpaces *> (expressionNonEmpty True)) P. "[parenthesis]" + +checkSpread ctor p = do i <- P.optionMaybe (keywordB "...") + case i of + Just _ -> ctor <$> p + Nothing -> p + +formalParameter = whiteSpaces *> bindExpression <* whiteSpaces + P. "[formal-parameters]" + +-- | function expression +functionDeclB = Function <$> (keywordB "function" *> lexeme (P.optionMaybe identB)) + <*> lexeme (parens (commaSep formalParameter)) + <*> lexeme (SBlock <$> braces (whiteSpaces *> P.many (lexeme statements))) + P. "[function]" + +-- | arrow expression (function) +afunctionB = P.try (Arrow <$> (lexeme (parens manyParams <|> singleParam) <* keywordB "=>") + <*> (SBlock <$> braces (whiteSpaces *> P.many (lexeme statements)) <|> statements)) + P. "[arrow-function]" + where singleParam = Left <$> bindVar + manyParams = Right <$> commaSep formalParameter + +functionB = (afunctionB <|> functionDeclB) + +propertyMethodDef = P.try (PropertyMethod <$> lexeme identB + <*> lexeme (parens (commaSep formalParameter)) + <*> (SBlock <$> braces (whiteSpaces *> P.many (lexeme statements)))) + P. "[class-method-definition]" + +classStaticDef = lexeme (keywordB "static") *> (ClassStatic <$> (propertyMethodDef <|> classPropertyDef)) + +classGetSetMethodDef = (keywordB "set" *> (ClassSetMethod <$> propertyMethodDef)) <|> + (keywordB "get" *> (ClassGetMethod <$> propertyMethodDef)) + P. "[class-get-set-definition]" + +asyncMethodDef = keywordB "async" *> (Async <$> propertyMethodDef) + P. "[async-definition]" + +classPropertyDef = P.try (ClassProperty <$> (lexeme identB <* P.char '=' <* whiteSpaces) + <*> lexeme (expressionNonEmpty False)) + P. "[class-property]" +classB = keywordB "class" *> (Class <$> (lexeme (P.optionMaybe identB)) + <*> P.optionMaybe (keywordB "extends" *> lexeme identB) + <*> (SBlock <$> braces (whiteSpaces *> classBlock))) + P. "[class-expression]" + where classBlock = P.many (lexeme (toStatement <$> classBlockDecls)) + classBlockDecls = (classPropertyDef + <|> asyncMethodDef + <|> classStaticDef + <|> classGetSetMethodDef + <|> propertyMethodDef) + +-- | key and/or value property pair +kvB = do + sp <- P.optionMaybe (keywordB "...") + case sp of + Just _ -> OPI . Spread <$> literals + Nothing -> (OPM <$> (asyncMethodDef <|> classGetSetMethodDef <|> propertyMethodDef)) <|> (do + k <- identB + x <- P.try (P.lookAhead (P.oneOf ",:}")) + case x of + ':' -> P.try (OPKV k <$> (lexeme (P.char ':') *> lexeme (checkSpread Spread (expressionNonEmpty False)) P. "[object-value-expression]")) + _ -> return (OPI k)) + +-- | object literal +objectB = LO <$> lexeme (braces (P.sepBy (whiteSpaces *> kvB <* whiteSpaces) (P.char ','))) P. "[object-literal]" + +dotMember p = Dot p <$> (lexeme (P.char '.') *> identB) P. "[dot-expression]" +accessor p = Acc p <$> brackets (whiteSpaces *> (expressionNonEmpty True) <* whiteSpaces) P. "[array-expression]" +callExp p = FCall p <$> lexeme (parens (commaSep (whiteSpaces *> expressionNonEmpty False))) P. "[function-call]" + +-- | new +newB = const Nothing <$> keywordB "new" P. "[new]" + +memberExp (Just p) = (do dt <- (callExp p <|> dotMember p <|> accessor p) P. "[member-expression]" + memberExp (Just dt)) <|> return p +memberExp Nothing = (New <$> expressions) P. "[new-expression]" + +literals = thisB <|> nullB <|> boolB + <|> stringB <|> templateStringB + <|> arrayB <|> objectB <|> regexB + <|> numberB <|> identB + +primaryExp = literals <|> functionB <|> classB <|> parensB + +maybeSemi = P.optional (P.char ';') + +emptyExp = (const Empty) <$> (P.char ';') P. "[empty-expressions]" + +leftHandSideExp = (newB <|> (Just <$> lexeme primaryExp)) >>= memberExp P. "left-hand-side-expression" + +-- | expressions +expressions = emptyExp <|> expressionNonEmpty True P. "[expressions]" + +comment = P.try (Comment <$> (P.string "//" *> P.many (P.satisfy (\c -> c /= '\n')))) +multilineComment = P.try (MultilineComment <$> (P.between (P.string "/*") (P.string "*/") (P.many P.anyToken))) + +expressionNonEmpty notComma = comment <|> multilineComment <|> + functionB <|> classB <|> + (operationExp notComma (expressionNonEmpty notComma) leftHandSideExp) <|> + primaryExp + P. "[non-empty-expressions]" + +toStatement :: Expression -> Statement +toStatement (Function (Just (LI a)) b c) = SF a b c +toStatement (Class (Just (LI a)) b c) = SC a b c +toStatement a = SExp a + +-- Statements + +importNamespaceClause = Namespace <$> ((keywordB "*" *> keywordB "as") *> identB) +importBindClause = BindNames <$> braces (commaSep (whiteSpaces *> identB <* whiteSpaces)) +importDefaultNameClause = DefaultName <$> lexeme identB + +importManyClauses = commaSep1 (whiteSpaces *> (importBindClause <|> importDefaultNameClause)) + +importClauses = (importNamespaceClause >>= return . Left) + <|> (importManyClauses >>= return . Right) + +importFileStatement = SImportFile <$> lexeme stringB +importStatement = SImport <$> (lexeme importClauses <* keywordB "from") <*> lexeme stringB +importStatements = keywordB "import" *> (importStatement <|> importFileStatement) + P. "[import-statement]" + +reexportStatement = P.try (SRExport <$> (lexeme (expressionNonEmpty False) <* keywordB "from") <*> lexeme stringB) +exportDefaultStatement = keywordB "default" *> (SExportDefault <$> expressionNonEmpty False) +exportStatement = SExport <$> statements +exportStatements = keywordB "export" *> (reexportStatement <|> exportDefaultStatement <|> exportStatement) + P. "[export-statement]" + +continueStatement = SContinue <$> (keywordB "continue" *> P.optionMaybe identB) + P. "[continue-statement]" +breakStatement = SBreak <$> (keywordB "break" *> P.optionMaybe identB) + P. "[break-statement]" + +blockStatement allowedStmt = SBlock <$> (P.try (braces (whiteSpaces *> P.many allowedStmt <* whiteSpaces))) + P. "[block-statement]" + +ifStatement = SIf <$> (keywordB "if" *> lexeme parensB) + <*> lexeme (SBlock <$> braces (whiteSpaces *> P.many (lexeme statements)) <|> statements) + <*> P.optionMaybe (keywordB "else" *> (SBlock <$> braces (whiteSpaces *> P.many (lexeme statements)) <|> statements)) + P. "[if-statement]" + +catchB = SCatch <$> (keywordB "catch" *> lexeme (P.optionMaybe parensB)) + <*> blockStatement statements + P. "[try/catch-statement]" + +finallyB = SFinally <$> (keywordB "finally" *> blockStatement statements) + P. "[try/catch/finally-statement]" + +tryStatement = STry <$> (keywordB "try" *> lexeme (blockStatement statements)) + <*> catchB + <*> P.optionMaybe finallyB P. "[try-statement]" + +throwStatement = SThrow <$> (keywordB "throw" *> expressionNonEmpty False) + P. "[throw-statement]" + +returnStatement = SReturn <$> (keywordB "return" *> expressions) + P. "[return-statement]" + +bindVar = BindVar <$> lexeme identB <*> P.optionMaybe (P.notFollowedBy (keywordB "=>") *> (lexeme (P.char '=') *> (expressionNonEmpty False))) +bindPatternDecl = BindPattern <$> (lexeme (objectB <|> arrayB)) <*> P.optionMaybe (lexeme (P.char '=') *> (expressionNonEmpty False)) +bindSpread = BindRest <$> (keywordB "..." *> leftHandSideExp) +bindExpression = (bindVar <|> bindPatternDecl <|> bindSpread) P. "[var-binds]" + +constVariableStatement = P.try (SVariable <$> (keywordB "const") <*> commaSep1 (whiteSpaces *> bindExpression <* whiteSpaces)) +notConstVariableStatement = P.try (SVariable <$> (keywordB "let" <|> keywordB "var") <*> commaSep1 (whiteSpaces *> bindExpression <* whiteSpaces)) +variableStatement = constVariableStatement <|> notConstVariableStatement P. "[variable-statement]" + +caseClause = lexeme ((caseB <|> defaultCase) <* (P.char ':')) P. "[switch/case-expression]" + where defaultCase = const DefaultCase <$> (keywordB "default") + caseB = Case <$> (keywordB "case" *> literals) + +caseCase = SCase <$> lexeme (P.many1 caseClause) + <*> P.many (lexeme ((breakStatement <* maybeSemi) <|> statements)) + +caseBlock = braces (whiteSpaces *> P.many caseCase <* whiteSpaces) +switchStatement = SSwitch <$> (keywordB "switch" *> lexeme parensB) + <*> caseBlock + P. "[switch-statement]" + +debuggerStatement = const SDebugger <$> keywordB "debugger" + P. "[debugger-statement]" + +breakableStatement = blockStatement ((breakStatement <* maybeSemi) <|> statements) <|> statements + +whileStatement = SWhile <$> (keywordB "while" *> lexeme (parens (P.many1 expressions))) + <*> breakableStatement + P. "[while-statement]" + +doWhileStatement = SDoWhile <$> (keywordB "do" *> lexeme breakableStatement) + <*> (keywordB "while" *> parens (P.many1 expressions)) + P. "[do/while-statement]" + +forInVStyle = P.try (ForInV <$> lexeme (keywordB "let" <|> keywordB "const" <|> keywordB "var") + <*> bindExpression + <*> (keywordB "in" *> (expressionNonEmpty False))) +forOfVStyle = P.try (ForOfV <$> lexeme (keywordB "let" <|> keywordB "const" <|> keywordB "var") + <*> bindExpression + <*> (keywordB "of" *> expressionNonEmpty False )) +forInStyle = P.try (ForIn <$> bindExpression <*> (keywordB "in" *> expressionNonEmpty False)) +forOfStyle = P.try (ForOf <$> bindExpression <*> (keywordB "of" *> expressionNonEmpty False)) +forRegularStyle = ForRegular <$> P.try (P.optionMaybe bindExpression <* (P.char ';')) + <*> P.try (P.optionMaybe (expressionNonEmpty True) <* (P.char ';')) + <*> P.optionMaybe (expressionNonEmpty True) +forStyle = forInVStyle <|> forOfVStyle <|> forInStyle <|> forOfStyle <|> forRegularStyle P. "[for-style]" +forStatement = SFor <$> lexeme (keywordB "for" *> (parens forStyle)) <*> breakableStatement + +iterationStatement = forStatement <|> whileStatement <|> doWhileStatement + +withStatement = SWith <$> (keywordB "with" *> lexeme (parens (expressionNonEmpty True))) + <*> (SBlock <$> braces (whiteSpaces *> P.many (lexeme statements)) <|> statements) + P. "[with-statement]" + +labelledStatement = SLabel <$> P.try (lexeme (identB <* P.char ':')) <*> statements + P. "[labelled-statement]" + +statements = ((blockStatement statements + <|> ifStatement + <|> iterationStatement + <|> debuggerStatement + <|> labelledStatement + <|> continueStatement + <|> tryStatement + <|> throwStatement + <|> returnStatement + <|> switchStatement + <|> withStatement + <|> variableStatement + <|> (fmap toStatement expressions)) <* maybeSemi) P. "[statements]" + +topLevelStatements = importStatements <|> exportStatements <|> statements + +-- | parser +parseJs = P.many (whiteSpaces *> lexeme (topLevelStatements <* maybeSemi <* whiteSpaces)) + +parse :: String -> String -> Either P.ParseError [Statement] +parse filename source = P.parse parseJs filename source + +parseFromFile :: String -> IO (Either P.ParseError [Statement]) +parseFromFile filename = readFile filename >>= return . P.parse parseJs filename diff --git a/src/Language/JS/Types.hs b/src/Language/JS/Types.hs new file mode 100644 --- /dev/null +++ b/src/Language/JS/Types.hs @@ -0,0 +1,126 @@ +module Language.JS.Types where + +data ObjectProperty = OPI Expression + | OPKV Expression Expression + | OP Expression + | OPM Expression + deriving (Show) + +type IsPrefix = Bool + +data SwitchCase = Case Expression | DefaultCase + deriving (Show) + +type ExpressionOpt = Maybe Expression +type StatementOpt = Maybe Statement + +data ForStyle = ForIn BindExpression Expression + | ForInV String BindExpression Expression + | ForOf BindExpression Expression + | ForOfV String BindExpression Expression + | ForRegular (Maybe BindExpression) ExpressionOpt ExpressionOpt + deriving (Show) + +-- | import and export binds +-- * as identifier +-- A, ... +-- {x,...} +data ImportClause = Namespace Expression + | DefaultName Expression + | BindNames [Expression] + deriving (Show) + +-- possible binds +-- <> +-- a +-- a=1 +-- {a} +-- {a}={a:1} +-- ...a +-- ...{a} +-- ...[a] +data BindExpression = BindVar Expression (Maybe Expression) + | BindPattern Expression (Maybe Expression) + | BindRest Expression + deriving (Show) + +data Expression = -- literals + LThis + | LNull + | LI String + | LN String + | LS String + | LTS String + | LB Bool + | RegExp String String + | UnaryUpdate String IsPrefix Expression + | Unary String Expression + | Spread Expression + | LA [Expression] + | LO [ObjectProperty] + | LP Expression + | Condition Expression Expression Expression -- exp ? exp : exp + | Assignment String Expression Expression + | Operation String Expression Expression + -- function expression + | Function ExpressionOpt [BindExpression] Statement + | Arrow (Either BindExpression [BindExpression]) Statement -- arrow function + -- class expression + | Class ExpressionOpt ExpressionOpt Statement + | ClassProperty Expression Expression + | PropertyMethod Expression [BindExpression] Statement + | ClassStatic Expression + | ClassGetMethod Expression + | ClassSetMethod Expression + -- async expression + | Async Expression + -- member expression + | Dot Expression Expression + | Acc Expression Expression + | FCall Expression [Expression] + | New Expression -- new + expression + -- comma / sequence + | Comma Expression Expression + -- empty expression ; + | Empty + | Comment String + | MultilineComment String + deriving (Show) + +data Statement = SExp Expression + -- module statements + | SImportFile Expression + | SImport (Either ImportClause [ImportClause]) Expression + | SRExport Expression Expression + | SExport Statement + | SExportDefault Expression + -- function and class declaration + | SC String ExpressionOpt Statement + | SF String [BindExpression] Statement + -- variable statements + | SVariable String [BindExpression] + -- iteration statements + | SWhile [Expression] Statement + | SDoWhile Statement [Expression] + | SFor ForStyle Statement + | SLabel Expression Statement -- identifier: statement + | SDebugger + -- control statements + | SContinue ExpressionOpt + | SBreak ExpressionOpt + -- general block statement + | SBlock [Statement] + | SIf Expression Statement StatementOpt + -- switch statement + | SSwitch Expression [Statement] + | SCase [SwitchCase] [Statement] -- cases + statementslist + -- try/catch/finally/throw statement + | SThrow Expression + | STry Statement Statement StatementOpt + | SCatch ExpressionOpt Statement + | SFinally Statement + -- return statement + | SReturn Expression + -- with statement + | SWith Expression Statement + deriving (Show) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,557 @@ +import Control.Monad (when) +import System.Exit +import Test.Hspec +import Test.Hspec.Runner +import Text.Parsec (parse) +import Language.JS.Parser hiding (parse) +import qualified Language.JS.Parser as JS + +testExpression = parse expressions "dummy.js" >>= return . show +testStatement = parse statements "dummy.js" >>= return . show +testTopLevelStatement = parse topLevelStatements "dummy.js" >>= return . show + +testParseJs = JS.parse "dummy.js" >>= return . show + +testExpressions :: Spec +testExpressions = describe "Parse literals:" $ do + it "this" $ do + shouldBe (testExpression "this") + "Right LThis" + + it "undefined/null" $ do + shouldBe (testExpression "null") + "Right LNull" + + it "booleans" $ do + shouldBe (testExpression "true") + "Right (LB True)" + + shouldBe (testExpression "false") + "Right (LB False)" + + it "ident" $ do + shouldBe (testExpression "test") + "Right (LI \"test\")" + + it "numbers" $ do + shouldBe (testExpression "1") + "Right (LN \"1\")" + + it "strings" $ do + shouldBe (testExpression "\"test\"") + "Right (LS \"test\")" + shouldBe (testExpression "\'test\'") + "Right (LS \"test\")" + + it "template string" $ do + shouldBe (testExpression "`test`") + "Right (LTS \"test\")" + + it "arrays" $ do + shouldBe (testExpression "[]") + "Right (LA [])" + + shouldBe (testExpression "[1,2]") + "Right (LA [LN \"1\",LN \"2\"])" + + shouldBe (testExpression "[a,2]") + "Right (LA [LI \"a\",LN \"2\"])" + + shouldBe (testExpression "[a,...b]") + "Right (LA [LI \"a\",Spread (LI \"b\")])" + + shouldBe (testExpression "[a,...[1, 2]]") + "Right (LA [LI \"a\",Spread (LA [LN \"1\",LN \"2\"])])" + + it "objects" $ do + shouldBe (testExpression "{}") + "Right (LO [])" + + shouldBe (testExpression "{a:1}") + "Right (LO [OPKV (LI \"a\") (LN \"1\")])" + + shouldBe (testExpression "{b:2,c: \"d\"}") + "Right (LO [OPKV (LI \"b\") (LN \"2\"),OPKV (LI \"c\") (LS \"d\")])" + + shouldBe (testExpression "{b:2, c:function() {}}") + "Right (LO [OPKV (LI \"b\") (LN \"2\"),OPKV (LI \"c\") (Function Nothing [] (SBlock []))])" + + shouldBe (testExpression "{e}") + "Right (LO [OPI (LI \"e\")])" + + shouldBe (testExpression "{e,f:1}") + "Right (LO [OPI (LI \"e\"),OPKV (LI \"f\") (LN \"1\")])" + + shouldBe (testExpression "{e,...f}") + "Right (LO [OPI (LI \"e\"),OPI (Spread (LI \"f\"))])" + + shouldBe (testExpression "{e,...{a:1}}") + "Right (LO [OPI (LI \"e\"),OPI (Spread (LO [OPKV (LI \"a\") (LN \"1\")]))])" + + shouldBe (testExpression "{e,i:...{a:1}}") + "Right (LO [OPI (LI \"e\"),OPKV (LI \"i\") (Spread (LO [OPKV (LI \"a\") (LN \"1\")]))])" + + shouldBe (testExpression "{e(){}}") + "Right (LO [OPM (PropertyMethod (LI \"e\") [] (SBlock []))])" + + shouldBe (testExpression "{get e(){}}") + "Right (LO [OPM (ClassGetMethod (PropertyMethod (LI \"e\") [] (SBlock [])))])" + + shouldBe (testExpression "{set e(){}}") + "Right (LO [OPM (ClassSetMethod (PropertyMethod (LI \"e\") [] (SBlock [])))])" + + shouldBe (testExpression "{async e(){}}") + "Right (LO [OPM (Async (PropertyMethod (LI \"e\") [] (SBlock [])))])" + + it "regular expression" $ do + shouldBe (testExpression "/test\\/asdf/") + "Right (RegExp \"test\\\\/asdf\" \"\")" + + shouldBe (testExpression "/test\\/asdf/gmi") + "Right (RegExp \"test\\\\/asdf\" \"gmi\")" + + shouldBe (testExpression "/test\\/asdf/gmi.exec(test)") + "Right (FCall (Dot (RegExp \"test\\\\/asdf\" \"gmi\") (LI \"exec\")) [LI \"test\"])" + + it "try dotted" $ do + shouldBe (testExpression "a.b") + "Right (Dot (LI \"a\") (LI \"b\"))" + + it "array accessor" $ do + shouldBe (testExpression "a[0]") + "Right (Acc (LI \"a\") (LN \"0\"))" + + shouldBe (testExpression "a[b.x]") + "Right (Acc (LI \"a\") (Dot (LI \"b\") (LI \"x\")))" + + shouldBe (testExpression "a[b.x].c") + "Right (Dot (Acc (LI \"a\") (Dot (LI \"b\") (LI \"x\"))) (LI \"c\"))" + + shouldBe (testExpression "a.c[b.x]") + "Right (Acc (Dot (LI \"a\") (LI \"c\")) (Dot (LI \"b\") (LI \"x\")))" + + it "parens expression" $ do + shouldBe (testExpression "(a,b)") + "Right (LP (Comma (LI \"a\") (LI \"b\")))" + + it "function expression" $ do + shouldBe (testExpression "function a() {}") + "Right (Function (Just (LI \"a\")) [] (SBlock []))" + + shouldBe (testExpression "function() {}") + "Right (Function Nothing [] (SBlock []))" + + shouldBe (testExpression "function(a, ...b) {}") + "Right (Function Nothing [BindVar (LI \"a\") Nothing,BindRest (LI \"b\")] (SBlock []))" + + shouldBe (testExpression "function(a=1) {}") + "Right (Function Nothing [BindVar (LI \"a\") (Just (LN \"1\"))] (SBlock []))" + + shouldBe (testExpression "function(a=1) { return 1; }") + "Right (Function Nothing [BindVar (LI \"a\") (Just (LN \"1\"))] (SBlock [SReturn (LN \"1\")]))" + + shouldBe (testExpression "function(a=1) {\n function b() {} }") + "Right (Function Nothing [BindVar (LI \"a\") (Just (LN \"1\"))] (SBlock [SF \"b\" [] (SBlock [])]))" + + shouldBe (testExpression "()=>x") + "Right (Arrow (Right []) (SExp (LI \"x\")))" + + shouldBe (testExpression "()=>{x}") + "Right (Arrow (Right []) (SBlock [SExp (LI \"x\")]))" + + shouldBe (testExpression "x=>{x}") + "Right (Arrow (Left (BindVar (LI \"x\") Nothing)) (SBlock [SExp (LI \"x\")]))" + + it "class expression" $ do + shouldBe (testExpression "class {}") + "Right (Class Nothing Nothing (SBlock []))" + + shouldBe (testExpression "class test {}") + "Right (Class (Just (LI \"test\")) Nothing (SBlock []))" + + shouldBe (testExpression "class test extends A {}") + "Right (Class (Just (LI \"test\")) (Just (LI \"A\")) (SBlock []))" + + shouldBe (testExpression "class extends A {}") + "Right (Class Nothing (Just (LI \"A\")) (SBlock []))" + + shouldBe (testExpression "class extends A { x = 1 }") + "Right (Class Nothing (Just (LI \"A\")) (SBlock [SExp (ClassProperty (LI \"x\") (LN \"1\"))]))" + + shouldBe (testExpression "class extends A { x() {} }") + "Right (Class Nothing (Just (LI \"A\")) (SBlock [SExp (PropertyMethod (LI \"x\") [] (SBlock []))]))" + + shouldBe (testExpression "class { static x = 1 }") + "Right (Class Nothing Nothing (SBlock [SExp (ClassStatic (ClassProperty (LI \"x\") (LN \"1\")))]))" + + shouldBe (testExpression "class { set x() { return 1 } }") + "Right (Class Nothing Nothing (SBlock [SExp (ClassSetMethod (PropertyMethod (LI \"x\") [] (SBlock [SReturn (LN \"1\")])))]))" + + shouldBe (testExpression "class { get x() { return 1 } }") + "Right (Class Nothing Nothing (SBlock [SExp (ClassGetMethod (PropertyMethod (LI \"x\") [] (SBlock [SReturn (LN \"1\")])))]))" + + shouldBe (testExpression "class { async x() { return 1 } }") + "Right (Class Nothing Nothing (SBlock [SExp (Async (PropertyMethod (LI \"x\") [] (SBlock [SReturn (LN \"1\")])))]))" + + it "new expression" $ do + shouldBe (testExpression "new A") + "Right (New (LI \"A\"))" + + shouldBe (testExpression "new A()") + "Right (New (FCall (LI \"A\") []))" + + it "call expression" $ do + shouldBe (testExpression "a()") + "Right (FCall (LI \"a\") [])" + + shouldBe (testExpression "a.b()") + "Right (FCall (Dot (LI \"a\") (LI \"b\")) [])" + + shouldBe (testExpression "a().b") + "Right (Dot (FCall (LI \"a\") []) (LI \"b\"))" + + shouldBe (testExpression "a(1).b") + "Right (Dot (FCall (LI \"a\") [LN \"1\"]) (LI \"b\"))" + + it "unary expression" $ do + shouldBe (testExpression "+a") + "Right (Unary \"+\" (LI \"a\"))" + + shouldBe (testExpression "-a") + "Right (Unary \"-\" (LI \"a\"))" + + shouldBe (testExpression "~a") + "Right (Unary \"~\" (LI \"a\"))" + + shouldBe (testExpression "!a") + "Right (Unary \"!\" (LI \"a\"))" + + shouldBe (testExpression "delete a") + "Right (Unary \"delete\" (LI \"a\"))" + + shouldBe (testExpression "typeof a") + "Right (Unary \"typeof\" (LI \"a\"))" + + shouldBe (testExpression "void a") + "Right (Unary \"void\" (LI \"a\"))" + + shouldBe (testExpression "++a") + "Right (UnaryUpdate \"++\" True (LI \"a\"))" + + shouldBe (testExpression "a++") + "Right (UnaryUpdate \"++\" False (LI \"a\"))" + + shouldBe (testExpression "--a") + "Right (UnaryUpdate \"--\" True (LI \"a\"))" + + shouldBe (testExpression "a--") + "Right (UnaryUpdate \"--\" False (LI \"a\"))" + + it "spread expression" $ do + shouldBe (testExpression "{...a}") + "Right (LO [OPI (Spread (LI \"a\"))])" + + it "assignment expression" $ do + shouldBe (testExpression "x = 1") + "Right (Assignment \"=\" (LI \"x\") (LN \"1\"))" + + shouldBe (testExpression "x += 1") + "Right (Assignment \"+=\" (LI \"x\") (LN \"1\"))" + + shouldBe (testExpression "x -= 1") + "Right (Assignment \"-=\" (LI \"x\") (LN \"1\"))" + + shouldBe (testExpression "x *= 1") + "Right (Assignment \"*=\" (LI \"x\") (LN \"1\"))" + + shouldBe (testExpression "x /= 1") + "Right (Assignment \"/=\" (LI \"x\") (LN \"1\"))" + + shouldBe (testExpression "x %= 1") + "Right (Assignment \"%=\" (LI \"x\") (LN \"1\"))" + + shouldBe (testExpression "x &= 1") + "Right (Assignment \"&=\" (LI \"x\") (LN \"1\"))" + + shouldBe (testExpression "x |= 1") + "Right (Assignment \"|=\" (LI \"x\") (LN \"1\"))" + + shouldBe (testExpression "x **= 1") + "Right (Assignment \"**=\" (LI \"x\") (LN \"1\"))" + + shouldBe (testExpression "x >>= 1") + "Right (Assignment \">>=\" (LI \"x\") (LN \"1\"))" + + shouldBe (testExpression "x <<= 1") + "Right (Assignment \"<<=\" (LI \"x\") (LN \"1\"))" + + shouldBe (testExpression "x >>>= 1") + "Right (Assignment \">>>=\" (LI \"x\") (LN \"1\"))" + + shouldBe (testExpression "x.a += 1") + "Right (Assignment \"+=\" (Dot (LI \"x\") (LI \"a\")) (LN \"1\"))" + + it "operation expressions" $ do + shouldBe (testExpression "a + b") + "Right (Operation \"+\" (LI \"a\") (LI \"b\"))" + + shouldBe (testExpression "a - b") + "Right (Operation \"-\" (LI \"a\") (LI \"b\"))" + + shouldBe (testExpression "a * b") + "Right (Operation \"*\" (LI \"a\") (LI \"b\"))" + + shouldBe (testExpression "a / b") + "Right (Operation \"/\" (LI \"a\") (LI \"b\"))" + + shouldBe (testExpression "a = b - c") + "Right (Assignment \"=\" (LI \"a\") (Operation \"-\" (LI \"b\") (LI \"c\")))" + + shouldBe (testExpression "a + b - c") + "Right (Operation \"-\" (Operation \"+\" (LI \"a\") (LI \"b\")) (LI \"c\"))" + + shouldBe (testExpression "a + x.a - x.c") + "Right (Operation \"-\" (Operation \"+\" (LI \"a\") (Dot (LI \"x\") (LI \"a\"))) (Dot (LI \"x\") (LI \"c\")))" + + shouldBe (testExpression "a + x.a && x.c") + "Right (Operation \"&&\" (Operation \"+\" (LI \"a\") (Dot (LI \"x\") (LI \"a\"))) (Dot (LI \"x\") (LI \"c\")))" + + shouldBe (testExpression "a == x.a + x.c") + "Right (Operation \"==\" (LI \"a\") (Operation \"+\" (Dot (LI \"x\") (LI \"a\")) (Dot (LI \"x\") (LI \"c\"))))" + + shouldBe (testExpression "!a") + "Right (Unary \"!\" (LI \"a\"))" + + shouldBe (testExpression "a = x.a && x.c") + "Right (Assignment \"=\" (LI \"a\") (Operation \"&&\" (Dot (LI \"x\") (LI \"a\")) (Dot (LI \"x\") (LI \"c\"))))" + + shouldBe (testExpression "a instanceof c") + "Right (Operation \"instanceof\" (LI \"a\") (LI \"c\"))" + + shouldBe (testExpression "typeof a == \"number\"") + "Right (Operation \"==\" (Unary \"typeof\" (LI \"a\")) (LS \"number\"))" + + shouldBe (testExpression "x ? y : z") + "Right (Condition (LI \"x\") (LI \"y\") (LI \"z\"))" + + shouldBe (testExpression "x == 1 ? y : z") + "Right (Condition (Operation \"==\" (LI \"x\") (LN \"1\")) (LI \"y\") (LI \"z\"))" + + shouldBe (testExpression "a = x == 1 ? y + 1 : z && 6") + "Right (Assignment \"=\" (LI \"a\") (Condition (Operation \"==\" (LI \"x\") (LN \"1\")) (Operation \"+\" (LI \"y\") (LN \"1\")) (Operation \"&&\" (LI \"z\") (LN \"6\"))))" + + shouldBe (testExpression "a.b() || x") + "Right (Operation \"||\" (FCall (Dot (LI \"a\") (LI \"b\")) []) (LI \"x\"))" + + shouldBe (testExpression "(x)\n.y") + "Right (Dot (LP (LI \"x\")) (LI \"y\"))" + + it "empty expression" $ do + shouldBe (testExpression ";") + "Right Empty" + +testStatements = describe "Statements" $ do + it "empty statement" $ do + shouldBe (testStatement ";") + "Right (SExp Empty)" + + it "if statement" $ do + shouldBe (testStatement "if (1) x = 1") + "Right (SIf (LP (LN \"1\")) (SExp (Assignment \"=\" (LI \"x\") (LN \"1\"))) Nothing)" + + shouldBe (testStatement "if (1)\nx = 1") + "Right (SIf (LP (LN \"1\")) (SExp (Assignment \"=\" (LI \"x\") (LN \"1\"))) Nothing)" + + shouldBe (testStatement "if (1) {x = 1}") + "Right (SIf (LP (LN \"1\")) (SBlock [SExp (Assignment \"=\" (LI \"x\") (LN \"1\"))]) Nothing)" + + shouldBe (testStatement "if (1) {x = 1} else x = 2") + "Right (SIf (LP (LN \"1\")) (SBlock [SExp (Assignment \"=\" (LI \"x\") (LN \"1\"))]) (Just (SExp (Assignment \"=\" (LI \"x\") (LN \"2\")))))" + + shouldBe (testStatement "if (a in [1, 2]) {}") + "Right (SIf (LP (Operation \"in\" (LI \"a\") (LA [LN \"1\",LN \"2\"]))) (SBlock []) Nothing)" + + it "try statement" $ do + shouldBe (testStatement "try {} catch {}") + "Right (STry (SBlock []) (SCatch Nothing (SBlock [])) Nothing)" + + shouldBe (testStatement "try {} catch {} finally {}") + "Right (STry (SBlock []) (SCatch Nothing (SBlock [])) Nothing)" + + shouldBe (testStatement "try {} catch (e) {} finally {}") + "Right (STry (SBlock []) (SCatch (Just (LP (LI \"e\"))) (SBlock [])) Nothing)" + + shouldBe (testStatement "return 1") + "Right (SReturn (LN \"1\"))" + + it "throw statements" $ do + shouldBe (testStatement "throw x;") + "Right (SThrow (LI \"x\"))" + + it "variable statements" $ do + shouldBe (testStatement "var x;") + "Right (SVariable \"var\" [BindVar (LI \"x\") Nothing])" + + shouldBe (testStatement "let x;") + "Right (SVariable \"let\" [BindVar (LI \"x\") Nothing])" + + shouldBe (testStatement "var x = 1") + "Right (SVariable \"var\" [BindVar (LI \"x\") (Just (LN \"1\"))])" + + shouldBe (testStatement "var x = 1, y;") + "Right (SVariable \"var\" [BindVar (LI \"x\") (Just (LN \"1\")),BindVar (LI \"y\") Nothing])" + + shouldBe (testStatement "const x = 1;") + "Right (SVariable \"const\" [BindVar (LI \"x\") (Just (LN \"1\"))])" + + shouldBe (testStatement "const x = 1, y = 2;") + "Right (SVariable \"const\" [BindVar (LI \"x\") (Just (LN \"1\")),BindVar (LI \"y\") (Just (LN \"2\"))])" + + shouldBe (testStatement "const {a} = {a:1};") + "Right (SVariable \"const\" [BindPattern (LO [OPI (LI \"a\")]) (Just (LO [OPKV (LI \"a\") (LN \"1\")]))])" + + it "switch statement" $ do + shouldBe (testStatement "switch (a) {}") + "Right (SSwitch (LP (LI \"a\")) [])" + + shouldBe (testStatement "switch (a) { case 1: { return; } }") + "Right (SSwitch (LP (LI \"a\")) [SCase [Case (LN \"1\")] [SBlock [SReturn Empty]]])" + + shouldBe (testStatement "switch (a) { case 1: { return; } break }") + "Right (SSwitch (LP (LI \"a\")) [SCase [Case (LN \"1\")] [SBlock [SReturn Empty],SBreak Nothing]])" + + shouldBe (testStatement "switch (a) { case 1: default: { return; } }") + "Right (SSwitch (LP (LI \"a\")) [SCase [Case (LN \"1\"),DefaultCase] [SBlock [SReturn Empty]]])" + + shouldBe (testStatement "switch (a) { case 1: { return 1; } case 2: default: { return; } }") + "Right (SSwitch (LP (LI \"a\")) [SCase [Case (LN \"1\")] [SBlock [SReturn (LN \"1\")]],SCase [Case (LN \"2\"),DefaultCase] [SBlock [SReturn Empty]]])" + + shouldBe (testStatement "switch (a) { case 1: { return 1; } break; default: return; }") + "Right (SSwitch (LP (LI \"a\")) [SCase [Case (LN \"1\")] [SBlock [SReturn (LN \"1\")],SBreak Nothing],SCase [DefaultCase] [SReturn Empty]])" + + it "continue statement" $ do + shouldBe (testStatement "continue") + "Right (SContinue Nothing)" + + shouldBe (testStatement "continue x") + "Right (SContinue (Just (LI \"x\")))" + + it "debugger statement" $ do + shouldBe (testStatement "debugger") + "Right SDebugger" + + it "iteration statement" $ do + shouldBe (testStatement "while (1) {}") + "Right (SWhile [LN \"1\"] (SBlock []))" + + -- break is allowed here + shouldBe (testStatement "while (1) {break}") + "Right (SWhile [LN \"1\"] (SBlock [SBreak Nothing]))" + + shouldBe (testStatement "while (1) {\nbreak\n;}") + "Right (SWhile [LN \"1\"] (SBlock [SBreak Nothing]))" + + shouldBe (testStatement "while (1) x = 1") + "Right (SWhile [LN \"1\"] (SExp (Assignment \"=\" (LI \"x\") (LN \"1\"))))" + + shouldBe (testStatement "do {} while (1)") + "Right (SDoWhile (SBlock []) [LN \"1\"])" + + shouldBe (testStatement "do {break} while (1)") + "Right (SDoWhile (SBlock [SBreak Nothing]) [LN \"1\"])" + + shouldBe (testStatement "do x = 1; while (1)") + "Right (SDoWhile (SExp (Assignment \"=\" (LI \"x\") (LN \"1\"))) [LN \"1\"])" + + shouldBe (testStatement "for (;;) {}") + "Right (SFor (ForRegular Nothing Nothing Nothing) (SBlock []))" + + shouldBe (testStatement "for (;;) {break}") + "Right (SFor (ForRegular Nothing Nothing Nothing) (SBlock [SBreak Nothing]))" + + shouldBe (testStatement "for (;;) x = 1") + "Right (SFor (ForRegular Nothing Nothing Nothing) (SExp (Assignment \"=\" (LI \"x\") (LN \"1\"))))" + + shouldBe (testStatement "for (x;;) x = 1") + "Right (SFor (ForRegular (Just (BindVar (LI \"x\") Nothing)) Nothing Nothing) (SExp (Assignment \"=\" (LI \"x\") (LN \"1\"))))" + + shouldBe (testStatement "for (x;;x++) x = 1") + "Right (SFor (ForRegular (Just (BindVar (LI \"x\") Nothing)) Nothing (Just (UnaryUpdate \"++\" False (LI \"x\")))) (SExp (Assignment \"=\" (LI \"x\") (LN \"1\"))))" + + shouldBe (testStatement "for (x;;x+=1) x = 1") + "Right (SFor (ForRegular (Just (BindVar (LI \"x\") Nothing)) Nothing (Just (Assignment \"+=\" (LI \"x\") (LN \"1\")))) (SExp (Assignment \"=\" (LI \"x\") (LN \"1\"))))" + + shouldBe (testStatement "for (;x&&y;) {}") + "Right (SFor (ForRegular Nothing (Just (Operation \"&&\" (LI \"x\") (LI \"y\"))) Nothing) (SBlock []))" + + shouldBe (testStatement "for (x in a) {}") + "Right (SFor (ForIn (BindVar (LI \"x\") Nothing) (LI \"a\")) (SBlock []))" + + shouldBe (testStatement "for (let x in a) {}") + "Right (SFor (ForInV \"let\" (BindVar (LI \"x\") Nothing) (LI \"a\")) (SBlock []))" + + shouldBe (testStatement "for (x of a) {}") + "Right (SFor (ForOf (BindVar (LI \"x\") Nothing) (LI \"a\")) (SBlock []))" + + shouldBe (testStatement "for (let x of a) {}") + "Right (SFor (ForOfV \"let\" (BindVar (LI \"x\") Nothing) (LI \"a\")) (SBlock []))" + + it "with statement" $ do + shouldBe (testStatement "with (a) {}") + "Right (SWith (LI \"a\") (SBlock []))" + + it "labelled statement" $ do + shouldBe (testStatement "a: x = 1") + "Right (SLabel (LI \"a\") (SExp (Assignment \"=\" (LI \"x\") (LN \"1\"))))" + + it "import statement" $ do + shouldBe (testTopLevelStatement "import \"test.js\"") + "Right (SImportFile (LS \"test.js\"))" + + shouldBe (testTopLevelStatement "import * as A from \"test.js\"") + "Right (SImport (Left (Namespace (LI \"A\"))) (LS \"test.js\"))" + + shouldBe (testTopLevelStatement "import {x} from \"test.js\"") + "Right (SImport (Right [BindNames [LI \"x\"]]) (LS \"test.js\"))" + + shouldBe (testTopLevelStatement "import B, {x} from \"test.js\"") + "Right (SImport (Right [DefaultName (LI \"B\"),BindNames [LI \"x\"]]) (LS \"test.js\"))" + + it "export statement" $ do + shouldBe (testTopLevelStatement "export {}") + "Right (SExport (SBlock []))" + + shouldBe (testTopLevelStatement "export default {}") + "Right (SExportDefault (LO []))" + + shouldBe (testTopLevelStatement "export {} from \"test.js\"") + "Right (SRExport (LO []) (LS \"test.js\"))" + + shouldBe (testTopLevelStatement "export const a = 1;") + "Right (SExport (SVariable \"const\" [BindVar (LI \"a\") (Just (LN \"1\"))]))" + + it "function declaration" $ do + shouldBe (testTopLevelStatement "function a() {} function b() {}") + "Right (SF \"a\" [] (SBlock []))" + + shouldBe (testTopLevelStatement "function a() { var i; return 1; }") + "Right (SF \"a\" [] (SBlock [SVariable \"var\" [BindVar (LI \"i\") Nothing],SReturn (LN \"1\")]))" + + shouldBe (testTopLevelStatement "function a() { function b() { return () => 1; } return 1; }") + "Right (SF \"a\" [] (SBlock [SF \"b\" [] (SBlock [SReturn (Arrow (Right []) (SExp (LN \"1\")))]),SReturn (LN \"1\")]))" + + it "class declaration" $ do + shouldBe (testTopLevelStatement "class a {}") + "Right (SC \"a\" Nothing (SBlock []))" + +testAll :: Spec +testAll = do + testExpressions + testStatements + +main :: IO () +main = do + summary <- hspecWithResult defaultConfig testAll + when (summaryFailures summary == 0) + exitSuccess + exitFailure