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 = 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]"
numberB = LN <$> (P.many1 P.digit) P.<?> "[number-literal]"
boolB = P.try (boolA "true" <|> boolA "false") P.<?> "[boolean]"
where
boolA = fmap (LB . toHask) . keywordB
toHask s | s == "true" = True
| otherwise = False
thisB = const LThis <$> keywordB "this" P.<?> "[this]"
nullB = const LNull <$> keywordB "null" P.<?> "[null]"
stringA ctor wc p = ctor <$> (P.try (P.between (P.char wc) (P.char wc) (p wc)))
stringB = stringA LS '\"' allowed <|> stringA LS '\'' allowed P.<?> "[string-literal]"
where
allowed e = P.many (P.satisfy (\c -> c /= '\n' && c /= e))
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 '\\'
t <- P.anyToken
n <- re
return (es:t:n)) <|>
(liftM2 (:) P.anyToken re)
in RegExp <$> ((P.char '/') *> re) <*> P.many (P.oneOf "mgi")
arrayB = P.try (LA <$> brackets (commaSep (whiteSpaces *> checkSpread Spread (expressionNonEmpty False)))) P.<?> "[array]"
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]"
functionDeclB = Function <$> (keywordB "function" *> lexeme (P.optionMaybe identB))
<*> lexeme (parens (commaSep formalParameter))
<*> lexeme (SBlock <$> braces (whiteSpaces *> P.many (lexeme statements)))
P.<?> "[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)
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))
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]"
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 = 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
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
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