language-ecmascript 0.16.2 → 0.19.1.0
raw patch · 9 files changed
Files
- CHANGELOG +26/−0
- LICENSE +1/−2
- language-ecmascript.cabal +34/−23
- src/Language/ECMAScript3/Lexer.hs +46/−17
- src/Language/ECMAScript3/Parser.hs +2/−1
- src/Language/ECMAScript3/PrettyPrint.hs +127/−97
- src/Language/ECMAScript3/Syntax/Arbitrary.hs +54/−28
- src/Language/ECMAScript3/Syntax/CodeGen.hs +386/−0
- src/Language/ECMAScript3/Syntax/QuasiQuote.hs +7/−4
CHANGELOG view
@@ -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.
LICENSE view
@@ -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
language-ecmascript.cabal view
@@ -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
src/Language/ECMAScript3/Lexer.hs view
@@ -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
src/Language/ECMAScript3/Parser.hs view
@@ -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
src/Language/ECMAScript3/PrettyPrint.hs view
@@ -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-
src/Language/ECMAScript3/Syntax/Arbitrary.hs view
@@ -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]
+ src/Language/ECMAScript3/Syntax/CodeGen.hs view
@@ -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
src/Language/ECMAScript3/Syntax/QuasiQuote.hs view
@@ -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 []