diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2007--2012, Brown University, 2008-2012 Claudiu Saftoiu, +2012 Stevens Institute of Technology. +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 Brown University, Stevens Institute of Technology + nor the names of its 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/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/language-ecmascript.cabal b/language-ecmascript.cabal new file mode 100644 --- /dev/null +++ b/language-ecmascript.cabal @@ -0,0 +1,79 @@ +Name: language-ecmascript +Version: 0.9 +Cabal-Version: >= 1.10 +Copyright: (c) 2007-2012 Brown University, (c) 2008-2010 Claudiu Saftoiu, + (c) 2012 Stevens Institute of Technology +License: BSD3 +License-file: LICENSE +Author: Andrey Chudnov, Arjun Guha, Spiridon Aristides Eliopoulos, + Joe Gibbs Politz, Claudiu Saftoiu +Maintainer: Andrey Chudnov +Homepage: http://github.com/jswebtools/language-ecmascript +Bug-reports: http://github.com/jswebtools/language-ecmascript/issues +Stability: provisional +Tested-with: GHC==7.0.4, GHC==7.4.1 +Category: Language +Build-Type: Simple +Synopsis: JavaScript analysis tools +Description: + Some tools for working with ECMAScript 3 (popularly known as JavaScript). + Includes a parser, pretty-printer, and basic building blocks for more + sophisticated tools. + + This package supercedes package WebBits. + +Source-repository head + type: git + location: git://github.com/jswebtools/language-ecmascript.git + +Source-repository this + type: git + location: git://github.com/jswebtools/language-ecmascript.git + tag: 0.9 + +Library + Hs-Source-Dirs: + src + Build-Depends: + base >= 4 && < 5, + mtl >= 1.1.0.1, + parsec < 3.2.0, + pretty >= 0.1, + containers >= 0.1, + syb >= 0.1, + uniplate >= 1.6 && <1.7, + data-default >= 0.4 && <0.5 + ghc-options: + -fwarn-incomplete-patterns + Exposed-Modules: + Language.ECMAScript3 + Language.ECMAScript3.Lexer + Language.ECMAScript3.Parser + Language.ECMAScript3.PrettyPrint + Language.ECMAScript3.Syntax + Language.ECMAScript3.Syntax.Annotations + Language.ECMAScript3.Analysis.Environment + Language.ECMAScript3.Analysis.LabelSets + Default-Extensions: + DeriveDataTypeable, ScopedTypeVariables, DeriveFunctor, DeriveFoldable, DeriveTraversable, FlexibleContexts + Default-Language: Haskell2010 + +Test-Suite unittest + Hs-Source-Dirs: src + Type: exitcode-stdio-1.0 + Main-Is: UnitTest.hs + Build-Depends: + base >= 4 && < 5, + mtl >= 1.1.0.1, + parsec < 3.2.0, + pretty >= 0.1, + containers >= 0.1, + syb >= 0.1, + directory, + filepath, + HUnit, + data-default >=0.4 && <0.5 + Default-Extensions: DeriveDataTypeable, ScopedTypeVariables, DeriveFunctor, DeriveFoldable, DeriveTraversable, FlexibleContexts + Default-Language: Haskell2010 + ghc-options: + -fwarn-incomplete-patterns diff --git a/src/Language/ECMAScript3.hs b/src/Language/ECMAScript3.hs new file mode 100644 --- /dev/null +++ b/src/Language/ECMAScript3.hs @@ -0,0 +1,12 @@ +-- |Re-exports commonly used modules. +module Language.ECMAScript3 + ( module Language.ECMAScript3.Syntax + , module Language.ECMAScript3.Parser + , renderStatements + , renderExpression + ) where + + +import Language.ECMAScript3.Syntax +import Language.ECMAScript3.Parser +import Language.ECMAScript3.PrettyPrint diff --git a/src/Language/ECMAScript3/Analysis/Environment.hs b/src/Language/ECMAScript3/Analysis/Environment.hs new file mode 100644 --- /dev/null +++ b/src/Language/ECMAScript3/Analysis/Environment.hs @@ -0,0 +1,156 @@ +-- | A lexical environment analysis of ECMAScript programs + +module Language.ECMAScript3.Analysis.Environment + ( env + , localVars + , EnvTree (..) + ) where + +import Data.List +import Data.Maybe +import qualified Data.Map as M +import Data.Map (Map) +import qualified Data.Set as S +import Data.Set (Set) +import Text.ParserCombinators.Parsec.Pos (SourcePos) + +import Language.ECMAScript3.Syntax + +-- | Intermediate data structure that contains locally declared names and +-- all references to identifers. +data Partial = Partial { + partialLocals :: M.Map String SourcePos, + partialReferences :: M.Map String SourcePos, + partialNested :: [Partial] +} + +empty :: Partial +empty = Partial M.empty M.empty [] + +ref :: Id SourcePos -> Partial +ref (Id p v) = Partial M.empty (M.singleton v p) [] + +decl :: Id SourcePos -> Partial +decl (Id p v) = Partial (M.singleton v p) M.empty [] + +nest :: Partial -> Partial +nest partial = Partial M.empty M.empty [partial] + +-- Combine partial results from the same lexical scope. +unions :: [Partial] -> Partial +unions ps = Partial (M.unions (map partialLocals ps)) + (M.unions (map partialReferences ps)) + (concatMap partialNested ps) + +javascript :: JavaScript SourcePos -> Partial +javascript (Script _ ss) = unions (map stmt ss) + + +lvalue :: LValue SourcePos -> Partial +lvalue lv = case lv of + LVar p x -> ref (Id p x) + LDot _ e _ -> expr e + LBracket _ e1 e2 -> unions [expr e1, expr e2] + +expr :: Expression SourcePos -> Partial +expr e = case e of + StringLit _ _ -> empty + RegexpLit {} -> empty + NumLit _ _ -> empty + IntLit _ _ -> empty + BoolLit _ _ -> empty + NullLit _ -> empty + ArrayLit _ es -> unions (map expr es) + ObjectLit _ props -> unions (map (expr.snd) props) + ThisRef _ -> empty + VarRef _ id -> empty + DotRef _ e _ -> expr e + BracketRef _ e1 e2 -> unions [expr e1, expr e2] + NewExpr _ e1 es -> unions [expr e1, unions $ map expr es] + PrefixExpr _ _ e -> expr e + InfixExpr _ _ e1 e2 -> unions [expr e1, expr e2] + CondExpr _ e1 e2 e3 -> unions [expr e1, expr e2, expr e3] + AssignExpr _ _ lv e -> unions [lvalue lv, expr e] + UnaryAssignExpr _ _ lv -> lvalue lv + ParenExpr _ e -> expr e + ListExpr _ es -> unions (map expr es) + CallExpr _ e es -> unions [expr e, unions $ map expr es] + FuncExpr _ _ args s -> nest $ unions [unions $ map decl args, stmt s] + +caseClause :: CaseClause SourcePos -> Partial +caseClause cc = case cc of + CaseClause _ e ss -> unions [expr e, unions $ map stmt ss] + CaseDefault _ ss -> unions $ map stmt ss + +-- TODO: Verify that this is a declaration and not a reference. +catchClause :: CatchClause SourcePos -> Partial +catchClause (CatchClause _ id s) = unions [decl id, stmt s] + +varDecl :: VarDecl SourcePos -> Partial +varDecl (VarDecl _ id Nothing) = decl id +varDecl (VarDecl _ id (Just e)) = unions [decl id, expr e] + +forInit :: ForInit SourcePos -> Partial +forInit fi = case fi of + NoInit -> empty + VarInit ds -> unions $ map varDecl ds + ExprInit e -> expr e + +forInInit :: ForInInit SourcePos -> Partial +forInInit (ForInVar id) = decl id +forInInit (ForInLVal lv) = lvalue lv + +stmt :: Statement SourcePos -> Partial +stmt s = case s of + BlockStmt _ ss -> unions $ map stmt ss + EmptyStmt _ -> empty + ExprStmt _ e -> expr e + IfStmt _ e s1 s2 -> unions [expr e, stmt s1, stmt s2] + IfSingleStmt _ e s -> unions [expr e, stmt s] + SwitchStmt _ e cases -> unions [expr e, unions $ map caseClause cases] + WhileStmt _ e s -> unions [expr e, stmt s] + DoWhileStmt _ s e -> unions [stmt s, expr e] + BreakStmt _ _ -> empty + ContinueStmt _ _ -> empty + LabelledStmt _ _ s -> stmt s + ForInStmt _ fii e s -> unions [forInInit fii, expr e, stmt s] + ForStmt _ fi me1 me2 s -> + unions [forInit fi, maybe empty expr me1, maybe empty expr me2, stmt s] + TryStmt _ s mcatch ms -> + unions [stmt s, maybe empty catchClause mcatch, maybe empty stmt ms] + ThrowStmt _ e -> expr e + ReturnStmt _ me -> maybe empty expr me + WithStmt _ e s -> unions [expr e, stmt s] + VarDeclStmt _ decls -> unions $ map varDecl decls + FunctionStmt _ fnId args s -> + unions [decl fnId, nest $ unions [unions $ map decl args, stmt s]] + +-- |The statically-determinate lexical structure of a JavaScript program. +data EnvTree = EnvTree (M.Map String SourcePos) [EnvTree] + +-- A 'Partial' specifies identifier references in addition to identifier +-- declarations. We descend into a 'Partial', pushing enclosing declarations +-- in to remove references to identifiers declared in the enclosing scope. +-- Any referencs to identifiers not declared in either the current or the +-- enclosing scope are local definitions of global variables. +makeEnvTree :: Map String SourcePos -- ^enclosing environment + -> Partial -- ^local environment and references + -> (EnvTree,Map String SourcePos) + -- ^environment and global definitions +makeEnvTree enclosing (Partial locals references nested) = (tree,globals) where + nestedResults = map (makeEnvTree (locals `M.union` enclosing)) nested + tree = EnvTree locals (map fst nestedResults) + globals' = (references `M.difference` locals) `M.difference` enclosing + globals = M.unions (globals':map snd nestedResults) + +env :: Map String SourcePos -- ^browser/testing environment + -> [Statement SourcePos] + -> (EnvTree,Map String SourcePos) +env globals program = makeEnvTree globals (unions $ map stmt program) + + +localVars :: [Statement SourcePos] + -> [(String, SourcePos)] +localVars body = M.toList locals where + Partial locals _ _ = unions $ map stmt body + diff --git a/src/Language/ECMAScript3/Analysis/LabelSets.hs b/src/Language/ECMAScript3/Analysis/LabelSets.hs new file mode 100644 --- /dev/null +++ b/src/Language/ECMAScript3/Analysis/LabelSets.hs @@ -0,0 +1,88 @@ +-- | Label-set analysis which annotates all the statements in the script +-- with their label sets according to ECMAScript specification, +-- section 12.12. The result of this analysis are useful for building +-- control-flow graphs. + +module Language.ECMAScript3.Analysis.LabelSets (annotateLabelSets + ,Label(..)) where + +import Language.ECMAScript3.Syntax +import Language.ECMAScript3.Syntax.Annotations +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Generics.Uniplate.Data +import Data.Data (Data) +import Control.Applicative +import Data.Typeable (Typeable) + +-- | Labels are either strings (identifiers) or /empty/ (see 12.12 of +-- the spec) +data Label = Label String + | EmptyLabel + deriving (Ord, Eq, Show, Data, Typeable) + +-- | Annotates statements with their label sets; example use: +-- +-- >>> let jsa = reannotate (\a -> (a, Set.empty)) +-- >>> in annotateLabelSets jsa snd (\labs (a, ls) -> (a, labs `Set.union` ls)) +annotateLabelSets :: Data a => + (a -> Set Label) -- ^ annotation read function + -> (Set Label -> a -> a) -- ^ annotation write function + -> JavaScript a -- ^ the script to annotate + -> JavaScript a +annotateLabelSets r w = transformBi (annotateFuncStmtBodies r w) + . transformBi (annotateFuncExprBodies r w) + . descendBi (annotateStatement r w) + +annotateFuncStmtBodies :: Data a => + (a -> Set Label) + -> (Set Label -> a -> a) + -> Statement a + -> Statement a +annotateFuncStmtBodies r w s = case s of + FunctionStmt a name params body -> + let newbody = descend (annotateStatement r w) body + in FunctionStmt a name params newbody + _ -> s + +annotateFuncExprBodies :: Data a => + (a -> Set Label) + -> (Set Label -> a -> a) + -> Expression a + -> Expression a +annotateFuncExprBodies r w e = case e of + FuncExpr a mname params body -> + let newbody = descend (annotateStatement r w) body + in FuncExpr a mname params newbody + _ -> e + +-- | 12.12 ECMA262: the production /Identifier/ : /Statement/ is +-- evaluated by adding /Identifier/ to the label ser of /Statement/ +-- and then evluating /Statement/. If the /LabelledStatement/ itsef +-- has a non-empty label set, these labels are also added to the label +-- set of /Statement/ before evaluating it. ... Prior to evaluation of +-- a /LabelledStatement/, the contained /Statement/ is regarded as +-- possessing an empty label set, unless it is an /IterationStatement/ +-- or a /SwitchStatement/, in which case it is regarded as possessing +-- a label set consisting of the single element, @empty@. +annotateStatement :: Data a => + (a -> Set Label) + -> (Set Label -> a -> a) + -> Statement a + -> Statement a +annotateStatement r w s = case s of + LabelledStmt ann lab stmt -> + let labelset = Set.insert (id2Label lab) (r ann) + newstmt = annotateStatement r w $ w labelset <$> stmt + in LabelledStmt ann lab newstmt + SwitchStmt {} -> + let labelset = Set.insert EmptyLabel (r $ getAnnotation s) + in descend (annotateStatement r w) (w labelset <$> s) + _ | isIterationStmt s -> + let labelset = Set.insert EmptyLabel (r $ getAnnotation s) + in descend (annotateStatement r w) (w labelset <$> s) + _ -> descend (annotateStatement r w) s + +id2Label :: Id a -> Label +id2Label = Label . unId + diff --git a/src/Language/ECMAScript3/Lexer.hs b/src/Language/ECMAScript3/Lexer.hs new file mode 100644 --- /dev/null +++ b/src/Language/ECMAScript3/Lexer.hs @@ -0,0 +1,65 @@ +-- | This isn't a lexer in the sense that it provides a JavaScript +-- token-stream. This module provides character-parsers for various +-- JavaScript tokens. + +module Language.ECMAScript3.Lexer(lexeme,identifier,reserved,operator,reservedOp,charLiteral, + stringLiteral,natural,integer,float,naturalOrFloat, + decimal,hexadecimal,octal,symbol,whiteSpace,parens, + braces,brackets,squares,semi,comma,colon,dot, + identifierStart) where + +import Prelude hiding (lex) +import Text.Parsec +import qualified Text.Parsec.Token as T + +identifierStart = letter <|> oneOf "$_" + +javascriptDef = + T.LanguageDef "/*" + "*/" + "//" + False -- no nested comments + identifierStart + (alphaNum <|> oneOf "$_") -- identifier rest + (oneOf "{}<>()~.,?:|&^=!+-*/%!") -- operator start + (oneOf "=<>|&+") -- operator rest + ["break", "case", "catch", "const", "continue", "debugger", + "default", "delete", "do", "else", "enum", "false", "finally", + "for", "function", "if", "instanceof", "in", "let", "new", + "null", "return", "switch", "this", "throw", "true", "try", + "typeof", "var", "void", "while", "with"] + ["|=", "^=", "&=", "<<=", ">>=", ">>>=", "+=", "-=", "*=", "/=", + "%=", "=", ";", ",", "?", ":", "||", "&&", "|", "^", "&", + "===", "==", "=", "!==", "!=", "<<", "<=", "<", ">>>", ">>", + ">=", ">", "++", "--", "+", "-", "*", "/", "%", "!", "~", ".", + "[", "]", "{", "}", "(", ")"," CharParser () +pushLabel lab = do labs <- getState + pos <- getPosition + if lab `elem` labs + then fail $ "Duplicate label at " ++ show pos + else putState (lab:labs) + +popLabel :: CharParser () +popLabel = modifyState safeTail + where safeTail [] = [] + safeTail (_:xs) = xs + +clearLabels :: ParserState -> ParserState +clearLabels _ = [] + +withFreshLabelStack :: CharParser a -> CharParser a +withFreshLabelStack p = do oldState <- getState + putState $ clearLabels oldState + a <- p + putState oldState + return a + +identifier :: CharParser (Id SourcePos) +identifier = + liftM2 Id getPosition Lexer.identifier + +--{{{ Statements + +-- Keep in mind that Token.reserved parsers (exported from the lexer) do not +-- consume any input on failure. Note that all statements (expect for labelled +-- and expression statements) begin with a reserved-word. If we fail to parse +-- this reserved-word, no input is consumed. Hence, we can have the massive or +-- block that is parseExpression. Note that if the reserved-word is parsed, it +-- must be whatever statement the reserved-word indicates. If we fail after the +-- reserved-word, we truly have a syntax error. Since input has been consumed, +-- <|> will not try its alternate in parseExpression, and we will fail. + +parseIfStmt:: StatementParser +parseIfStmt = do + pos <- getPosition + reserved "if" + test <- parseParenExpr "parenthesized test-expression in if statement" + consequent <- parseStatement "true-branch of if statement" + optional semi -- TODO: in spec? + ((do reserved "else" + alternate <- parseStatement + return $ IfStmt pos test consequent alternate) + <|> return (IfSingleStmt pos test consequent)) + +parseSwitchStmt:: StatementParser +parseSwitchStmt = + let parseDefault = do + pos <- getPosition + reserved "default" + colon + statements <- many parseStatement + return (CaseDefault pos statements) + parseCase = do + pos <- getPosition + reserved "case" + condition <- parseListExpr + colon + actions <- many parseStatement + return (CaseClause pos condition actions) + isCaseDefault (CaseDefault _ _) = True + isCaseDefault _ = False + checkClauses cs = case filter isCaseDefault cs of + (_:c:_) -> fail $ "duplicate default clause in switch statement at " ++ + show (getAnnotation c) + _ -> return () + in do pos <- getPosition + reserved "switch" + test <- parseParenExpr + clauses <- braces $ many $ parseDefault <|> parseCase + checkClauses clauses + return (SwitchStmt pos test clauses) + +parseWhileStmt:: StatementParser +parseWhileStmt = do + pos <- getPosition + reserved "while" + test <- parseParenExpr "parenthesized test-expression in while loop" + body <- parseStatement + return (WhileStmt pos test body) + +parseDoWhileStmt:: StatementParser +parseDoWhileStmt = do + pos <- getPosition + reserved "do" + body <- parseBlockStmt + reserved "while" "while at the end of a do block" + test <- parseParenExpr "parenthesized test-expression in do loop" + optional semi + return (DoWhileStmt pos body test) + +parseContinueStmt:: StatementParser +parseContinueStmt = do + pos <- getPosition + reserved "continue" + pos' <- getPosition + -- Ensure that the identifier is on the same line as 'continue.' + id <- if sourceLine pos == sourceLine pos' + then liftM Just identifier <|> return Nothing + else return Nothing + optional semi + return $ ContinueStmt pos id + +parseBreakStmt:: StatementParser +parseBreakStmt = do + pos <- getPosition + reserved "break" + pos' <- getPosition + -- Ensure that the identifier is on the same line as 'break.' + id <- if sourceLine pos == sourceLine pos' + then liftM Just identifier <|> return Nothing + else return Nothing + optional semi + return $ BreakStmt pos id + +parseBlockStmt:: StatementParser +parseBlockStmt = do + pos <- getPosition + statements <- braces (many parseStatement) + return (BlockStmt pos statements) + +parseEmptyStmt:: StatementParser +parseEmptyStmt = do + pos <- getPosition + semi + return (EmptyStmt pos) + +parseLabelledStmt:: StatementParser +parseLabelledStmt = do + pos <- getPosition + -- Lookahead for the colon. If we don't see it, we are parsing an identifier + -- for an expression statement. + label <- try (do label <- identifier + colon + return label) + pushLabel $ unId label + statement <- parseStatement + popLabel + return (LabelledStmt pos label statement) + +parseExpressionStmt:: StatementParser +parseExpressionStmt = do + pos <- getPosition + expr <- parseListExpr -- TODO: spec 12.4? + optional semi + return $ ExprStmt pos expr + + +parseForInStmt:: StatementParser +parseForInStmt = + let parseInit = (reserved "var" >> liftM ForInVar identifier) + <|> liftM ForInLVal lvalue + in do pos <- getPosition + -- Lookahead, so that we don't clash with parseForStmt + (init,expr) <- try $ do reserved "for" + parens $ do init <- parseInit + reserved "in" + expr <- parseExpression + return (init,expr) + body <- parseStatement + return $ ForInStmt pos init expr body + +parseForStmt:: StatementParser +parseForStmt = + let parseInit = (reserved "var" >> liftM VarInit (parseVarDecl `sepBy` comma)) + <|> liftM ExprInit parseListExpr + <|> return NoInit + in do pos <- getPosition + reserved "for" + reservedOp "(" + init <- parseInit + semi + test <- optionMaybe parseExpression + semi + iter <- optionMaybe parseListExpr + reservedOp ")" "closing paren" + stmt <- parseStatement + return $ ForStmt pos init test iter stmt + +parseTryStmt:: StatementParser +parseTryStmt = + let parseCatchClause = do pos <- getPosition + reserved "catch" + id <- parens identifier + stmt <- parseStatement + return $ CatchClause pos id stmt + in do reserved "try" + pos <- getPosition + guarded <- parseStatement + mCatch <- optionMaybe parseCatchClause + mFinally <- optionMaybe $ reserved "finally" >> parseStatement + -- the spec requires at least a catch or a finally block to + -- be present + if isJust mCatch || isJust mFinally + then return $ TryStmt pos guarded mCatch mFinally + else fail $ "A try statement should have at least a catch\ + \ or a finally block, at " ++ show pos + +parseThrowStmt:: StatementParser +parseThrowStmt = do + pos <- getPosition + reserved "throw" + expr <- parseExpression + optional semi + return (ThrowStmt pos expr) + +parseReturnStmt:: StatementParser +parseReturnStmt = do + pos <- getPosition + reserved "return" + expr <- optionMaybe parseListExpr + optional semi + return (ReturnStmt pos expr) + +parseWithStmt:: StatementParser +parseWithStmt = do + pos <- getPosition + reserved "with" + context <- parseParenExpr + stmt <- parseStatement + return (WithStmt pos context stmt) + +parseVarDecl = do + pos <- getPosition + id <- identifier + init <- (reservedOp "=" >> liftM Just parseExpression) <|> return Nothing + return (VarDecl pos id init) + +parseVarDeclStmt:: StatementParser +parseVarDeclStmt = do + pos <- getPosition + reserved "var" + decls <- parseVarDecl `sepBy` comma + optional semi + return (VarDeclStmt pos decls) + +parseFunctionStmt:: StatementParser +parseFunctionStmt = do + pos <- getPosition + name <- try (reserved "function" >> identifier) -- ambiguity with FuncExpr + args <- parens (identifier `sepBy` comma) + -- label sets don't cross function boundaries + body <- withFreshLabelStack parseBlockStmt "function body in { ... }" + return (FunctionStmt pos name args body) + +parseStatement:: StatementParser +parseStatement = parseIfStmt <|> parseSwitchStmt <|> parseWhileStmt + <|> parseDoWhileStmt <|> parseContinueStmt <|> parseBreakStmt + <|> parseBlockStmt <|> parseEmptyStmt <|> parseForInStmt <|> parseForStmt + <|> parseTryStmt <|> parseThrowStmt <|> parseReturnStmt <|> parseWithStmt + <|> parseVarDeclStmt <|> parseFunctionStmt + -- labelled, expression and the error message always go last, in this order + <|> parseLabelledStmt <|> parseExpressionStmt "statement" + +--}}} + +--{{{ Expressions + +-- References used to construct this stuff: +-- + http://developer.mozilla.org/en/docs/ +-- Core_JavaScript_1.5_Reference:Operators:Operator_Precedence +-- + http://www.mozilla.org/js/language/grammar14.html +-- +-- Aren't expression tables nice? Well, we can't quite use them, because of +-- JavaScript's ternary (?:) operator. We have to use two expression tables. +-- We use one expression table for the assignment operators that bind looser +-- than ?: (assignTable). The terms of assignTable are ternary expressions +-- (parseTernaryExpr). parseTernaryExpr left-factors the left-recursive +-- production for ?:, and is defined over the second expression table, +-- exprTable, which consists of operators that bind tighter than ?:. The terms +-- of exprTable are atomic expressions, parenthesized expressions, functions and +-- array references. + +--{{{ Primary expressions + +parseThisRef:: ExpressionParser +parseThisRef = do + pos <- getPosition + reserved "this" + return (ThisRef pos) + +parseNullLit:: ExpressionParser +parseNullLit = do + pos <- getPosition + reserved "null" + return (NullLit pos) + + +parseBoolLit:: ExpressionParser +parseBoolLit = do + pos <- getPosition + let parseTrueLit = reserved "true" >> return (BoolLit pos True) + parseFalseLit = reserved "false" >> return (BoolLit pos False) + parseTrueLit <|> parseFalseLit + +parseVarRef:: ExpressionParser +parseVarRef = liftM2 VarRef getPosition identifier + +parseArrayLit:: ExpressionParser +parseArrayLit = liftM2 ArrayLit getPosition (squares (parseExpression `sepEndBy` comma)) + +parseFuncExpr = do + pos <- getPosition + reserved "function" + name <- optionMaybe identifier + args <- parens (identifier `sepBy` comma) + -- labels don't cross function boundaries + body <- withFreshLabelStack parseBlockStmt + return $ FuncExpr pos name args body + +--{{{ parsing strings + +escapeChars = + [('\'','\''),('\"','\"'),('\\','\\'),('b','\b'),('f','\f'),('n','\n'), + ('r','\r'),('t','\t'),('v','\v'),('/','/'),(' ',' '),('0','\0')] + +allEscapes:: String +allEscapes = map fst escapeChars + +parseEscapeChar = do + c <- oneOf allEscapes + let (Just c') = lookup c escapeChars -- will succeed due to line above + return c' + +parseAsciiHexChar = do + char 'x' + d1 <- hexDigit + d2 <- hexDigit + return ((chr.fst.head.readHex) (d1:d2:"")) + +parseUnicodeHexChar = do + char 'u' + liftM (chr.fst.head.readHex) + (sequence [hexDigit,hexDigit,hexDigit,hexDigit]) + +isWhitespace ch = ch `elem` " \t" + + +-- The endWith argument is either single-quote or double-quote, depending on how +-- we opened the string. +parseStringLit' endWith = + (char endWith >> return "") <|> + (do try (string "\\'") + cs <- parseStringLit' endWith + return $ "'" ++ cs) <|> + (do char '\\' + c <- parseEscapeChar <|> parseAsciiHexChar <|> parseUnicodeHexChar <|> + char '\r' <|> char '\n' + cs <- parseStringLit' endWith + if c == '\r' || c == '\n' + then return (c:dropWhile isWhitespace cs) + else return (c:cs)) <|> + liftM2 (:) anyChar (parseStringLit' endWith) + +parseStringLit:: ExpressionParser +parseStringLit = do + pos <- getPosition + -- parseStringLit' takes as an argument the quote-character that opened the + -- string. + str <- lexeme $ (char '\'' >>= parseStringLit') <|> (char '\"' >>= parseStringLit') + -- CRUCIAL: Parsec.Token parsers expect to find their token on the first + -- character, and read whitespaces beyond their tokens. Without 'lexeme' + -- above, expressions like: + -- var s = "string" ; + -- do not parse. + return $ StringLit pos str + +--}}} + +parseRegexpLit:: ExpressionParser +parseRegexpLit = do + let parseFlags = do + flags <- many (oneOf "mgi") + return $ \f -> f ('g' `elem` flags) ('i' `elem` flags) + let parseEscape :: CharParser Char + parseEscape = char '\\' >> anyChar + let parseChar :: CharParser Char + parseChar = noneOf "/" + let parseRe = (char '/' >> return "") <|> + (do char '\\' + ch <- anyChar -- TOOD: too lenient + rest <- parseRe + return ('\\':ch:rest)) <|> + liftM2 (:) anyChar parseRe + pos <- getPosition + char '/' + pat <- parseRe --many1 parseChar + flags <- parseFlags + spaces -- crucial for Parsec.Token parsers + return $ flags (RegexpLit pos pat) + +parseObjectLit:: ExpressionParser +parseObjectLit = + let parseProp = do + -- Parses a string, identifier or integer as the property name. I + -- apologize for the abstruse style, but it really does make the code + -- much shorter. + name <- liftM (\(StringLit p s) -> PropString p s) parseStringLit + <|> liftM2 PropId getPosition identifier + <|> liftM2 PropNum getPosition decimal + colon + val <- assignExpr + return (name,val) + in do pos <- getPosition + props <- braces (parseProp `sepEndBy` comma) "object literal" + return $ ObjectLit pos props + +--{{{ Parsing numbers. From pg. 17-18 of ECMA-262. + +hexLit = do + try (string "0x") + digits <- many1 (oneOf "0123456789abcdefABCDEF") + [(hex,"")] <- return $ Numeric.readHex digits + return (True, hex) + +-- Creates a decimal value from a whole, fractional and exponent part. +mkDecimal:: Double -> Double -> Int -> Double +mkDecimal w f e = if f >= 1.0 + then mkDecimal w (f / 10.0) e + else (w + f) * (10.0 ^^ e) + +exponentPart = do + oneOf "eE" + (char '+' >> decimal) <|> (char '-' >> negate `fmap` decimal) <|> decimal + +--wrap a parser's result in a Just: +jparser = liftM Just + +decLit = + (do whole <- decimal + mfrac <- option Nothing (jparser (char '.' >> decimal)) + mexp <- option Nothing (jparser exponentPart) + if isNothing mfrac && isNothing mexp + then return (True, fromIntegral whole) + else return (False, mkDecimal (fromIntegral whole) + (fromIntegral (fromMaybe 0 mfrac)) + (fromIntegral (fromMaybe 0 mexp)))) <|> + (do frac <- char '.' >> decimal + exp <- option 0 exponentPart + return (False, mkDecimal 0.0 (fromIntegral frac) (fromIntegral exp))) + +parseNumLit:: ExpressionParser +parseNumLit = do + pos <- getPosition + (isint, num) <- lexeme $ hexLit <|> decLit + notFollowedBy identifierStart "whitespace" + if isint + then return $ IntLit pos (round num) + else return $ NumLit pos num + + +------------------------------------------------------------------------------ +-- Position Helper +------------------------------------------------------------------------------ + +withPos cstr p = do { pos <- getPosition; e <- p; return $ cstr pos e } + +------------------------------------------------------------------------------- +-- Compound Expression Parsers +------------------------------------------------------------------------------- + +dotRef e = (reservedOp "." >> withPos cstr identifier) "property.ref" + where cstr pos = DotRef pos e + +funcApp e = parens (withPos cstr (parseExpression `sepBy` comma)) + "(function application)" + where cstr pos = CallExpr pos e + +bracketRef e = brackets (withPos cstr parseExpression) "[property-ref]" + where cstr pos = BracketRef pos e + +------------------------------------------------------------------------------- +-- Expression Parsers +------------------------------------------------------------------------------- + +parseParenExpr:: ExpressionParser +parseParenExpr = withPos ParenExpr (parens parseListExpr) + +-- everything above expect functions +parseExprForNew = parseThisRef <|> parseNullLit <|> parseBoolLit <|> parseStringLit + <|> parseArrayLit <|> parseParenExpr <|> parseNewExpr <|> parseNumLit + <|> parseRegexpLit <|> parseObjectLit <|> parseVarRef + +-- all the expression parsers defined above +parseSimpleExpr' = parseThisRef <|> parseNullLit <|> parseBoolLit + <|> parseStringLit <|> parseArrayLit <|> parseParenExpr + <|> parseFuncExpr <|> parseNumLit <|> parseRegexpLit <|> parseObjectLit + <|> parseVarRef + +parseNewExpr = + (do pos <- getPosition + reserved "new" + constructor <- parseSimpleExprForNew Nothing -- right-associativity + arguments <- try (parens (parseExpression `sepBy` comma)) <|> return [] + return (NewExpr pos constructor arguments)) <|> + parseSimpleExpr' + +parseSimpleExpr (Just e) = ((dotRef e <|> funcApp e <|> bracketRef e) >>= + parseSimpleExpr . Just) + <|> return e +parseSimpleExpr Nothing = do + e <- parseNewExpr "expression (3)" + parseSimpleExpr (Just e) + +parseSimpleExprForNew (Just e) = ((dotRef e <|> bracketRef e) >>= + parseSimpleExprForNew . Just) + <|> return e +parseSimpleExprForNew Nothing = do + e <- parseNewExpr "expression (3)" + parseSimpleExprForNew (Just e) + +--}}} + +makeInfixExpr str constr = Infix parser AssocLeft where + parser:: CharParser (Expression SourcePos -> Expression SourcePos -> Expression SourcePos) + parser = do + pos <- getPosition + reservedOp str + return (InfixExpr pos constr) -- points-free, returns a function + + +-- apparently, expression tables can't handle immediately-nested prefixes +parsePrefixedExpr = do + pos <- getPosition + op <- optionMaybe $ (reservedOp "!" >> return PrefixLNot) <|> + (reservedOp "~" >> return PrefixBNot) <|> + (try (lexeme $ char '-' >> notFollowedBy (char '-')) >> + return PrefixMinus) <|> + (try (lexeme $ char '+' >> notFollowedBy (char '+')) >> + return PrefixPlus) <|> + (reserved "typeof" >> return PrefixTypeof) <|> + (reserved "void" >> return PrefixVoid) <|> + (reserved "delete" >> return PrefixDelete) + case op of + Nothing -> unaryAssignExpr + Just op -> do + innerExpr <- parsePrefixedExpr + return (PrefixExpr pos op innerExpr) + +exprTable:: [[Operator String ParserState Identity ParsedExpression]] +exprTable = + [ [ makeInfixExpr "==" OpEq + , makeInfixExpr "!=" OpNEq + , makeInfixExpr "===" OpStrictEq + , makeInfixExpr "!==" OpStrictNEq + ] + + , [ makeInfixExpr "||" OpLOr ] + + , [ makeInfixExpr "&&" OpLAnd ] + + , [ makeInfixExpr "|" OpBOr ] + + , [ makeInfixExpr "^" OpBXor ] + + , [ makeInfixExpr "&" OpBAnd ] + + , [ makeInfixExpr "<" OpLT + , makeInfixExpr "<=" OpLEq + , makeInfixExpr ">" OpGT + , makeInfixExpr ">=" OpGEq + , makeInfixExpr "instanceof" OpInstanceof + , makeInfixExpr "in" OpIn + ] + + , [ makeInfixExpr "<<" OpLShift + , makeInfixExpr ">>" OpSpRShift + , makeInfixExpr ">>>" OpZfRShift + ] + + , [ makeInfixExpr "+" OpAdd + , makeInfixExpr "-" OpSub + ] + + , [ makeInfixExpr "*" OpMul + , makeInfixExpr "/" OpDiv + , makeInfixExpr "%" OpMod + ] + ] + +parseExpression' = + buildExpressionParser exprTable parsePrefixedExpr "simple expression" + +asLValue :: SourcePos + -> Expression SourcePos + -> CharParser (LValue SourcePos) +asLValue p' e = case e of + VarRef p (Id _ x) -> return (LVar p x) + DotRef p e (Id _ x) -> return (LDot p e x) + BracketRef p e1 e2 -> return (LBracket p e1 e2) + otherwise -> fail $ "expected a left-value at " ++ show p' + +lvalue :: CharParser (LValue SourcePos) +lvalue = do + p <- getPosition + e <- parseSimpleExpr Nothing + asLValue p e + + +unaryAssignExpr :: CharParser ParsedExpression +unaryAssignExpr = do + p <- getPosition + let prefixInc = do + reservedOp "++" + liftM (UnaryAssignExpr p PrefixInc) lvalue + let prefixDec = do + reservedOp "--" + liftM (UnaryAssignExpr p PrefixDec) lvalue + let postfixInc e = do + reservedOp "++" + liftM (UnaryAssignExpr p PostfixInc) (asLValue p e) + let postfixDec e = do + reservedOp "--" + liftM (UnaryAssignExpr p PostfixDec) (asLValue p e) + let other = do + e <- parseSimpleExpr Nothing + postfixInc e <|> postfixDec e <|> return e + prefixInc <|> prefixDec <|> other + + +parseTernaryExpr':: CharParser (ParsedExpression,ParsedExpression) +parseTernaryExpr' = do + reservedOp "?" + l <- assignExpr + colon + r <- assignExpr + return (l,r) + +parseTernaryExpr:: ExpressionParser +parseTernaryExpr = do + e <- parseExpression' + e' <- optionMaybe parseTernaryExpr' + case e' of + Nothing -> return e + Just (l,r) -> do p <- getPosition + return $ CondExpr p e l r + + +assignOp :: CharParser AssignOp +assignOp = + (reservedOp "=" >> return OpAssign) <|> + (reservedOp "+=" >> return OpAssignAdd) <|> + (reservedOp "-=" >> return OpAssignSub) <|> + (reservedOp "*=" >> return OpAssignMul) <|> + (reservedOp "/=" >> return OpAssignDiv) <|> + (reservedOp "%=" >> return OpAssignMod) <|> + (reservedOp "<<=" >> return OpAssignLShift) <|> + (reservedOp ">>=" >> return OpAssignSpRShift) <|> + (reservedOp ">>>=" >> return OpAssignZfRShift) <|> + (reservedOp "&=" >> return OpAssignBAnd) <|> + (reservedOp "^=" >> return OpAssignBXor) <|> + (reservedOp "|=" >> return OpAssignBOr) + + +assignExpr :: ExpressionParser +assignExpr = do + p <- getPosition + lhs <- parseTernaryExpr + let assign = do + op <- assignOp + lhs <- asLValue p lhs + rhs <- assignExpr + return (AssignExpr p op lhs rhs) + assign <|> return lhs + +parseExpression:: ExpressionParser +parseExpression = assignExpr + +parseListExpr = liftM2 ListExpr getPosition (assignExpr `sepBy1` comma) + +parseScript:: CharParser (JavaScript SourcePos) +parseScript = do + whiteSpace + liftM2 Script getPosition (parseStatement `sepBy` whiteSpace) + +-- | Parse from a stream; same as 'Text.Parsec.parse' +parse :: Stream s Identity t => + Parsec s [String] a -- ^ The parser to use + -> SourceName -- ^ Name of the source file + -> s -- ^ the stream to parse, usually a 'String' + -> Either ParseError a +parse p = runParser p initialParserState + +-- | Read a JavaScript program from file an parse it into a list of +-- statements +parseJavaScriptFromFile :: MonadIO m => String -- ^ file name + -> m [Statement SourcePos] +parseJavaScriptFromFile filename = do + chars <- liftIO $ readFile filename + case parse parseScript filename chars of + Left err -> fail (show err) + Right (Script _ stmts) -> return stmts + +-- | Parse a JavaScript program from a string +parseScriptFromString :: String -- ^ source file name + -> String -- ^ JavaScript source to parse + -> Either ParseError (JavaScript SourcePos) +parseScriptFromString = parse parseScript + +-- | Parse a JavaScript source string into a list of statements +parseString :: String -- ^ JavaScript source + -> [Statement SourcePos] +parseString str = case parse parseScript "" str of + Left err -> error (show err) + Right (Script _ stmts) -> stmts diff --git a/src/Language/ECMAScript3/PrettyPrint.hs b/src/Language/ECMAScript3/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/src/Language/ECMAScript3/PrettyPrint.hs @@ -0,0 +1,231 @@ +-- |Pretty-printing JavaScript. +module Language.ECMAScript3.PrettyPrint + ( +-- stmt +-- , expr + javaScript + , renderStatements + , renderExpression + ) where + +import Text.PrettyPrint.HughesPJ +import Language.ECMAScript3.Syntax + +-- | Renders a list of statements as a 'String' +renderStatements :: [Statement a] -> String +renderStatements = render . stmtList + +-- | Renders a list of statements as a 'String' +renderExpression :: Expression a -> String +renderExpression = render . expr + +-- Displays the statement in { ... }, unless it is a block itself. +inBlock:: Statement a -> Doc +inBlock s@(BlockStmt _ _) = stmt s +inBlock s = lbrace $+$ nest 2 (stmt s) $+$ rbrace + +-- Displays the expression in ( ... ), unless it is a parenthesized expression +inParens:: Expression a -> Doc +inParens e@(ParenExpr _ _) = expr e +inParens e = parens (expr e) + +pp (Id _ str) = text str + +forInit :: ForInit a -> Doc +forInit t = case t of + NoInit -> empty + VarInit vs -> text "var" <+> cat (punctuate comma $ map varDecl vs) + ExprInit e -> expr e + +forInInit :: ForInInit a -> Doc +forInInit t = case t of + ForInVar id -> text "var" <+> pp id + ForInLVal lv -> lvalue lv + +caseClause :: CaseClause a -> Doc +caseClause (CaseClause _ e ss) = + text "case" $+$ expr e <+> colon $$ nest 2 (stmtList ss) +caseClause (CaseDefault _ ss) = + text "default:" $$ nest 2 (stmtList ss) + +varDecl :: VarDecl a -> Doc +varDecl (VarDecl _ id Nothing) = pp id +varDecl (VarDecl _ id (Just e)) = pp id <+> equals <+> expr e + +stmt :: Statement a -> Doc +stmt s = case s of + BlockStmt _ ss -> lbrace $+$ nest 2 (stmtList ss) $$ rbrace + EmptyStmt _ -> semi + ExprStmt _ e -> expr e <> semi + IfSingleStmt _ test cons -> text "if" <+> inParens test $$ stmt cons + IfStmt _ test cons alt -> + text "if" <+> inParens test $$ stmt cons $$ text "else" <+> stmt alt + SwitchStmt _ e cases -> + text "switch" <+> inParens e $$ + braces (nest 2 (vcat (map caseClause cases))) + WhileStmt _ test body -> text "while" <+> inParens test $$ stmt body + ReturnStmt _ Nothing -> text "return" + ReturnStmt _ (Just e) -> text "return" <+> expr e + DoWhileStmt _ s e -> + text "do" $$ (stmt s <+> text "while" <+> inParens e <> semi) + BreakStmt _ Nothing -> text "break" <> semi + BreakStmt _ (Just label) -> text "break" <+> pp label <> semi + ContinueStmt _ Nothing -> text "continue" <> semi + ContinueStmt _ (Just label) -> text"continue" <+> pp label <> semi + LabelledStmt _ label s -> pp label <> colon $$ stmt s + ForInStmt p init e body -> + text "for" <+> + parens (forInInit init <+> text "in" <+> expr e) $+$ stmt body + ForStmt _ init incr test body -> + text "for" <+> + parens (forInit init <> semi <+> mexpr incr <> semi <+> mexpr test) $$ + stmt body + TryStmt _ stmt mcatch mfinally -> + text "try" $$ inBlock stmt $$ ppCatch $$ ppFinally + where ppFinally = case mfinally of + Nothing -> empty + Just stmt -> text "finally" <> inBlock stmt + ppCatch = case mcatch of + Nothing -> empty + Just (CatchClause _ id s) -> + text "catch" <+> (parens.pp) id <+> inBlock s + ThrowStmt _ e -> text "throw" <+> expr e <> semi + WithStmt _ expr s -> text "with" <+> inParens expr $$ stmt s + VarDeclStmt _ decls -> + text "var" <+> cat (punctuate comma (map varDecl decls)) <> semi + FunctionStmt _ name args s -> + text "function" <+> pp name <> + parens (cat $ punctuate comma (map pp args)) $$ + inBlock s + +stmtList :: [Statement a] -> Doc +stmtList = vcat . map stmt + +prop :: Prop a -> Doc +prop p = case p of + PropId _ id -> pp id + PropString _ str -> doubleQuotes (text (jsEscape str)) + PropNum _ n -> text (show n) + +infixOp op = text $ case op of + OpMul -> "*" + OpDiv -> "/" + OpMod -> "%" + OpAdd -> "+" + OpSub -> "-" + OpLShift -> "<<" + OpSpRShift -> ">>" + OpZfRShift -> ">>>" + OpLT -> "<" + OpLEq -> "<=" + OpGT -> ">" + OpGEq -> ">=" + OpIn -> "in" + OpInstanceof -> "instanceof" + OpEq -> "==" + OpNEq -> "!=" + OpStrictEq -> "===" + OpStrictNEq -> "!==" + OpBAnd -> "&" + OpBXor -> "^" + OpBOr -> "|" + OpLAnd -> "&&" + OpLOr -> "||" + + +prefixOp op = text $ case op of + PrefixLNot -> "!" + PrefixBNot -> "~" + PrefixPlus -> "+" + PrefixMinus -> "-" + PrefixTypeof -> "typeof" + PrefixVoid -> "void" + PrefixDelete -> "delete" + + +assignOp op = text $ case op of + OpAssign -> "=" + OpAssignAdd -> "+=" + OpAssignSub -> "-=" + OpAssignMul -> "*=" + OpAssignDiv -> "/=" + OpAssignMod -> "%=" + OpAssignLShift -> "<<=" + OpAssignSpRShift -> ">>=" + OpAssignZfRShift -> ">>>=" + OpAssignBAnd -> "&=" + OpAssignBXor -> "^=" + OpAssignBOr -> "|=" + +-- Based on: +-- http://developer.mozilla.org/en/docs/Core_JavaScript_1.5_Guide:Literals +jsEscape:: String -> String +jsEscape "" = "" +jsEscape (ch:chs) = sel ch ++ jsEscape chs where + sel '\b' = "\\b" + sel '\f' = "\\f" + sel '\n' = "\\n" + sel '\r' = "\\r" + sel '\t' = "\\t" + sel '\v' = "\\v" + sel '\'' = "\\'" + sel '\"' = "\\\"" + sel '\\' = "\\\\" + sel x = [x] + -- We don't have to do anything about \X, \x and \u escape sequences. + +lvalue :: LValue a -> Doc +lvalue (LVar _ x) = text x +lvalue (LDot _ e x) = expr e <> text "." <> text x +lvalue (LBracket _ e1 e2) = expr e1 <> brackets (expr e2) + +expr :: Expression a -> Doc +expr e = case e of + StringLit _ str -> doubleQuotes (text (jsEscape str)) + RegexpLit _ re global ci -> + text "/" <> text re <> text "/" <> g <> i where + g = if global then text "g" else empty + i = if ci then text "i" else empty + NumLit _ n -> text (show n) + IntLit _ n -> text (show n) + BoolLit _ True -> text "true" + BoolLit _ False -> text "false" + NullLit _ -> text "null" + ArrayLit _ es -> brackets $ cat $ punctuate comma (map expr es) + ObjectLit _ xs -> + braces (hsep (punctuate comma (map pp' xs))) where + pp' (n,v) = prop n <> colon <+> expr v + ThisRef _ -> text "this" + VarRef _ id -> pp id + DotRef _ e' id -> expr e' <> text "." <> pp id + BracketRef _ container key -> expr container <> brackets (expr key) + NewExpr _ constr args -> + text "new" <+> expr constr <> + parens (cat $ punctuate comma (map expr args)) + PrefixExpr _ op e' -> prefixOp op <+> expr e' + InfixExpr _ op left right -> expr left <+> infixOp op <+> expr right + CondExpr _ test cons alt -> + expr test <+> text "?" <+> expr cons <+> colon <+> expr alt + AssignExpr _ op l r -> lvalue l <+> assignOp op <+> expr r + UnaryAssignExpr _ op e' -> case op of + PrefixInc -> text "++" <> lvalue e' + PrefixDec -> text "--" <> lvalue e' + PostfixInc -> lvalue e' <> text "++" + PostfixDec -> lvalue e' <> text "--" + ParenExpr _ e' -> parens (expr e') + ListExpr _ es -> cat $ punctuate comma (map expr es) + CallExpr _ f args -> + expr f <> parens (cat $ punctuate comma (map expr args)) + FuncExpr _ name args body -> + text "function" <+> text (maybe "" unId name) <+> + parens (cat $ punctuate comma (map pp args)) $$ + inBlock body + +mexpr :: Maybe (Expression a) -> Doc +mexpr Nothing = empty +mexpr (Just e) = expr e + +-- | Renders a JavaScript program as a document, the show instance of +-- 'Doc' will pretty-print it automatically +javaScript :: JavaScript a -> Doc +javaScript (Script _ ss) = stmtList ss diff --git a/src/Language/ECMAScript3/Syntax.hs b/src/Language/ECMAScript3/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Language/ECMAScript3/Syntax.hs @@ -0,0 +1,236 @@ +-- |ECMAScript 3 syntax. /Spec/ refers to the ECMA-262 specification, 3rd edition. +module Language.ECMAScript3.Syntax (JavaScript(..) + ,unJavaScript + ,Statement(..) + ,isIterationStmt + ,CaseClause(..) + ,CatchClause(..) + ,ForInit(..) + ,ForInInit(..) + ,VarDecl(..) + ,Expression(..) + ,InfixOp(..) + ,AssignOp(..) + ,Id(..) + ,unId + ,PrefixOp(..) + ,Prop(..) + ,UnaryAssignOp(..) + ,LValue (..) + ,SourcePos + ) where + +import Text.Parsec.Pos(initialPos,SourcePos) -- used by data JavaScript +import Data.Generics(Data,Typeable) +import Data.Foldable (Foldable) +import Data.Traversable (Traversable) +import Data.Default + +data JavaScript a + -- |A script in \ ... \ tags. + = Script a [Statement a] + deriving (Show,Data,Typeable,Eq,Ord,Functor,Foldable,Traversable) + +instance Default a => Default (JavaScript a) where + def = Script def [] + +-- | extracts statements from a JavaScript type +unJavaScript :: JavaScript a -> [Statement a] +unJavaScript (Script _ stmts) = stmts + +instance Default SourcePos where + def = initialPos "" + +data Id a = Id a String + deriving (Show,Eq,Ord,Data,Typeable,Functor,Foldable,Traversable) + +unId :: Id a -> String +unId (Id _ s) = s + +-- | Infix operators: see spec 11.5-11.11 +data InfixOp = OpLT -- ^ @<@ + | OpLEq -- ^ @<=@ + | OpGT -- ^ @>@ + | OpGEq -- ^ @>=@ + | OpIn -- ^ @in@ + | OpInstanceof -- ^ @instanceof@ + | OpEq -- ^ @==@ + | OpNEq -- ^ @!=@ + | OpStrictEq -- ^ @===@ + | OpStrictNEq -- ^ @!===@ + | OpLAnd -- ^ @&&@ + | OpLOr -- ^ @||@ + | OpMul -- ^ @*@ + | OpDiv -- ^ @/@ + | OpMod -- ^ @%@ + | OpSub -- ^ @-@ + | OpLShift -- ^ @<<@ + | OpSpRShift -- ^ @>>@ + | OpZfRShift -- ^ @>>>@ + | OpBAnd -- ^ @&@ + | OpBXor -- ^ @^@ + | OpBOr -- ^ @|@ + | OpAdd -- ^ @+@ + deriving (Show,Data,Typeable,Eq,Ord,Enum) + +-- | Assignment operators: see spec 11.13 +data AssignOp = OpAssign -- ^ simple assignment, @=@ + | OpAssignAdd -- ^ @+=@ + | OpAssignSub -- ^ @-=@ + | OpAssignMul -- ^ @*=@ + | OpAssignDiv -- ^ @/=@ + | OpAssignMod -- ^ @%=@ + | OpAssignLShift -- ^ @<<=@ + | OpAssignSpRShift -- ^ @>>=@ + | OpAssignZfRShift -- ^ @>>>=@ + | OpAssignBAnd -- ^ @&=@ + | OpAssignBXor -- ^ @^=@ + | OpAssignBOr -- ^ @|=@ + deriving (Show,Data,Typeable,Eq,Ord) + +-- | Unary assignment operators: see spec 11.3, 11.4.4, 11.4.5 +data UnaryAssignOp = PrefixInc -- ^ @++x@ + | PrefixDec -- ^ @--x@ + | PostfixInc -- ^ @x++@ + | PostfixDec -- ^ @x--@ + deriving (Show, Data, Typeable, Eq, Ord) + +-- | Prefix operators: see spec 11.4 (excluding 11.4.4, 11.4.5) +data PrefixOp = PrefixLNot -- ^ @!@ + | PrefixBNot -- ^ @~@ + | PrefixPlus -- ^ @+@ + | PrefixMinus -- ^ @-@ + | PrefixTypeof -- ^ @typeof@ + | PrefixVoid -- ^ @void@ + | PrefixDelete -- ^ @delete@ + deriving (Show,Data,Typeable,Eq,Ord) + +-- | Property names in an object initializer: see spec 11.1.5 +data Prop a = PropId a (Id a) -- ^ property name is an identifier, @foo@ + | PropString a String -- ^ property name is a string, @\"foo\"@ + | PropNum a Integer -- ^ property name is an integer, @42@ + deriving (Show,Data,Typeable,Eq,Ord,Functor,Foldable,Traversable) + +-- | Left-hand side expressions: see spec 11.2 +data LValue a + = LVar a String -- ^ variable reference, @foo@ + | LDot a (Expression a) String -- ^ @foo.bar@ + | LBracket a (Expression a) (Expression a) -- ^ @foo[bar]@ + deriving (Show, Eq, Ord, Data, Typeable, Functor,Foldable,Traversable) + +-- | Expressions, see spec 11 +data Expression a + = StringLit a String -- ^ @\"foo\"@, spec 11.1.3, 7.8 + | RegexpLit a String Bool Bool + -- ^ @RegexpLit a regexp global? case_insensitive?@ -- regular + -- expression, see spec 11.1.3, 7.8 + | NumLit a Double -- ^ @41.99999@, spec 11.1.3, 7.8 + | IntLit a Int -- ^ @42@, spec 11.1.3, 7.8 + | BoolLit a Bool -- ^ @true@, spec 11.1.3, 7.8 + | NullLit a -- ^ @null@, spec 11.1.3, 7.8 + | ArrayLit a [Expression a] -- ^ @[1,2,3]@, spec 11.1.4 + | ObjectLit a [(Prop a, Expression a)] -- ^ @{foo:\"bar\", baz: 42}@, spec 11.1.5 + | ThisRef a -- ^ @this@, spec 11.1.1 + | VarRef a (Id a) -- ^ @foo@, spec 11.1.2 + | DotRef a (Expression a) (Id a) -- ^ @foo.bar@, spec 11.2.1 + | BracketRef a (Expression a) {- container -} (Expression a) {- key -} + -- ^ @foo[bar@, spec 11.2.1 + | NewExpr a (Expression a) {- constructor -} [Expression a] + -- ^ @new foo(bar)@, spec 11.2.2 + | PrefixExpr a PrefixOp (Expression a) + -- ^ @\@e@, spec 11.4 (excluding 11.4.4, 111.4.5) + | UnaryAssignExpr a UnaryAssignOp (LValue a) + -- ^ @++x@, @x--@ etc., spec 11.3, 11.4.4, 11.4.5 + | InfixExpr a InfixOp (Expression a) (Expression a) + -- ^ @e1\@e2@, spec 11.5, 11.6, 11.7, 11.8, 11.9, 11.10, 11.11 + | CondExpr a (Expression a) (Expression a) (Expression a) + -- ^ @e1 ? e2 : e3@, spec 11.12 + | AssignExpr a AssignOp (LValue a) (Expression a) + -- ^ @e1 \@=e2@, spec 11.13 + | ParenExpr a (Expression a) -- ^ @(e)@, spec 11.1.6 + | ListExpr a [Expression a] -- ^ @e1, e2@, spec 11.14 + | CallExpr a (Expression a) [Expression a] -- ^ @f(x,y,z)@, spec 11.2.3 + --funcexprs are optionally named + | FuncExpr a (Maybe (Id a)) [Id a] (Statement a) + -- ^ @function f (x,y,z) {...}@, spec 11.2.5, 13 + deriving (Show,Data,Typeable,Eq,Ord,Functor,Foldable,Traversable) + +-- | Case clauses, spec 12.11 +data CaseClause a = CaseClause a (Expression a) [Statement a] + -- ^ @case e: stmts;@ + | CaseDefault a [Statement a] + -- ^ @default: stmts;@ + deriving (Show,Data,Typeable,Eq,Ord,Functor,Foldable,Traversable) + +-- | Catch clause, spec 12.14 +data CatchClause a = CatchClause a (Id a) (Statement a) + -- ^ @catch (x) {...}@ + deriving (Show,Data,Typeable,Eq,Ord,Functor,Foldable,Traversable) + +-- | A variable declaration, spec 12.2 +data VarDecl a = VarDecl a (Id a) (Maybe (Expression a)) + -- ^ @var x = e;@ + deriving (Show,Data,Typeable,Eq,Ord,Functor,Foldable,Traversable) + +-- | for initializer, spec 12.6 +data ForInit a = NoInit -- ^ empty + | VarInit [VarDecl a] -- ^ @var x, y=42@ + | ExprInit (Expression a) -- ^ @expr@ + deriving (Show,Data,Typeable,Eq,Ord,Functor,Foldable,Traversable) + +-- | for..in initializer, spec 12.6 +data ForInInit a = ForInVar (Id a) -- ^ @var x@ + | ForInLVal (LValue a) -- ^ @foo.baz@, @foo[bar]@, @z@ + deriving (Show,Data,Typeable,Eq,Ord,Functor,Foldable,Traversable) + +-- | Statements, spec 12. +data Statement a + = BlockStmt a [Statement a] -- ^ @{stmts}@, spec 12.1 + | EmptyStmt a -- ^ @;@, spec 12.3 + | ExprStmt a (Expression a) -- ^ @expr;@, spec 12.4 + | IfStmt a (Expression a) (Statement a) (Statement a) + -- ^ @if (e) stmt@, spec 12.5 + | IfSingleStmt a (Expression a) (Statement a) + -- ^ @if (e) stmt1 else stmt2@, spec 12.5 + | SwitchStmt a (Expression a) [CaseClause a] + -- ^ @switch (e) clauses@, spec 12.11 + | WhileStmt a (Expression a) (Statement a) + -- ^ @while (e) do stmt@, spec 12.6 + | DoWhileStmt a (Statement a) (Expression a) + -- ^ @do stmt while (e);@, spec 12.6 + | BreakStmt a (Maybe (Id a)) -- ^ @break lab;@, spec 12.8 + | ContinueStmt a (Maybe (Id a)) -- ^ @continue lab;@, spec 12.7 + | LabelledStmt a (Id a) (Statement a) -- ^ @lab: stmt@, spec 12.12 + | ForInStmt a (ForInInit a) (Expression a) (Statement a) + -- ^ @for (x in o) stmt@, spec 12.6 + | ForStmt a (ForInit a) + (Maybe (Expression a)) -- test + (Maybe (Expression a)) -- increment + (Statement a) -- body + -- ^ @ForStmt a init test increment body@, @for (init; test, + -- increment) body@, spec 12.6 + | TryStmt a (Statement a) {-body-} (Maybe (CatchClause a)) + (Maybe (Statement a)) {-finally-} + -- ^ @try stmt catch(x) stmt finally stmt@, spec 12.14 + | ThrowStmt a (Expression a) + -- ^ @throw expr;@, spec 12.13 + | ReturnStmt a (Maybe (Expression a)) + -- ^ @return expr;@, spec 12.9 + | WithStmt a (Expression a) (Statement a) + -- ^ @with (o) stmt@, spec 12.10 + | VarDeclStmt a [VarDecl a] + -- ^ @var x, y=42;@, spec 12.2 + | FunctionStmt a (Id a) {-name-} [Id a] {-args-} (Statement a) {-body-} + -- ^ @function f(x, y, z) {...}@, spec 13 + deriving (Show,Data,Typeable,Eq,Ord,Functor,Foldable,Traversable) + +-- | Returns 'True' if the statement is an /IterationStatement/ +-- according to spec 12.6. +isIterationStmt :: Statement a -> Bool +isIterationStmt s = case s of + WhileStmt {} -> True + DoWhileStmt {} -> True + ForStmt {} -> True + ForInStmt {} -> True + _ -> False + diff --git a/src/Language/ECMAScript3/Syntax/Annotations.hs b/src/Language/ECMAScript3/Syntax/Annotations.hs new file mode 100644 --- /dev/null +++ b/src/Language/ECMAScript3/Syntax/Annotations.hs @@ -0,0 +1,115 @@ +-- | A few helpers to work with the AST annotations +module Language.ECMAScript3.Syntax.Annotations where + +import Language.ECMAScript3.Syntax +import Data.Traversable +import Control.Applicative +import Control.Arrow +import Control.Monad.State hiding (mapM) +import Prelude hiding (mapM) + +-- | Removes annotations from a tree +removeAnnotations :: Traversable t => t a -> t () +removeAnnotations = reannotate (const ()) + +-- | Changes all the labels in the tree to another one, given by a +-- function. +reannotate :: Traversable t => (a -> b) -> t a -> t b +reannotate f tree = traverse (pure . f) tree () + +-- | add an extra field to the AST labels (the label would look like @ +-- (a, b) @) +addExtraAnnotationField :: Traversable t => b -> t a -> t (a, b) +addExtraAnnotationField def t = traverse (\z -> pure (z, def)) t () + +-- | remove an extra field +removeExtraAnnotationField :: Traversable t => t (a, b) -> t a +removeExtraAnnotationField t = traverse (pure . fst) t () + + +-- | Assigns unique numeric (Int) ids to each node in the AST. Returns +-- a pair: the tree annotated with UID's and the last ID that was +-- assigned. +assignUniqueIds :: Traversable t => Int -- ^ starting id + -> t a -- ^ tree root + -> (t (a, Int), Int) +assignUniqueIds first tree = + (returnA *** \i -> i-1) $ runState (mapM f tree) first + where f :: a -> State Int (a, Int) + f a = do i <- get + put (i+1) + return (a, i) + +class HasAnnotation a where + -- | Returns the annotation of the root of the tree + getAnnotation :: a b -> b + +instance HasAnnotation Expression where + getAnnotation e = case e of + (StringLit a s) -> a + (RegexpLit a s g ci) -> a + (NumLit a d) -> a + (IntLit a i) -> a + (BoolLit a b) -> a + (NullLit a) -> a + (ArrayLit a exps) -> a + (ObjectLit a props) -> a + (ThisRef a) -> a + (VarRef a id) -> a + (DotRef a exp id) -> a + (BracketRef a container key) -> a + (NewExpr a ctor params) -> a + (PrefixExpr a op e) -> a + (UnaryAssignExpr a op lv) -> a + (InfixExpr a op e1 e2) -> a + (CondExpr a g et ef) -> a + (AssignExpr a op lv e) -> a + (ParenExpr a e) -> a + (ListExpr a es) -> a + (CallExpr a fn params) -> a + (FuncExpr a mid args s) -> a + +instance HasAnnotation Statement where + getAnnotation s = case s of + BlockStmt a _ -> a + EmptyStmt a -> a + ExprStmt a _ -> a + IfStmt a _ _ _ -> a + IfSingleStmt a _ _ -> a + SwitchStmt a _ _ -> a + WhileStmt a _ _ -> a + DoWhileStmt a _ _ -> a + BreakStmt a _ -> a + ContinueStmt a _ -> a + LabelledStmt a _ _ -> a + ForInStmt a _ _ _ -> a + ForStmt a _ _ _ _ -> a + TryStmt a _ _ _ -> a + ThrowStmt a _ -> a + ReturnStmt a _ -> a + WithStmt a _ _ -> a + VarDeclStmt a _ -> a + FunctionStmt a _ _ _ -> a + +instance HasAnnotation LValue where + getAnnotation lv = case lv of + LVar a _ -> a + LDot a _ _ -> a + LBracket a _ _ -> a + +instance HasAnnotation VarDecl where + getAnnotation (VarDecl a _ _) = a + +instance HasAnnotation Prop where + getAnnotation p = case p of + PropId a _ -> a + PropString a _ -> a + PropNum a _ -> a + +instance HasAnnotation CaseClause where + getAnnotation c = case c of + CaseClause a _ _ -> a + CaseDefault a _ -> a + +instance HasAnnotation CatchClause where + getAnnotation (CatchClause a _ _) = a diff --git a/src/UnitTest.hs b/src/UnitTest.hs new file mode 100644 --- /dev/null +++ b/src/UnitTest.hs @@ -0,0 +1,31 @@ +module Main where + +import Test.HUnit +import System.Exit +import System.Directory +import qualified System.FilePath as FilePath +import Language.ECMAScript3.Parser +import Language.ECMAScript3.PrettyPrint +import Language.ECMAScript3.Syntax + +testDir = "tests/parse-pretty" + +parsePrettyTest filename = TestLabel filename $ TestCase $ do + js <- parseJavaScriptFromFile filename + let str = renderStatements js + case parseScriptFromString "" str of + Left err -> assertFailure (show err) + Right (Script _ js') -> do + let str' = renderStatements js' + assertBool "pretty-printed code should re-parse" (str == str') + +main = do + allFiles <- getDirectoryContents testDir + let files = map (testDir `FilePath.combine`) $ + filter (\x -> FilePath.takeExtension x == ".js") allFiles + let parsePretty = TestLabel "parser - printer composition" + (TestList (map parsePrettyTest files)) + results <- runTestTT parsePretty + if errors results > 0 || failures results > 0 + then exitFailure + else putStrLn "All tests passed."