diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,31 @@ Version change log. +=0.19.0.1= +Version bumps and a build fix for GHC 8.8 (GitHub issue #85). + +=0.19= +Pull request #84: Moved the Arbitrary instance and the testing-feat dependency to the test-suite. Removed tabs from the lexer. + +=0.18= +Pull request #83: Updated dependencies, migrated to ansi-wl-pprint. + +=0.17.2.0= +Issue #82: Tighter lexing of identifiers using Unicode character classes (thanks @berdario). + +Dependency version bumps. + +=0.17.1.0= +Improvements to pretty-printing (Github PR #78) + fixed a bug in quasi-quotation (Github PR #77). + +=0.17.0.2= +Fixed a bug in the Arbitrary instance: no longer generating empty list expressions. Dependency bounds update. + +=0.17.0.1= +Dependency bounds update. + +=0.17= +Added helper functions for code generation (see Language.ECMAScript3.Syntax.CodeGen). Bug fixes to the Arbitrary instances. + =0.16.2= Build fixes for GHC 7.4.2 and 7.8.2. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,5 +1,4 @@ -Copyright (c) 2007--2012, Brown University, 2008-2012 Claudiu Saftoiu, -2012-2014 Stevens Institute of Technology. +Copyright (c) 2007--2012 Brown University, (c) 2008-2012 Claudiu Saftoiu, (c) 2012-2015 Stevens Institute of Technology, (c) 2016 Andrey Chudnov, (c) 2016 Eyal Lotem. All Rights Reserved. Redistribution and use in source and binary forms, with or without diff --git a/language-ecmascript.cabal b/language-ecmascript.cabal --- a/language-ecmascript.cabal +++ b/language-ecmascript.cabal @@ -1,8 +1,8 @@ Name: language-ecmascript -Version: 0.16.2 -Cabal-Version: >= 1.10 +Version: 0.19.1.0 +Cabal-Version: >= 1.12 Copyright: (c) 2007-2012 Brown University, (c) 2008-2010 Claudiu Saftoiu, - (c) 2012-2014 Stevens Institute of Technology + (c) 2012-2015 Stevens Institute of Technology, (c) 2016 Eyal Lotem, (c) 2016-2020 Andrey Chudnov License: BSD3 License-file: LICENSE Author: Andrey Chudnov, Arjun Guha, Spiridon Aristides Eliopoulos, @@ -11,16 +11,16 @@ Homepage: http://github.com/jswebtools/language-ecmascript Bug-reports: http://github.com/jswebtools/language-ecmascript/issues Stability: experimental -Tested-with: GHC==7.6.3, GHC==7.4.2, GHC==7.8.2 +Tested-with: GHC==8.8.1 Extra-Source-Files: test/parse-pretty/*.js, test/diff/left/*.js, test/diff/right/*.js, test/diff/expects/*.diff, CHANGELOG Category: Language Build-Type: Simple Synopsis: JavaScript parser and pretty-printer library Description: - Tools for working with ECMAScript 3 (popularly known as JavaScript). + Tools for working with ECMAScript 3 (popularly known as JavaScript). Includes a parser, pretty-printer, tools for working with source tree annotations and an arbitrary instance. See CHANGELOG for a summary of - changes. + changes. The package follows the Haskell Package Versioning Policy since version 0.17.0.1. Source-repository head type: git @@ -29,33 +29,33 @@ Source-repository this type: git location: git://github.com/jswebtools/language-ecmascript.git - tag: 0.16.2 + tag: 0.19.0.1 Library Hs-Source-Dirs: src Build-Depends: - base >= 4 && < 5, + base >= 4 && < 4.15, mtl >= 1 && < 3, parsec > 3 && < 3.2.0, - wl-pprint == 1.*, + ansi-wl-pprint >= 0.6 && < 1, containers == 0.*, uniplate >= 1.6 && <1.7, - data-default-class >= 0.0.1 && < 0.1, + data-default-class >= 0.0.1 && < 0.2, QuickCheck >= 2.5 && < 3, template-haskell >= 2.7 && < 3, - Diff == 0.3.*, - testing-feat >= 0.4.0.2 && < 0.5 + Diff == 0.4.*, + charset >= 0.3 ghc-options: -fwarn-incomplete-patterns Exposed-Modules: - Language.ECMAScript3 - Language.ECMAScript3.Lexer + Language.ECMAScript3 + Language.ECMAScript3.Lexer Language.ECMAScript3.Parser Language.ECMAScript3.PrettyPrint Language.ECMAScript3.Syntax Language.ECMAScript3.Syntax.Annotations - Language.ECMAScript3.Syntax.Arbitrary + Language.ECMAScript3.Syntax.CodeGen Language.ECMAScript3.Syntax.QuasiQuote Language.ECMAScript3.Analysis.Environment Language.ECMAScript3.Analysis.LabelSets @@ -68,30 +68,41 @@ Default-Language: Haskell2010 Test-Suite test - Hs-Source-Dirs: test + Hs-Source-Dirs: src test Type: exitcode-stdio-1.0 Main-Is: TestMain.hs Other-Modules: + Language.ECMAScript3.Lexer + Language.ECMAScript3.Parser + Language.ECMAScript3.Parser.State + Language.ECMAScript3.Parser.Type + Language.ECMAScript3.PrettyPrint + Language.ECMAScript3.SourceDiff + Language.ECMAScript3.Syntax + Language.ECMAScript3.Syntax.Annotations + Language.ECMAScript3.Syntax.Arbitrary Test.Diff Test.Unit Test.Pretty Test.Arbitrary Build-Depends: - base >= 4 && < 5, + base >= 4 && < 4.14, mtl >= 1 && < 3, parsec >= 3 && < 3.2.0, - wl-pprint == 1.*, + ansi-wl-pprint >= 0.6 && < 1, + charset >= 0.3, containers == 0.*, - directory >= 1.2 && < 1.3, - filepath >= 1.3 && < 1.4, - HUnit >= 1.2 && < 1.3, + directory >= 1.2 && < 1.4, + filepath >= 1.3 && < 1.5, + HUnit >= 1.2 && < 1.7, QuickCheck >= 2.5 && < 3, - data-default-class >= 0.0.1 && < 0.1, + data-default-class >= 0.0.1 && < 0.2, + testing-feat >= 0.4.0.2 && < 1.2, test-framework >= 0.8 && < 0.9, test-framework-hunit >= 0.3.0 && < 0.4, test-framework-quickcheck2 >= 0.3.0.1 && < 0.4, uniplate >= 1.6 && <1.7, - Diff == 0.3.*, + Diff == 0.4.*, language-ecmascript Default-Extensions: DeriveDataTypeable, ScopedTypeVariables, DeriveFunctor, DeriveFoldable, DeriveTraversable, FlexibleContexts Default-Language: Haskell2010 diff --git a/src/Language/ECMAScript3/Lexer.hs b/src/Language/ECMAScript3/Lexer.hs --- a/src/Language/ECMAScript3/Lexer.hs +++ b/src/Language/ECMAScript3/Lexer.hs @@ -13,6 +13,10 @@ ,hexIntLit,decIntLit, decDigits, decDigitsOpt, exponentPart, decLit) where import Prelude hiding (lex) +import Data.Char +import Data.Monoid ((<>), mconcat) +import qualified Data.CharSet as Set +import qualified Data.CharSet.Unicode.Category as Set import Text.Parsec import qualified Text.Parsec.Token as T import Language.ECMAScript3.Parser.State @@ -21,9 +25,34 @@ import Control.Applicative ((<$>), (<*>)) import Data.Maybe (isNothing) +identifierStartCharSet :: Set.CharSet +identifierStartCharSet = + mconcat + [ Set.fromDistinctAscList "$_" + , Set.lowercaseLetter + , Set.uppercaseLetter + , Set.titlecaseLetter + , Set.modifierLetter + , Set.otherLetter + , Set.letterNumber + ] + +identifierRestCharSet :: Set.CharSet +identifierRestCharSet = + identifierStartCharSet + <> mconcat + [ Set.nonSpacingMark + , Set.spacingCombiningMark + , Set.decimalNumber + , Set.connectorPunctuation + ] + identifierStart :: Stream s Identity Char => Parser s Char -identifierStart = letter <|> oneOf "$_" +identifierStart = satisfy (flip Set.member identifierStartCharSet) "letter, '$', '_'" +identifierRest :: Stream s Identity Char => Parser s Char +identifierRest = satisfy (flip Set.member identifierRestCharSet) "letter, digits, '$', '_' ..." + javascriptDef :: Stream s Identity Char =>T.GenLanguageDef s ParserState Identity javascriptDef = T.LanguageDef "/*" @@ -31,7 +60,7 @@ "//" False -- no nested comments identifierStart - (alphaNum <|> oneOf "$_") -- identifier rest + identifierRest (oneOf "{}<>()~.,?:|&^=!+-*/%!") -- operator start (oneOf "=<>|&+") -- operator rest ["break", "case", "catch", "const", "continue", "debugger", @@ -51,45 +80,45 @@ -- everything but commaSep and semiSep identifier :: Stream s Identity Char => Parser s String -identifier = T.identifier lex +identifier = T.identifier lex reserved :: Stream s Identity Char => String -> Parser s () -reserved = T.reserved lex +reserved = T.reserved lex operator :: Stream s Identity Char => Parser s String -operator = T.operator lex +operator = T.operator lex reservedOp :: Stream s Identity Char => String -> Parser s () -reservedOp = T.reservedOp lex +reservedOp = T.reservedOp lex charLiteral :: Stream s Identity Char => Parser s Char -charLiteral = T.charLiteral lex +charLiteral = T.charLiteral lex stringLiteral :: Stream s Identity Char => Parser s String stringLiteral = T.stringLiteral lex -- natural :: Stream s Identity Char => Parser s Integer --- natural = T.natural lex +-- natural = T.natural lex -- integer :: Stream s Identity Char => Parser s Integer --- integer = T.integer lex +-- integer = T.integer lex -- float :: Stream s Identity Char => Parser s Double -- float = T.float lex -- naturalOrFloat :: Stream s Identity Char => Parser s (Either Integer Double) -- naturalOrFloat = T.naturalOrFloat lex -- decimal :: Stream s Identity Char => Parser s Integer --- decimal = T.decimal lex +-- decimal = T.decimal lex -- hexadecimal :: Stream s Identity Char => Parser s Integer --- hexadecimal = T.hexadecimal lex +-- hexadecimal = T.hexadecimal lex -- octal :: Stream s Identity Char => Parser s Integer -- octal = T.octal lex symbol :: Stream s Identity Char => String -> Parser s String symbol = T.symbol lex whiteSpace :: Stream s Identity Char => Parser s () -whiteSpace = T.whiteSpace lex +whiteSpace = T.whiteSpace lex parens :: Stream s Identity Char => Parser s a -> Parser s a -parens = T.parens lex +parens = T.parens lex braces :: Stream s Identity Char => Parser s a -> Parser s a -braces = T.braces lex +braces = T.braces lex squares :: Stream s Identity Char => Parser s a -> Parser s a -squares = T.squares lex +squares = T.squares lex semi :: Stream s Identity Char => Parser s String -semi = T.semi lex +semi = T.semi lex comma :: Stream s Identity Char => Parser s String -comma = T.comma lex +comma = T.comma lex colon :: Stream s Identity Char => Parser s String colon = T.colon lex dot :: Stream s Identity Char => Parser s String diff --git a/src/Language/ECMAScript3/Parser.hs b/src/Language/ECMAScript3/Parser.hs --- a/src/Language/ECMAScript3/Parser.hs +++ b/src/Language/ECMAScript3/Parser.hs @@ -42,6 +42,7 @@ import Data.Maybe (isJust, isNothing, fromMaybe) import Control.Monad.Error.Class import Control.Applicative ((<$>), (<*>)) +import Control.Exception (throwIO) {-# DEPRECATED ParsedStatement, ParsedExpression, StatementParser, ExpressionParser @@ -794,7 +795,7 @@ parseJavaScriptFromFile filename = do chars <- liftIO $ readFile filename case parse parseScript filename chars of - Left err -> fail (show err) + Left err -> liftIO $ throwIO $ userError $ show err Right (Script _ stmts) -> return stmts -- | Parse a JavaScript program from a string diff --git a/src/Language/ECMAScript3/PrettyPrint.hs b/src/Language/ECMAScript3/PrettyPrint.hs --- a/src/Language/ECMAScript3/PrettyPrint.hs +++ b/src/Language/ECMAScript3/PrettyPrint.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE CPP #-} -- | Pretty-printing JavaScript. module Language.ECMAScript3.PrettyPrint (Pretty (..) @@ -9,14 +10,19 @@ ,unsafeInExprStmt ) where -import Text.PrettyPrint.Leijen hiding (Pretty) +import qualified Text.PrettyPrint.ANSI.Leijen as Pretty +import Text.PrettyPrint.ANSI.Leijen hiding (Pretty, parens) import Language.ECMAScript3.Syntax import Prelude hiding (maybe, id) +import qualified Prelude import Data.Char import Numeric {-# DEPRECATED PP, javaScript, renderStatements, renderExpression "These interfaces are outdated and would be removed/hidden in version 1.0. Use the Pretty class instead." #-} +parens :: Doc -> Doc +parens = Pretty.parens . align + -- | A class of pretty-printable ECMAScript AST nodes. Will -- pretty-print correct JavaScript given that the 'isValid' predicate -- holds for the AST. @@ -28,34 +34,45 @@ instance Pretty (JavaScript a) where prettyPrint (Script _ ss) = prettyPrint ss -instance Pretty [Statement a] where +instance Pretty [Statement a] where prettyPrint = vcat . map prettyPrint -instance Pretty (Expression a) where +instance Pretty (Expression a) where prettyPrint = ppExpression True -instance Pretty (Statement a) where +-- | Print a list of items in parenthesis +parenList :: (a -> Doc) -> [a] -> Doc +parenList ppElem = encloseSep (text "(") (text ")") comma . map ppElem + +isIf :: Statement a -> Bool +isIf IfSingleStmt {} = True +isIf IfStmt {} = True +isIf _ = False + +instance Pretty (Statement a) where prettyPrint s = case s of BlockStmt _ ss -> asBlock ss EmptyStmt _ -> semi - ExprStmt _ e | unsafeInExprStmt (e) -> parens (ppExpression True e) <> semi - ExprStmt _ e | otherwise -> ppExpression True e <> semi - IfSingleStmt _ test cons -> text "if" <+> - parens (ppExpression True test) - (nest 3 $ prettyPrint cons) + ExprStmt _ e | unsafeInExprStmt (e) -> parens (nest 4 (ppExpression True e)) <> semi + ExprStmt _ e | otherwise -> nest 4 (ppExpression True e) <> semi + IfSingleStmt _ test cons -> text "if" <+> + parens (ppExpression True test) + indented 3 cons IfStmt _ test cons alt -> text "if" <+> parens (ppExpression True test) - (nest 3 $ prettyPrint cons) text "else" - <+> (nest 3 $ prettyPrint alt) + indented 3 cons text "else" + <+> if isIf alt + then prettyPrint alt + else indented 3 alt SwitchStmt _ e cases -> - text "switch" <+> parens (ppExpression True e) <$> - braces (nest 3 (vcat (map prettyPrint cases))) + text "switch" <+> parens (ppExpression True e) <> line <> + ppBlock 2 (vcat (map prettyPrint cases)) WhileStmt _ test body -> text "while" <+> parens (ppExpression True test) - prettyPrint body + indented 3 body ReturnStmt _ Nothing -> text "return" <> semi - ReturnStmt _ (Just e) -> text "return" <+> ppExpression True e <> semi - DoWhileStmt _ s e -> - text "do" - (prettyPrint s text "while" <+> parens (ppExpression True e) + ReturnStmt _ (Just e) -> text "return" <+> nest 4 (ppExpression True e) <> semi + DoWhileStmt _ s e -> + text "do" + (indented 3 s text "while" <+> parens (ppExpression True e) <> semi) BreakStmt _ Nothing -> text "break" <> semi BreakStmt _ (Just label) -> text "break" <+> prettyPrint label <> semi @@ -63,17 +80,17 @@ ContinueStmt _ (Just label) -> text"continue" <+> prettyPrint label <> semi LabelledStmt _ label s -> prettyPrint label <> colon prettyPrint s - ForInStmt p init e body -> - text "for" <+> - parens (prettyPrint init <+> text "in" <+> ppExpression True e) - prettyPrint body + ForInStmt p init e body -> + text "for" <+> + parens (prettyPrint init <+> text "in" <+> ppExpression True e) + indented 3 body ForStmt _ init incr test body -> - text "for" <+> - parens (prettyPrint init <> semi <+> maybe incr (ppExpression True) <> - semi <+> maybe test (ppExpression True)) - prettyPrint body + text "for" <+> + parens (prettyPrint init <> semi <+> maybe incr (ppExpression True) <> + semi <+> maybe test (ppExpression True)) + indented 3 body TryStmt _ stmt mcatch mfinally -> - text "try" inBlock stmt ppCatch ppFinally + text "try" inBlock stmt ppCatch ppFinally where ppFinally = case mfinally of Nothing -> empty Just stmt -> text "finally" <> inBlock stmt @@ -82,13 +99,13 @@ Just cc -> prettyPrint cc ThrowStmt _ e -> text "throw" <+> ppExpression True e <> semi WithStmt _ e s -> text "with" <+> parens (ppExpression True e) - prettyPrint s + indented 3 s VarDeclStmt _ decls -> text "var" <+> cat (punctuate comma (map (ppVarDecl True) decls)) <> semi FunctionStmt _ name args body -> - text "function" <+> prettyPrint name <> - parens (cat $ punctuate comma (map prettyPrint args)) <+> + text "function" <+> prettyPrint name <> + parenList prettyPrint args <+> asBlock body -- | A predicate to tell if the expression --when pretty-printed-- @@ -116,12 +133,12 @@ LVar {} -> False LDot _ obj _ -> unsafeInExprStmt_ prec obj LBracket _ obj _ -> unsafeInExprStmt_ prec obj - + instance Pretty (CatchClause a) where prettyPrint (CatchClause _ id s) = text "catch" <+> (parens.prettyPrint) id <+> inBlock s -instance Pretty (ForInit a) where +instance Pretty (ForInit a) where prettyPrint t = case t of NoInit -> empty VarInit vs -> text "var" @@ -133,11 +150,11 @@ ForInVar id -> text "var" <+> prettyPrint id ForInLVal lv -> prettyPrint lv -instance Pretty (LValue a) where +instance Pretty (LValue a) where prettyPrint lv = case lv of LVar _ x -> printIdentifierName x LDot _ e x -> ppObjInDotRef e ppMemberExpression <> text "." <> printIdentifierName x - LBracket _ e1 e2 -> ppMemberExpression e1 <> + LBracket _ e1 e2 -> ppMemberExpression e1 <> brackets (ppExpression True e2) instance Pretty (VarDecl a) where @@ -145,16 +162,21 @@ instance Pretty (CaseClause a) where prettyPrint c = case c of - CaseClause _ e ss -> - text "case" <+> ppExpression True e <> colon nest 2 (prettyPrint ss) - CaseDefault _ ss -> text "default:" nest 2 (prettyPrint ss) + CaseClause _ e ss -> + text "case" <+> ppExpression True e <> suffix ss + CaseDefault _ ss -> + text "default" <> suffix ss + where + suffix :: [Statement a] -> Doc + suffix [] = colon + suffix ss = colon <> nest 2 (linebreak <> prettyPrint ss) -instance Pretty InfixOp where +instance Pretty InfixOp where prettyPrint op = text $ case op of OpMul -> "*" OpDiv -> "/" - OpMod -> "%" - OpAdd -> "+" + OpMod -> "%" + OpAdd -> "+" OpSub -> "-" OpLShift -> "<<" OpSpRShift -> ">>" @@ -175,7 +197,7 @@ OpLAnd -> "&&" OpLOr -> "||" -instance Pretty AssignOp where +instance Pretty AssignOp where prettyPrint op = text $ case op of OpAssign -> "=" OpAssignAdd -> "+=" @@ -190,7 +212,7 @@ OpAssignBXor -> "^=" OpAssignBOr -> "|=" -instance Pretty PrefixOp where +instance Pretty PrefixOp where prettyPrint op = text $ case op of PrefixLNot -> "!" PrefixBNot -> "~" @@ -209,10 +231,10 @@ instance Pretty (Id a) where prettyPrint (Id _ str) = printIdentifierName str -class PP a where +class PP a where pp :: a -> Doc -instance Pretty a => PP a where +instance Pretty a => PP a where pp = prettyPrint -- | DEPRECATED: Use 'prettyPrint' instead! Renders a JavaScript @@ -231,6 +253,10 @@ renderExpression :: Expression a -> String renderExpression = show . prettyPrint +indented :: Int -> Statement a -> Doc +indented _ stmt@BlockStmt {} = prettyPrint stmt +indented width stmt = indent width (prettyPrint stmt) + -- Displays the statement in { ... }, unless it is a block itself. inBlock:: Statement a -> Doc inBlock s@(BlockStmt _ _) = prettyPrint s @@ -238,16 +264,22 @@ asBlock :: [Statement a] -> Doc asBlock [] = lbrace <$$> rbrace -asBlock ss = lbrace <> line <> (indentBlock $ prettyPrint ss) <$$> rbrace +asBlock ss = ppBlock 3 (prettyPrint ss) -indentBlock :: Doc -> Doc -indentBlock = indent 3 +ppBlock :: Int -> Doc -> Doc +ppBlock width doc = lbrace <> nest width (line <> doc) <$$> rbrace ppVarDecl :: Bool -> VarDecl a -> Doc ppVarDecl hasIn vd = case vd of VarDecl _ id Nothing -> prettyPrint id - VarDecl _ id (Just e) -> prettyPrint id <+> equals - <+> ppAssignmentExpression hasIn e + VarDecl _ id (Just e) -> + prettyPrint id <+> equals + maybeAlign (ppAssignmentExpression hasIn e) + where + maybeAlign = + case e of + FuncExpr {} -> Prelude.id + _ -> align -- | Pretty prints a string assuming it's used as an identifier. Note -- that per Spec 7.6 unicode escape sequences representing illegal @@ -278,7 +310,7 @@ regexpEscape = regexpEscapeChar True where regexpEscapeChar :: Bool -- ^ First char? -> String -> String - regexpEscapeChar first s = + regexpEscapeChar first s = case (s, first) of ("", True) -> "(?:)" ("", False)-> "" @@ -301,7 +333,7 @@ IntLit _ n -> int n StringLit _ str -> dquotes $ text $ jsEscape str RegexpLit _ reg g ci -> text "/" <> (text (regexpEscape reg)) <> text "/" <> - (if g then text "g" else empty) <> + (if g then text "g" else empty) <> (if ci then text "i" else empty) ArrayLit _ es -> list $ map (ppAssignmentExpression True) es ObjectLit _ xs -> encloseSep lbrace rbrace comma $ map ppField xs @@ -311,14 +343,14 @@ -- 11.2 ppMemberExpression :: Expression a -> Doc ppMemberExpression e = case e of - FuncExpr _ name params body -> + FuncExpr _ name params body -> text "function" <+> maybe name (\n -> prettyPrint n <> space) <> - parens (cat $ punctuate comma (map prettyPrint params)) <+> + parenList prettyPrint params <+> asBlock body DotRef _ obj id -> ppObjInDotRef obj ppMemberExpression <> text "." <> prettyPrint id - BracketRef _ obj key -> - ppMemberExpression obj <> brackets (ppExpression True key) - NewExpr _ ctor args -> + BracketRef _ obj key -> + ppMemberExpression obj <> brackets (ppExpression True key) + NewExpr _ ctor args -> text "new" <+> ppMemberExpression ctor <> ppArguments args _ -> ppPrimaryExpression e @@ -335,8 +367,7 @@ ppObjInDotRef e p = p e ppArguments :: [Expression a] -> Doc -ppArguments es = - parens $ cat $ punctuate comma (map (ppAssignmentExpression True) es) +ppArguments = parenList (ppAssignmentExpression True) ppLHSExpression :: Expression a -> Doc ppLHSExpression = ppCallExpression @@ -347,7 +378,7 @@ UnaryAssignExpr _ PostfixInc e' -> prettyPrint e' <> text "++" UnaryAssignExpr _ PostfixDec e' -> prettyPrint e' <> text "--" _ -> ppLHSExpression e - + -- 11.4 ppUnaryExpression :: Expression a -> Doc ppUnaryExpression e = case e of @@ -369,105 +400,104 @@ -- 11.5 ppMultiplicativeExpression :: Expression a -> Doc ppMultiplicativeExpression e = case e of - InfixExpr _ op e1 e2 | op `elem` [OpMul, OpDiv, OpMod] -> - ppMultiplicativeExpression e1 <+> prettyPrint op <+> ppUnaryExpression e2 + InfixExpr _ op e1 e2 | op `elem` [OpMul, OpDiv, OpMod] -> + ppMultiplicativeExpression e1 prettyPrint op ppUnaryExpression e2 _ -> ppUnaryExpression e - + -- 11.6 ppAdditiveExpression :: Expression a -> Doc ppAdditiveExpression e = case e of - InfixExpr _ op e1 e2 | op `elem` [OpAdd, OpSub] -> - ppAdditiveExpression e1 <+> prettyPrint op - <+> ppMultiplicativeExpression e2 + InfixExpr _ op e1 e2 | op `elem` [OpAdd, OpSub] -> + ppAdditiveExpression e1 prettyPrint op + ppMultiplicativeExpression e2 _ -> ppMultiplicativeExpression e -- 11.7 ppShiftExpression :: Expression a -> Doc ppShiftExpression e = case e of - InfixExpr _ op e1 e2 | op `elem` [OpLShift, OpSpRShift, OpZfRShift] -> - ppShiftExpression e1 <+> prettyPrint op <+> ppAdditiveExpression e2 + InfixExpr _ op e1 e2 | op `elem` [OpLShift, OpSpRShift, OpZfRShift] -> + ppShiftExpression e1 prettyPrint op ppAdditiveExpression e2 _ -> ppAdditiveExpression e --- 11.8. +-- 11.8. -- | @ppRelationalExpression True@ is RelationalExpression, -- @ppRelationalExpression False@ is RelationalExpressionNoIn ppRelationalExpression :: Bool -> Expression a -> Doc -ppRelationalExpression hasIn e = +ppRelationalExpression hasIn e = let opsNoIn = [OpLT, OpGT, OpLEq, OpGEq, OpInstanceof] ops = if hasIn then OpIn:opsNoIn else opsNoIn - in case e of - InfixExpr _ op e1 e2 | op `elem` ops -> - ppRelationalExpression hasIn e1 <+> prettyPrint op - <+> ppShiftExpression e2 + in case e of + InfixExpr _ op e1 e2 | op `elem` ops -> + ppRelationalExpression hasIn e1 prettyPrint op + ppShiftExpression e2 _ -> ppShiftExpression e - + -- 11.9 ppEqualityExpression :: Bool -> Expression a -> Doc ppEqualityExpression hasIn e = case e of InfixExpr _ op e1 e2 | op `elem` [OpEq, OpNEq, OpStrictEq, OpStrictNEq] -> - ppEqualityExpression hasIn e1 <+> prettyPrint op <+> + ppEqualityExpression hasIn e1 prettyPrint op ppRelationalExpression hasIn e2 _ -> ppRelationalExpression hasIn e - + -- 11.10 ppBitwiseANDExpression :: Bool -> Expression a -> Doc ppBitwiseANDExpression hasIn e = case e of - InfixExpr _ op@OpBAnd e1 e2 -> ppBitwiseANDExpression hasIn e1 <+> - prettyPrint op <+> + InfixExpr _ op@OpBAnd e1 e2 -> ppBitwiseANDExpression hasIn e1 + prettyPrint op ppEqualityExpression hasIn e2 _ -> ppEqualityExpression hasIn e - + ppBitwiseXORExpression :: Bool -> Expression a -> Doc ppBitwiseXORExpression hasIn e = case e of - InfixExpr _ op@OpBXor e1 e2 -> ppBitwiseXORExpression hasIn e1 <+> - prettyPrint op <+> + InfixExpr _ op@OpBXor e1 e2 -> ppBitwiseXORExpression hasIn e1 + prettyPrint op ppBitwiseANDExpression hasIn e2 _ -> ppBitwiseANDExpression hasIn e - + ppBitwiseORExpression :: Bool -> Expression a -> Doc ppBitwiseORExpression hasIn e = case e of - InfixExpr _ op@OpBOr e1 e2 -> ppBitwiseORExpression hasIn e1 <+> - prettyPrint op <+> + InfixExpr _ op@OpBOr e1 e2 -> ppBitwiseORExpression hasIn e1 + prettyPrint op ppBitwiseXORExpression hasIn e2 _ -> ppBitwiseXORExpression hasIn e -- 11.11 ppLogicalANDExpression :: Bool -> Expression a -> Doc ppLogicalANDExpression hasIn e = case e of - InfixExpr _ op@OpLAnd e1 e2 -> ppLogicalANDExpression hasIn e1 <+> - prettyPrint op <+> + InfixExpr _ op@OpLAnd e1 e2 -> ppLogicalANDExpression hasIn e1 + prettyPrint op ppBitwiseORExpression hasIn e2 - _ -> ppBitwiseORExpression hasIn e - + _ -> ppBitwiseORExpression hasIn e + ppLogicalORExpression :: Bool -> Expression a -> Doc ppLogicalORExpression hasIn e = case e of - InfixExpr _ op@OpLOr e1 e2 -> ppLogicalORExpression hasIn e1 <+> - prettyPrint op <+> + InfixExpr _ op@OpLOr e1 e2 -> ppLogicalORExpression hasIn e1 + prettyPrint op ppLogicalANDExpression hasIn e2 _ -> ppLogicalANDExpression hasIn e - + -- 11.12 ppConditionalExpression :: Bool -> Expression a -> Doc ppConditionalExpression hasIn e = case e of - CondExpr _ c et ee -> ppLogicalORExpression hasIn c <+> text "?" <+> - ppAssignmentExpression hasIn et <+> colon <+> + CondExpr _ c et ee -> ppLogicalORExpression hasIn c text "?" <+> + ppAssignmentExpression hasIn et colon <+> ppAssignmentExpression hasIn ee _ -> ppLogicalORExpression hasIn e -- 11.13 ppAssignmentExpression :: Bool -> Expression a -> Doc ppAssignmentExpression hasIn e = case e of - AssignExpr _ op l r -> prettyPrint l <+> prettyPrint op <+> + AssignExpr _ op l r -> prettyPrint l prettyPrint op ppAssignmentExpression hasIn r _ -> ppConditionalExpression hasIn e - + -- 11.14 ppExpression :: Bool -> Expression a -> Doc ppExpression hasIn e = case e of - ListExpr _ es -> cat $ punctuate comma (map (ppExpression hasIn) es) + ListExpr _ es -> parenList (ppExpression hasIn) es _ -> ppAssignmentExpression hasIn e maybe :: Maybe a -> (a -> Doc) -> Doc maybe Nothing _ = empty maybe (Just a) f = f a - diff --git a/src/Language/ECMAScript3/Syntax/Arbitrary.hs b/src/Language/ECMAScript3/Syntax/Arbitrary.hs --- a/src/Language/ECMAScript3/Syntax/Arbitrary.hs +++ b/src/Language/ECMAScript3/Syntax/Arbitrary.hs @@ -22,6 +22,7 @@ import Test.Feat.Class import Test.Feat.Enumerate import Test.Feat.Modifiers +import Control.Arrow deriveEnumerable ''AssignOp deriveEnumerable ''InfixOp @@ -179,55 +180,64 @@ fixUp :: a -> Gen a instance (Data a) => Fixable (JavaScript a) where - fixUp (Script a ss) = (liftM (Script a) (fixBreakContinue ss)) - >>=transformBiM (return . identifierFixup - :: Id a -> Gen (Id a)) - >>=transformBiM (fixUpFunExpr + fixUp = transformBiM (return . identifierFixup + :: Id a -> Gen (Id a)) + >=>transformBiM (fixUpFunExpr :: Expression a -> Gen (Expression a)) - >>=transformBiM (fixUpFunStmt + >=>transformBiM (fixUpListExpr + :: Expression a -> Gen (Expression a)) + >=>transformBiM (fixUpFunStmt :: Statement a -> Gen (Statement a)) - >>=transformBiM (return . fixLValue + >=>transformBiM (return . fixLValue :: LValue a -> Gen (LValue a)) + >=>(\(Script a ss)-> liftM (Script a) $ fixBreakContinue ss) instance (Data a) => Fixable (Expression a) where fixUp = (fixUpFunExpr . transformBi (identifierFixup :: Id a -> Id a)) >=>transformBiM (fixUpFunExpr :: Expression a -> Gen (Expression a)) + >=>transformBiM (fixUpListExpr :: Expression a -> Gen (Expression a)) >=>transformBiM (fixUpFunStmt :: Statement a -> Gen (Statement a)) >=>transformBiM (return . fixLValue :: LValue a -> Gen (LValue a)) instance (Data a) => Fixable (Statement a) where fixUp = (fixUpFunStmt . transformBi (identifierFixup :: Id a -> Id a)) >=>transformBiM (fixUpFunExpr :: Expression a -> Gen (Expression a)) + >=>transformBiM (fixUpListExpr :: Expression a -> Gen (Expression a)) >=>transformBiM (fixUpFunStmt :: Statement a -> Gen (Statement a)) >=>transformBiM (return . fixLValue :: LValue a -> Gen (LValue a)) instance (Data a) => Fixable (CaseClause a) where fixUp = transformBiM (return . identifierFixup :: Id a -> Gen (Id a)) >=>transformBiM (fixUpFunExpr :: Expression a -> Gen (Expression a)) + >=>transformBiM (fixUpListExpr :: Expression a -> Gen (Expression a)) >=>transformBiM (fixUpFunStmt :: Statement a -> Gen (Statement a)) >=>transformBiM (return . fixLValue :: LValue a -> Gen (LValue a)) instance (Data a) => Fixable (CatchClause a) where fixUp = transformBiM (return . identifierFixup :: Id a -> Gen (Id a)) >=>transformBiM (fixUpFunExpr :: Expression a -> Gen (Expression a)) + >=>transformBiM (fixUpListExpr :: Expression a -> Gen (Expression a)) >=>transformBiM (fixUpFunStmt :: Statement a -> Gen (Statement a)) >=>transformBiM (return . fixLValue :: LValue a -> Gen (LValue a)) instance (Data a) => Fixable (ForInit a) where fixUp = transformBiM (return . identifierFixup :: Id a -> Gen (Id a)) >=>transformBiM (fixUpFunExpr :: Expression a -> Gen (Expression a)) + >=>transformBiM (fixUpListExpr :: Expression a -> Gen (Expression a)) >=>transformBiM (fixUpFunStmt :: Statement a -> Gen (Statement a)) >=>transformBiM (return . fixLValue :: LValue a -> Gen (LValue a)) instance (Data a) => Fixable (ForInInit a) where fixUp = transformBiM (return . identifierFixup :: Id a -> Gen (Id a)) >=>transformBiM (fixUpFunExpr :: Expression a -> Gen (Expression a)) + >=>transformBiM (fixUpListExpr :: Expression a -> Gen (Expression a)) >=>transformBiM (fixUpFunStmt :: Statement a -> Gen (Statement a)) >=>transformBiM (return . fixLValue :: LValue a -> Gen (LValue a)) instance (Data a) => Fixable (VarDecl a) where fixUp = transformBiM (return . identifierFixup :: Id a -> Gen (Id a)) >=>transformBiM (fixUpFunExpr :: Expression a -> Gen (Expression a)) + >=>transformBiM (fixUpListExpr :: Expression a -> Gen (Expression a)) >=>transformBiM (fixUpFunStmt :: Statement a -> Gen (Statement a)) >=>transformBiM (return . fixLValue :: LValue a -> Gen (LValue a)) @@ -237,12 +247,14 @@ instance (Data a) => Fixable (Prop a) where fixUp = transformBiM (return . identifierFixup :: Id a -> Gen (Id a)) >=>transformBiM (fixUpFunExpr :: Expression a -> Gen (Expression a)) + >=>transformBiM (fixUpListExpr :: Expression a -> Gen (Expression a)) >=>transformBiM (fixUpFunStmt :: Statement a -> Gen (Statement a)) >=>transformBiM (return . fixLValue :: LValue a -> Gen (LValue a)) instance (Data a) => Fixable (LValue a) where fixUp = transformBiM (return . identifierFixup :: Id a -> Gen (Id a)) >=>transformBiM (fixUpFunExpr :: Expression a -> Gen (Expression a)) + >=>transformBiM (fixUpListExpr :: Expression a -> Gen (Expression a)) >=>transformBiM (fixUpFunStmt :: Statement a -> Gen (Statement a)) >=>transformBiM (return . fixLValue :: LValue a -> Gen (LValue a)) >=>(return . fixLValue) @@ -258,6 +270,11 @@ FuncExpr a mid params body -> liftM (FuncExpr a mid params) $ fixBreakContinue body _ -> return e +fixUpListExpr :: (Data a) => Expression a -> Gen (Expression a) +fixUpListExpr e = case e of + ListExpr a [] -> return $ NullLit a + _ -> return e + fixUpFunStmt :: (Data a) => Statement a -> Gen (Statement a) fixUpFunStmt s = case s of FunctionStmt a id params body -> liftM (FunctionStmt a id params) $ fixBreakContinue body @@ -298,27 +315,25 @@ fixBC stmt@(LabelledStmt a lab s) = do labs <- gets fst if (unId lab) `elem` labs - -- if duplicate label, delete the current statement (but - -- keep it's child statement) - then descendM fixBC stmt - else liftM (LabelledStmt a lab) $ descendM fixBC s + -- if duplicate label, delete the current statement (but + -- keep it's child statement) + then descendM fixBC s + else pushLabel lab $ descendM fixBC stmt fixBC stmt@(BreakStmt a mlab) = do encls <- gets snd - case mlab of - Nothing -> if or $ map isIterSwitch encls then return stmt + case (mlab, encls) of + (_, []) -> return $ EmptyStmt a + (Nothing, _) -> if all isIterSwitch encls + then return stmt -- if none of the enclosing statements is an -- iteration or switch statement, substitute -- the break statement for an empty statement else return $ EmptyStmt a - Just lab@(Id b _) -> + (Just lab@(Id b _), _) -> if any (elem (unId lab) . getLabelSet) encls then return stmt - else if not $ and $ map isIterSwitch encls - -- if none of the enclosing statements is an - -- iteration or switch statement, substitute - -- the break statement for an empty statement - then return $ EmptyStmt a - else case concatMap getLabelSet encls of + else if all isIterSwitch encls + then case concatMap getLabelSet encls of -- if none of the enclosing statements have -- labels, remove the label from the break -- statement @@ -326,17 +341,21 @@ -- if some of them have labels, add the first -- label to the break statement ls -> do newLab <- lift $ selectRandomElement ls - return $ BreakStmt a (Just $ Id b newLab) + return $ BreakStmt a $ Just $ Id b newLab + -- if none of the enclosing statements is an + -- iteration or switch statement, substitute + -- the break statement for an empty statement + else return $ EmptyStmt a fixBC stmt@(ContinueStmt a mlab) = do encls <- gets snd let enIts = filter isIter encls - case mlab of - Nothing -> if not $ null enIts then return stmt - -- if none of the enclosing statements are - -- iteration statements, substitute the - -- continue statement for an empty statement - else return $ EmptyStmt a - Just lab@(Id b _) -> + case (mlab, enIts) of + -- if none of the enclosing statements are + -- iteration statements, substitute the + -- continue statement for an empty statement + (_, []) -> return $ EmptyStmt a + (Nothing, _) -> return stmt + (Just lab@(Id b _), _) -> if any (elem (unId lab) . getLabelSet) enIts then return stmt else case concatMap getLabelSet enIts of @@ -353,7 +372,14 @@ -- label to the break statement ls -> do newLab <- lift $ selectRandomElement ls return $ ContinueStmt a (Just $ Id b newLab) - fixBC s = descendM fixBC s + fixBC s@(WhileStmt {}) = iterCommon s + fixBC s@(DoWhileStmt {}) = iterCommon s + fixBC s@(ForStmt {}) = iterCommon s + fixBC s@(ForInStmt {}) = iterCommon s + fixBC s@(SwitchStmt {}) = pushEnclosing EnclosingSwitch $ descendM fixBC s + fixBC s@(BlockStmt {}) = pushEnclosing EnclosingOther $ descendM fixBC s + fixBC s = descendM fixBC s + iterCommon s = pushEnclosing EnclosingIter $ descendM fixBC s -- | choose n elements from a list randomly rChooseElem :: [a] -> Int -> Gen [a] diff --git a/src/Language/ECMAScript3/Syntax/CodeGen.hs b/src/Language/ECMAScript3/Syntax/CodeGen.hs new file mode 100644 --- /dev/null +++ b/src/Language/ECMAScript3/Syntax/CodeGen.hs @@ -0,0 +1,386 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +-- | Utility combinator functions for simplifying writing programmatic +-- generation of ECMAScript code. Recommended to use together with the +-- -XOverloadedStrings GHC extension. +module Language.ECMAScript3.Syntax.CodeGen where + +import Language.ECMAScript3.Syntax +import Data.Default.Class +import Data.String + +script :: Default a => [Statement a] -> JavaScript a +script = Script def + +instance Default a => IsString (Id a) where + fromString = Id def + +instance Default a => IsString (Prop a) where + fromString = PropString def + +ident :: Default a => String -> Id a +ident = Id def + +propId :: Default a => Id a -> Prop a +propId = PropId def + +propS :: Default a => String -> Prop a +propS = PropString def + +propN :: Default a => Integer -> Prop a +propN = PropNum def + +instance Default a => IsString (LValue a) where + fromString = LVar def + +lvar :: Default a => String -> LValue a +lvar = LVar def + +ldot :: Default a => Expression a -> String -> LValue a +ldot = LDot def + +lbrack :: Default a => Expression a -> Expression a -> LValue a +lbrack = LBracket def + +instance Default a => IsString (Expression a) where + fromString = StringLit def + +string :: Default a => String -> Expression a +string = StringLit def + +regexp :: Default a => String -> Bool -> Bool -> Expression a +regexp = RegexpLit def + +number :: Default a => Double -> Expression a +number = NumLit def + +bool :: Default a => Bool -> Expression a +bool = BoolLit def + +int :: Default a => Int -> Expression a +int = IntLit def + +null_ :: Default a => Expression a +null_ = NullLit def + +array :: Default a => [Expression a] -> Expression a +array = ArrayLit def + +object :: Default a => [(Prop a, Expression a)] -> Expression a +object = ObjectLit def + +this :: Default a => Expression a +this = ThisRef def + +var :: Default a => Id a -> Expression a +var = VarRef def + +dot :: Default a => Expression a -> Id a -> Expression a +dot = DotRef def + +brack :: Default a => Expression a -> Expression a -> Expression a +brack = BracketRef def + +new :: Default a => Expression a -> [Expression a] -> Expression a +new = NewExpr def + +prefix :: Default a => PrefixOp -> Expression a -> Expression a +prefix = PrefixExpr def + +lnot :: Default a => Expression a -> Expression a +lnot = prefix PrefixLNot + +bnot :: Default a => Expression a -> Expression a +bnot = prefix PrefixBNot + +plus :: Default a => Expression a -> Expression a +plus = prefix PrefixPlus + +minus :: Default a => Expression a -> Expression a +minus = prefix PrefixMinus + +typeof :: Default a => Expression a -> Expression a +typeof = prefix PrefixTypeof + +void :: Default a => Expression a -> Expression a +void = prefix PrefixVoid + +delete :: Default a => Expression a -> Expression a +delete = prefix PrefixDelete + +uassign :: Default a => UnaryAssignOp -> LValue a -> Expression a +uassign = UnaryAssignExpr def + +preinc :: Default a => LValue a -> Expression a +preinc = uassign PrefixInc + +predec :: Default a => LValue a -> Expression a +predec = uassign PrefixDec + +postinc :: Default a => LValue a -> Expression a +postinc = uassign PostfixInc + +postdec :: Default a => LValue a -> Expression a +postdec = uassign PostfixDec + +infixe + :: Default a => + InfixOp -> Expression a -> Expression a -> Expression a +infixe = InfixExpr def + +lt :: Default a => Expression a -> Expression a -> Expression a +lt = infixe OpLT + +le :: Default a => Expression a -> Expression a -> Expression a +le = infixe OpLEq + +gt :: Default a => Expression a -> Expression a -> Expression a +gt = infixe OpGT + +ge :: Default a => Expression a -> Expression a -> Expression a +ge = infixe OpGEq + +in_ :: Default a => Expression a -> Expression a -> Expression a +in_= infixe OpIn + +instanceof + :: Default a => Expression a -> Expression a -> Expression a +instanceof = infixe OpInstanceof + +eq :: Default a => Expression a -> Expression a -> Expression a +eq = infixe OpEq + +neq :: Default a => Expression a -> Expression a -> Expression a +neq = infixe OpNEq + +steq :: Default a => Expression a -> Expression a -> Expression a +steq = infixe OpStrictEq + +stneq :: Default a => Expression a -> Expression a -> Expression a +stneq = infixe OpStrictNEq + +land :: Default a => Expression a -> Expression a -> Expression a +land = infixe OpLAnd + +lor :: Default a => Expression a -> Expression a -> Expression a +lor = infixe OpLOr + +mul :: Default a => Expression a -> Expression a -> Expression a +mul = infixe OpMul + +div :: Default a => Expression a -> Expression a -> Expression a +div = infixe OpDiv + +mod :: Default a => Expression a -> Expression a -> Expression a +mod = infixe OpMod + +sub :: Default a => Expression a -> Expression a -> Expression a +sub = infixe OpSub + +lshift :: Default a => Expression a -> Expression a -> Expression a +lshift = infixe OpLShift + +srshift + :: Default a => Expression a -> Expression a -> Expression a +srshift = infixe OpSpRShift + +zrshift + :: Default a => Expression a -> Expression a -> Expression a +zrshift = infixe OpZfRShift + +band :: Default a => Expression a -> Expression a -> Expression a +band = infixe OpBAnd + +bor :: Default a => Expression a -> Expression a -> Expression a +bor = infixe OpBOr + +xor :: Default a => Expression a -> Expression a -> Expression a +xor = infixe OpBXor + +add :: Default a => Expression a -> Expression a -> Expression a +add = infixe OpAdd + +cond + :: Default a => + Expression a -> Expression a -> Expression a -> Expression a +cond = CondExpr def + +assignop :: Default a => AssignOp -> LValue a -> Expression a -> Expression a +assignop = AssignExpr def + +assign + :: Default a => LValue a -> Expression a -> Expression a +assign = assignop OpAssign + +assignadd :: Default a => LValue a -> Expression a -> Expression a +assignadd = assignop OpAssignAdd + +assignsub :: Default a => LValue a -> Expression a -> Expression a +assignsub = assignop OpAssignSub + +assignmul :: Default a => LValue a -> Expression a -> Expression a +assignmul = assignop OpAssignMul + +assigndiv :: Default a => LValue a -> Expression a -> Expression a +assigndiv = assignop OpAssignDiv + +assignmod :: Default a => LValue a -> Expression a -> Expression a +assignmod = assignop OpAssignMod + +assignlshift + :: Default a => LValue a -> Expression a -> Expression a +assignlshift = assignop OpAssignLShift + +assignsrshift + :: Default a => LValue a -> Expression a -> Expression a +assignsrshift = assignop OpAssignSpRShift + +assignzrshift + :: Default a => LValue a -> Expression a -> Expression a +assignzrshift = assignop OpAssignZfRShift + +assignband :: Default a => LValue a -> Expression a -> Expression a +assignband = assignop OpAssignBAnd + +assignxor :: Default a => LValue a -> Expression a -> Expression a +assignxor = assignop OpAssignBXor + +assignbor :: Default a => LValue a -> Expression a -> Expression a +assignbor = assignop OpAssignBOr + +list :: Default a => [Expression a] -> Expression a +list = ListExpr def + +call :: Default a => Expression a -> [Expression a] -> Expression a +call = CallExpr def + +func + :: Default a => Id a -> [Id a] -> [Statement a] -> Expression a +func id = FuncExpr def (Just id) + +lambda :: Default a => [Id a] -> [Statement a] -> Expression a +lambda = FuncExpr def Nothing + +casee :: Default a => Expression a -> [Statement a] -> CaseClause a +casee = CaseClause def + +defaultc :: Default a => [Statement a] -> CaseClause a +defaultc = CaseDefault def + +catch :: Default a => Id a -> Statement a -> CatchClause a +catch = CatchClause def + +vardecl :: Default a => Id a -> VarDecl a +vardecl id = VarDecl def id Nothing + +varinit :: Default a => Id a -> Expression a -> VarDecl a +varinit id = VarDecl def id . Just + +block :: Default a => [Statement a] -> Statement a +block = BlockStmt def + +empty :: Default a => Statement a +empty = EmptyStmt def + +expr :: Default a => Expression a -> Statement a +expr = ExprStmt def + +ifte + :: Default a => + Expression a -> Statement a -> Statement a -> Statement a +ifte = IfStmt def + +ift :: Default a => Expression a -> Statement a -> Statement a +ift = IfSingleStmt def + +switch + :: Default a => Expression a -> [CaseClause a] -> Statement a +switch = SwitchStmt def + +while :: Default a => Expression a -> Statement a -> Statement a +while = WhileStmt def + +dowhile :: Default a => Statement a -> Expression a -> Statement a +dowhile = DoWhileStmt def + +break :: Default a => Maybe (Id a) -> Statement a +break = BreakStmt def + +continue :: Default a => Maybe (Id a) -> Statement a +continue = ContinueStmt def + +label :: Default a => Id a -> Statement a -> Statement a +label = LabelledStmt def + +forin + :: Default a => + ForInInit a -> Expression a -> Statement a -> Statement a +forin = ForInStmt def + +for + :: Default a => + ForInit a + -> Maybe (Expression a) + -> Maybe (Expression a) + -> Statement a + -> Statement a +for = ForStmt def + +try :: Default a => Statement a -> Statement a +try b = TryStmt def b Nothing Nothing + +trycatch + :: Default a => + Statement a -> CatchClause a -> Maybe (Statement a) -> Statement a +trycatch b c = TryStmt def b (Just c) + +tryfinally + :: Default a => Statement a -> Statement a -> Statement a +tryfinally b f = TryStmt def b Nothing (Just f) + +trycatchfinally + :: Default a => + Statement a -> CatchClause a -> Statement a -> Statement a +trycatchfinally b c f = TryStmt def b (Just c) (Just f) + +throw :: Default a => Expression a -> Statement a +throw = ThrowStmt def + +returns :: Default a => Expression a -> Statement a +returns = ReturnStmt def . Just + +ret :: Default a => Statement a +ret = ReturnStmt def Nothing + +with :: Default a => Expression a -> Statement a -> Statement a +with = WithStmt def + +vardecls :: Default a => [VarDecl a] -> Statement a +vardecls = VarDeclStmt def + +function + :: Default a => Id a -> [Id a] -> [Statement a] -> Statement a +function = FunctionStmt def + +-- | Convert an identifier to a String literal +id2string :: Id a -> Expression a +id2string (Id a s) = StringLit a s + +-- | Helper function to convert LValues to expressions +lv2e :: LValue a -> Expression a +lv2e lval = case lval of + LVar a vname -> VarRef a (Id a vname) + LDot a obj fname -> DotRef a obj (Id a fname) + LBracket a obj field -> BracketRef a obj field + +-- | Convert an expression to an l-value. May fail with an error +e2lv :: Expression a -> LValue a +e2lv e = case e of + VarRef a (Id _ vname) -> LVar a vname + DotRef a obj (Id _ fname) -> LDot a obj fname + BracketRef a obj field -> LBracket a obj field + _ -> error "expr2LVal: Can't convert an expression to an LValue" + +forInInit2lv :: ForInInit a -> LValue a +forInInit2lv i = case i of + ForInVar (Id a s) -> LVar a s + ForInLVal lv -> lv diff --git a/src/Language/ECMAScript3/Syntax/QuasiQuote.hs b/src/Language/ECMAScript3/Syntax/QuasiQuote.hs --- a/src/Language/ECMAScript3/Syntax/QuasiQuote.hs +++ b/src/Language/ECMAScript3/Syntax/QuasiQuote.hs @@ -35,10 +35,13 @@ quoteCommon p s = do loc <- TH.location let fname = TH.loc_filename loc let (line, col) = TH.loc_start loc - let p2 = (getPosition >>= \pos -> - setPosition $ (flip setSourceName) fname $ - (flip setSourceLine) line $ - (flip setSourceColumn) col $ pos) >> p + let p2 = do pos <- getPosition + setPosition $ (flip setSourceName) fname $ + (flip setSourceLine) line $ + (flip setSourceColumn) col $ pos + r <- p + eof + return r case parse p2 "" s of Left err -> do TH.report True $ show err return $ TH.UnboxedTupE []