diff --git a/purescript.cabal b/purescript.cabal --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.2.10 +version: 0.2.10.1 cabal-version: >=1.8 build-type: Simple license: MIT @@ -46,6 +46,7 @@ Language.PureScript.Parser.State Language.PureScript.Parser.Types Language.PureScript.Parser.Values + Language.PureScript.Parser.JS Language.PureScript.Pretty Language.PureScript.Pretty.Common Language.PureScript.Pretty.JS diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -36,10 +36,7 @@ moduleToJs :: Options -> Module -> Environment -> [JS] moduleToJs opts (Module pname@(ProperName name) decls) env = - let - rawDecls = mapMaybe filterRawDecls decls - in - map JSRaw rawDecls ++ + mapMaybe filterRawDecls decls ++ [ JSVariableIntroduction (Ident name) Nothing , JSApp (JSFunction Nothing [Ident name] (JSBlock (concat $ mapMaybe (\decl -> declToJs opts (ModuleName pname) decl env) decls))) diff --git a/src/Language/PureScript/Declarations.hs b/src/Language/PureScript/Declarations.hs --- a/src/Language/PureScript/Declarations.hs +++ b/src/Language/PureScript/Declarations.hs @@ -20,6 +20,7 @@ import Language.PureScript.Types import Language.PureScript.Names import Language.PureScript.Kinds +import Language.PureScript.CodeGen.JS.AST import qualified Data.Data as D @@ -38,7 +39,7 @@ | TypeDeclaration Ident Type | ValueDeclaration Ident [[Binder]] (Maybe Guard) Value | BindingGroupDeclaration [(Ident, Value)] - | ExternDeclaration Ident (Maybe String) Type + | ExternDeclaration Ident (Maybe JS) Type | ExternDataDeclaration ProperName Kind | FixityDeclaration Fixity String | ImportDeclaration ModuleName (Maybe [Either Ident ProperName]) diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -28,6 +28,8 @@ import Language.PureScript.Parser.Values import Language.PureScript.Parser.Types import Language.PureScript.Parser.Kinds +import Language.PureScript.Parser.JS +import Language.PureScript.CodeGen.JS.AST import Language.PureScript.Values parseDataDeclaration :: P.Parsec String ParseState Declaration @@ -65,8 +67,11 @@ (ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName) <*> (lexeme (indented *> P.string "::") *> parseKind) <|> ExternDeclaration <$> parseIdent - <*> P.optionMaybe stringLiteral + <*> P.optionMaybe (parseJSLiteral <$> stringLiteral) <*> (lexeme (indented *> P.string "::") *> parsePolyType)) + +parseJSLiteral :: String -> JS +parseJSLiteral s = either (const $ JSRaw s) id $ P.runParser parseJS () "Javascript" s parseAssociativity :: P.Parsec String ParseState Associativity parseAssociativity = diff --git a/src/Language/PureScript/Parser/JS.hs b/src/Language/PureScript/Parser/JS.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Parser/JS.hs @@ -0,0 +1,169 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Parser.JS +-- Copyright : (c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- Stability : experimental +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +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) diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs --- a/src/Language/PureScript/Pretty/JS.hs +++ b/src/Language/PureScript/Pretty/JS.hs @@ -219,6 +219,7 @@ , [ unary Not "!" ] , [ unary BitwiseNot "~" ] , [ unary Negate "-" ] + , [ unary Positive "+" ] , [ binary Multiply "*" ] , [ binary Divide "/" ] , [ binary Modulus "%" ] diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -140,6 +140,7 @@ , [ unary Not "!" ] , [ unary BitwiseNot "~" ] , [ unary Negate "-" ] + , [ unary Positive "+" ] , [ binary Multiply "*" ] , [ binary Divide "/" ] , [ binary Modulus "%" ] diff --git a/src/Language/PureScript/Values.hs b/src/Language/PureScript/Values.hs --- a/src/Language/PureScript/Values.hs +++ b/src/Language/PureScript/Values.hs @@ -26,7 +26,8 @@ data UnaryOperator = Negate | Not - | BitwiseNot deriving (Show, Eq, Data, Typeable) + | BitwiseNot + | Positive deriving (Show, Eq, Data, Typeable) data BinaryOperator = Add