module Language.PureScript.Parser.JS (
parseJS
) where
import Language.PureScript.Values
import Language.PureScript.Names
import Language.PureScript.CodeGen.JS.AST
import qualified Language.PureScript.Parser.Common as C
import Control.Applicative
import Data.Functor.Identity
import qualified Text.Parsec as P
import qualified Text.Parsec.Token as P
import qualified Text.Parsec.Expr as P
booleanLiteral :: P.Parsec String u Bool
booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False)
parseNumericLiteral :: P.Parsec String u JS
parseNumericLiteral = JSNumericLiteral <$> C.integerOrFloat
parseStringLiteral :: P.Parsec String u JS
parseStringLiteral = JSStringLiteral <$> C.stringLiteral
parseBooleanLiteral :: P.Parsec String u JS
parseBooleanLiteral = JSBooleanLiteral <$> booleanLiteral
parseArrayLiteral :: P.Parsec String u JS
parseArrayLiteral = JSArrayLiteral <$> P.squares C.tokenParser (P.commaSep C.tokenParser parseJS)
parseObjectLiteral :: P.Parsec String u JS
parseObjectLiteral = JSObjectLiteral <$> P.braces C.tokenParser (P.commaSep C.tokenParser parseIdentifierAndValue)
parseIdentifierAndValue :: P.Parsec String u (String, JS)
parseIdentifierAndValue = (,) <$> (C.identifier <* C.colon)
<*> parseJS
parseFunction :: P.Parsec String u JS
parseFunction = do
C.reserved "function"
name <- P.optionMaybe (Ident <$> C.identifier)
args <- P.parens C.tokenParser $ P.commaSep C.tokenParser (Ident <$> C.identifier)
body <- parseJS
return $ JSFunction name args body
parseBlock :: P.Parsec String u JS
parseBlock = JSBlock <$> P.braces C.tokenParser (P.many parseJS)
parseVar :: P.Parsec String u JS
parseVar = JSVar <$> Ident <$> C.identifier
parseJSAtom :: P.Parsec String u JS
parseJSAtom = P.choice
[ P.try parseNumericLiteral
, P.try parseStringLiteral
, P.try parseBooleanLiteral
, parseArrayLiteral
, P.try parseObjectLiteral
, parseFunction
, parseBlock
, P.try parseVar
, parseVariableIntroduction
, P.try parseAssignment
, parseWhile
, parseIf
, parseReturn
, P.parens C.tokenParser parseJS ]
parseAccessor :: JS -> P.Parsec String u JS
parseAccessor js = P.try $ flip JSAccessor js <$> (C.dot *> P.notFollowedBy C.opLetter *> C.identifier)
parseIndexer :: JS -> P.Parsec String u JS
parseIndexer js = P.try $ flip JSIndexer js <$> (P.squares C.tokenParser parseJS)
parseConditional :: JS -> P.Parsec String u JS
parseConditional js = P.try $ do
_ <- C.lexeme $ P.char '?'
tr <- parseJS
_ <- C.lexeme $ P.char ':'
fa <- parseJS
return $ JSConditional js tr fa
binary :: BinaryOperator -> String -> P.Assoc -> P.Operator String u Identity JS
binary op s f = P.Infix (P.try $ C.reservedOp s >> return (JSBinary op)) f
unary :: UnaryOperator -> String -> P.Operator String u Identity JS
unary op s = P.Prefix (P.try $ C.reservedOp s >> return (JSUnary op))
parseJS :: P.Parsec String u JS
parseJS =
(P.buildExpressionParser operators
. C.buildPostfixParser postfixTable2
$ indexersAndAccessors) P.<?> "javascript"
where
indexersAndAccessors = C.buildPostfixParser postfixTable1 parseJSAtom
postfixTable1 = [ parseAccessor, parseIndexer, parseConditional ]
postfixTable2 = [ \v -> P.try $ JSApp v <$> (P.parens C.tokenParser (P.commaSep C.tokenParser parseJS)) ]
operators = [ [ binary LessThan "<" P.AssocLeft]
, [ binary LessThanOrEqualTo "<=" P.AssocLeft]
, [ binary GreaterThan ">" P.AssocLeft]
, [ binary GreaterThanOrEqualTo ">=" P.AssocLeft]
, [ unary Not "!" ]
, [ unary BitwiseNot "~" ]
, [ unary Negate "-" ]
, [ unary Positive "+" ]
, [ binary Multiply "*" P.AssocLeft]
, [ binary Divide "/" P.AssocLeft]
, [ binary Modulus "%" P.AssocLeft]
, [ binary Concat "+" P.AssocLeft]
, [ binary Add "+" P.AssocLeft]
, [ binary Subtract "-" P.AssocLeft]
, [ binary ShiftLeft "<<" P.AssocLeft]
, [ binary ShiftRight ">>" P.AssocLeft]
, [ binary ZeroFillShiftRight ">>>" P.AssocLeft]
, [ binary EqualTo "===" P.AssocLeft]
, [ binary NotEqualTo "!==" P.AssocLeft]
, [ binary BitwiseAnd "&" P.AssocLeft]
, [ binary BitwiseXor "^" P.AssocLeft]
, [ binary BitwiseOr "|" P.AssocLeft]
, [ binary And "&&" P.AssocRight]
, [ binary Or "||" P.AssocRight]
]
parseVariableIntroduction :: P.Parsec String u JS
parseVariableIntroduction = do
C.reserved "var"
name <- Ident <$> P.identifier C.tokenParser
value <- P.optionMaybe $ do
_ <- C.lexeme $ P.char '='
value <- parseJS
_ <- C.semi
return value
return $ JSVariableIntroduction name value
parseAssignment :: P.Parsec String u JS
parseAssignment = do
tgt <- parseAssignmentTarget
_ <- C.lexeme $ P.char '='
value <- parseJS
_ <- C.semi
return $ JSAssignment tgt value
parseAssignmentTarget :: P.Parsec String u JSAssignment
parseAssignmentTarget = C.buildPostfixParser [] (JSAssignVariable <$> Ident <$> P.identifier C.tokenParser)
parseWhile :: P.Parsec String u JS
parseWhile = JSWhile <$> (C.reserved "while" *> P.parens C.tokenParser parseJS)
<*> parseJS
parseIf :: P.Parsec String u JS
parseIf = JSIfElse <$> (C.reserved "if" *> P.parens C.tokenParser parseJS)
<*> parseJS
<*> P.optionMaybe (C.reserved "else" >> parseJS)
parseReturn :: P.Parsec String u JS
parseReturn = JSReturn <$> (C.reserved "return" *> parseJS <* C.semi)