language-ecmascript 0.15.4 → 0.16
raw patch · 9 files changed
+484/−257 lines, 9 filesdep +testing-featdep ~QuickCheck
Dependencies added: testing-feat
Dependency ranges changed: QuickCheck
Files
- CHANGELOG +8/−0
- LICENSE +1/−1
- language-ecmascript.cabal +8/−6
- src/Language/ECMAScript3/Parser.hs +1/−1
- src/Language/ECMAScript3/PrettyPrint.hs +46/−4
- src/Language/ECMAScript3/Syntax.hs +178/−0
- src/Language/ECMAScript3/Syntax/Arbitrary.hs +224/−245
- test/Test/Arbitrary.hs +16/−0
- test/TestMain.hs +2/−0
CHANGELOG view
@@ -1,5 +1,13 @@ Version change log. +=0.16=+Rewritten the Arbitrary instances using 'testing-feat'. Adjusted the+pretty-printer to escape invalid characters in identifier names+automatically, which gives better usability in code generation use-cases.+Added an 'isValid' predicate to check the validity of the AST. Note that the+pretty-printer is guaranteed to produce syntactically correct code only+for valid ASTs.+ =0.15.4= Fixed haddock build failure.
LICENSE view
@@ -1,5 +1,5 @@ Copyright (c) 2007--2012, Brown University, 2008-2012 Claudiu Saftoiu,-2012 Stevens Institute of Technology.+2012-2014 Stevens Institute of Technology. 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.15.4+Version: 0.16 Cabal-Version: >= 1.10 Copyright: (c) 2007-2012 Brown University, (c) 2008-2010 Claudiu Saftoiu,- (c) 2012-2013 Stevens Institute of Technology+ (c) 2012-2014 Stevens Institute of Technology License: BSD3 License-file: LICENSE Author: Andrey Chudnov, Arjun Guha, Spiridon Aristides Eliopoulos,@@ -29,7 +29,7 @@ Source-repository this type: git location: git://github.com/jswebtools/language-ecmascript.git- tag: 0.15.4+ tag: 0.16 Library Hs-Source-Dirs:@@ -42,9 +42,10 @@ containers == 0.*, uniplate >= 1.6 && <1.7, data-default-class >= 0.0.1 && < 0.1,- QuickCheck >= 2.5 && < 2.7,+ QuickCheck >= 2.5 && < 3, template-haskell >= 2.8 && < 2.9,- Diff == 0.3.*+ Diff == 0.3.*,+ testing-feat >= 0.4 && < 0.5 ghc-options: -fwarn-incomplete-patterns Exposed-Modules:@@ -74,6 +75,7 @@ Test.Diff Test.Unit Test.Pretty+ Test.Arbitrary Build-Depends: base >= 4 && < 5, mtl >= 1 && < 3,@@ -83,7 +85,7 @@ directory >= 1.2 && < 1.3, filepath >= 1.3 && < 1.4, HUnit >= 1.2 && < 1.3,- QuickCheck >= 2.5 && < 2.7,+ QuickCheck >= 2.5 && < 3, data-default-class >= 0.0.1 && < 0.1, test-framework >= 0.8 && < 0.9, test-framework-hunit >= 0.3.0 && < 0.4,
src/Language/ECMAScript3/Parser.hs view
@@ -29,7 +29,7 @@ import qualified Language.ECMAScript3.Lexer as Lexer import Language.ECMAScript3.Parser.State import Language.ECMAScript3.Parser.Type-import Language.ECMAScript3.Syntax+import Language.ECMAScript3.Syntax hiding (pushLabel) import Language.ECMAScript3.Syntax.Annotations import Data.Default.Class import Text.Parsec hiding (parse)
src/Language/ECMAScript3/PrettyPrint.hs view
@@ -12,10 +12,14 @@ import Text.PrettyPrint.Leijen hiding (Pretty) import Language.ECMAScript3.Syntax import Prelude hiding (maybe, id)+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." #-} --- | A class of pretty-printable ECMAScript AST nodes.+-- | A class of pretty-printable ECMAScript AST nodes. Will+-- pretty-print correct JavaScript given that the 'isValid' predicate+-- holds for the AST. class Pretty a where -- | Pretty-print an ECMAScript AST node. Use 'render' or 'show' to -- convert 'Doc' to 'String'.@@ -131,8 +135,8 @@ instance Pretty (LValue a) where prettyPrint lv = case lv of- LVar _ x -> text x- LDot _ e x -> ppObjInDotRef e ppMemberExpression <> text "." <> text x+ LVar _ x -> printIdentifierName x+ LDot _ e x -> ppObjInDotRef e ppMemberExpression <> text "." <> printIdentifierName x LBracket _ e1 e2 -> ppMemberExpression e1 <> brackets (ppExpression True e2) @@ -203,7 +207,7 @@ PropNum _ n -> text (show n) instance Pretty (Id a) where- prettyPrint (Id _ str) = text str+ prettyPrint (Id _ str) = printIdentifierName str class PP a where pp :: a -> Doc@@ -244,6 +248,44 @@ VarDecl _ id Nothing -> prettyPrint id VarDecl _ id (Just e) -> prettyPrint id <+> equals <+> ppAssignmentExpression hasIn e++-- | Pretty prints a string assuming it's used as an+-- identifier. Escapes characters that are disallowed by the grammar+-- with unicode escape sequences, so that the resulting program can be+-- parsed later. Note that it does not (and could not) do anything+-- about identifier names that are reserved words as well as empty+-- identifier names.+printIdentifierName :: String -> Doc+printIdentifierName = text . adapt + where adapt [] = []+ adapt (c:cs) = (adaptStart c) ++ (concatMap adaptRest cs)+ adaptStart c = if validIdStart c then [c]+ else unicodeEscape c+ adaptRest c = if validIdPart c then [c]+ else unicodeEscape c+ validIdStart c = unicodeLetter c+ || c == '$'+ || c == '_'+ validIdPart c = validIdStart c+ || validIdPartUnicode c+ unicodeLetter c = case generalCategory c of+ UppercaseLetter -> True+ LowercaseLetter -> True+ TitlecaseLetter -> True+ ModifierLetter -> True+ OtherLetter -> True+ LetterNumber -> True+ _ -> False+ validIdPartUnicode c = case generalCategory c of+ NonSpacingMark -> True+ SpacingCombiningMark -> True+ DecimalNumber -> True+ ConnectorPunctuation -> True+ _ -> False+ -- escapes a given character converting it into a 16-bit+ -- unicode escape sequence+ unicodeEscape :: Char -> String+ unicodeEscape c = "\\u" ++ showHex (ord c) "" -- Based on: -- http://developer.mozilla.org/en/docs/Core_JavaScript_1.5_Guide:Literals
src/Language/ECMAScript3/Syntax.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE ScopedTypeVariables #-} module Language.ECMAScript3.Syntax (JavaScript(..) ,unJavaScript ,Statement(..)@@ -23,6 +24,15 @@ ,UnaryAssignOp(..) ,LValue (..) ,SourcePos+ ,isValid+ ,isValidIdentifier+ ,isValidIdentifierName+ ,EnclosingStatement(..)+ ,pushLabel+ ,pushEnclosing+ ,HasLabelSet (..)+ ,isIter+ ,isIterSwitch ) where import Text.Parsec.Pos(initialPos,SourcePos) -- used by data JavaScript@@ -31,6 +41,10 @@ import Data.Foldable (Foldable) import Data.Traversable (Traversable) import Data.Default.Class+import Data.Generics.Uniplate.Data+import Data.Char+import Control.Monad.State+import Control.Arrow data JavaScript a -- |A script in \<script\> ... \</script\> tags.@@ -239,3 +253,167 @@ ForInStmt {} -> True _ -> False +-- | The ECMAScript standard defines certain syntactic restrictions on+-- programs (or, more precisely, statements) that aren't easily+-- enforced in the AST datatype. These restrictions have to do with+-- labeled statements and break/continue statement, as well as+-- identifier names. Thus, it is possible to manually generate AST's+-- that correspond to syntactically incorrect programs. Use this+-- predicate to check if an 'JavaScript' AST corresponds to a+-- syntactically correct ECMAScript program.+isValid :: forall a. (Data a, Typeable a) => JavaScript a -> Bool+-- =From ECMA-262-3=+-- A program is considered syntactically incorrect if either of the+-- following is true:+-- * The program contains a continue statement without the optional+-- Identifier, which is not nested, directly or indirectly (but not+-- crossing function boundaries), within an IterationStatement.+-- * The program contains a continue statement with the optional+-- Identifier, where Identifier does not appear in the label set of an+-- enclosing (but not crossing function boundaries) IterationStatement.+-- * The program contains a break statement without the optional+-- Identifier, which is not nested, directly or indirectly (but not+-- crossing function boundaries), within an IterationStatement or a+-- SwitchStatement.+-- * The program contains a break statement with the optional+-- Identifier, where Identifier does not appear in the label set of an+-- enclosing (but not crossing function boundaries) Statement.+-- * The program contains a LabelledStatement that is enclosed by a+-- LabelledStatement with the same Identifier as label. This does not+-- apply to labels appearing within the body of a FunctionDeclaration+-- that is nested, directly or indirectly, within a labelled+-- statement.+-- * The identifiers should be valid. See spec 7.6+isValid js = checkIdentifiers js && checkBreakContinueLabels js+ where checkIdentifiers :: (Data a, Typeable a) => JavaScript a -> Bool+ checkIdentifiers js =+ and $ map isValidIdentifierName $+ [n | (Id _ n) :: Id a <- universeBi js] +++ [n | (LVar _ n) :: LValue a <- universeBi js] +++ [n | (LDot _ _ n) :: LValue a <- universeBi js]+ checkBreakContinueLabels js@(Script _ body) = and $ map checkStmt $+ body ++ concat ([body | FuncExpr _ _ _ body <- universeBi js] +++ [body | FunctionStmt _ _ _ body <- universeBi js])++checkStmt :: Statement a -> Bool+checkStmt s = evalState (checkStmtM s) ([], [])++checkStmtM :: Statement a -> State ([Label], [EnclosingStatement]) Bool+checkStmtM stmt = case stmt of+ ContinueStmt a mlab -> do+ encls <- gets snd+ let enIts = filter isIter encls+ return $ case mlab of+ Nothing -> not $ null enIts+ Just lab -> any (elem (unId lab) . getLabelSet) enIts+ BreakStmt a mlab -> do+ encls <- gets snd+ return $ case mlab of+ Nothing -> any isIterSwitch encls+ Just lab -> any (elem (unId lab) . getLabelSet) encls+ LabelledStmt _ lab s -> do+ labs <- gets fst+ if (unId lab) `elem` labs then return False+ else pushLabel lab $ checkStmtM s+ WhileStmt _ _ s -> iterCommon s+ DoWhileStmt _ s _ -> iterCommon s+ ForStmt _ _ _ _ s -> iterCommon s+ ForInStmt _ _ _ s -> iterCommon s+ SwitchStmt _ _ cs -> pushEnclosing EnclosingSwitch $ liftM and $ mapM checkCaseM cs+ BlockStmt _ ss -> pushEnclosing EnclosingOther $ liftM and $ mapM checkStmtM ss+ IfStmt _ _ t e -> liftM2 (&&) (checkStmtM t) (checkStmtM e)+ IfSingleStmt _ _ t -> checkStmtM t+ TryStmt _ body mcatch mfinally -> liftM2 (&&) (checkStmtM body) $+ liftM2 (&&) (maybe (return True) checkCatchM mcatch)+ (maybe (return True) checkStmtM mfinally)+ WithStmt _ _ body -> checkStmtM body+ _ -> return True++iterCommon s = pushEnclosing EnclosingIter $ checkStmtM s++pushEnclosing :: Monad m => ([Label] -> EnclosingStatement)+ -> StateT ([Label], [EnclosingStatement]) m a+ -> StateT ([Label], [EnclosingStatement]) m a+pushEnclosing ctor = bracketState (\(labs, encls) -> ([], ctor labs:encls))++pushLabel :: Monad m => Id b -> StateT ([Label], [EnclosingStatement]) m a+ -> StateT ([Label], [EnclosingStatement]) m a+pushLabel l = bracketState (first (unId l:))++checkCaseM c = let ss = case c of+ CaseClause _ _ body -> body+ CaseDefault _ body -> body+ in liftM and $ mapM checkStmtM ss++checkCatchM (CatchClause _ _ body) = checkStmtM body++bracketState :: Monad m => (s -> s) -> StateT s m a -> StateT s m a+bracketState f m = do original <- get+ modify f+ rv <- m+ put original+ return rv++-- | Checks if an identifier name is valid according to the spec+isValidIdentifier :: Id a -> Bool+isValidIdentifier (Id _ name) = isValidIdentifierName name++isValidIdentifierName :: String -> Bool+isValidIdentifierName name = (not $ null name) && name `notElem` reservedWords+ where reservedWords = keyword ++ futureReservedWord ++ nullKw ++ boolLit+ keyword = ["break", "case", "catch", "continue", "default", "delete"+ ,"do", "else", "finally", "for", "function", "if", "in"+ ,"instanceof", "new", "return", "switch", "this", "throw"+ ,"try", "typeof", "var", "void", "while", "with"]+ futureReservedWord = ["abstract", "boolean", "byte", "char", "class"+ ,"const", "debugger", "enum", "export", "extends"+ ,"final", "float", "goto", "implements", "int"+ ,"interface", "long", "native", "package", "private"+ ,"protected", "short", "static", "super"+ ,"synchronized", "throws", "transient", "volatile"]+ nullKw = ["null"]+ boolLit = ["true", "false"]+ +data EnclosingStatement = EnclosingIter [Label]+ -- ^ The enclosing statement is an iteration statement+ | EnclosingSwitch [Label]+ -- ^ The enclosing statement is a switch statement+ | EnclosingOther [Label]+ -- ^ The enclosing statement is some other+ -- statement. Note, `EnclosingOther` is+ -- never pushed if the current `labelSet` is+ -- empty, so the list of labels in this+ -- constructor should always be non-empty++instance Show EnclosingStatement where+ show (EnclosingIter ls) = "iteration" ++ show ls+ show (EnclosingSwitch ls) = "switch" ++ show ls+ show (EnclosingOther ls) = "statement" ++ show ls++isIter :: EnclosingStatement -> Bool+isIter (EnclosingIter _) = True+isIter _ = False++isIterSwitch :: EnclosingStatement -> Bool+isIterSwitch (EnclosingIter _) = True+isIterSwitch (EnclosingSwitch _) = True+isIterSwitch _ = False++class HasLabelSet a where+ getLabelSet :: a -> [Label]+ setLabelSet :: [Label] -> a -> a++modifyLabelSet :: HasLabelSet a => ([Label] -> [Label]) -> a -> a+modifyLabelSet f a = setLabelSet (f $ getLabelSet a) a++instance HasLabelSet EnclosingStatement where+ getLabelSet e = case e of+ EnclosingIter ls -> ls+ EnclosingSwitch ls -> ls+ EnclosingOther ls -> ls+ setLabelSet ls e = case e of+ EnclosingIter _ -> EnclosingIter ls+ EnclosingSwitch _ -> EnclosingSwitch ls+ EnclosingOther _ -> EnclosingOther ls++type Label = String
src/Language/ECMAScript3/Syntax/Arbitrary.hs view
@@ -8,7 +8,7 @@ import Test.QuickCheck hiding (Prop) import Test.QuickCheck.Arbitrary import Test.QuickCheck.Property (forAllShrink)-import Data.Map hiding (map,null,filter,foldr)+import Data.Map hiding (map,null,filter,foldr,toList,singleton) import Data.List (nub,delete) import Data.Data import Data.Char@@ -18,56 +18,59 @@ import Control.Monad import Control.Monad.State import Data.Maybe (maybeToList)+import Test.Feat+import Test.Feat.Class+import Test.Feat.Enumerate+import Test.Feat.Modifiers +deriveEnumerable ''AssignOp+deriveEnumerable ''InfixOp+deriveEnumerable ''UnaryAssignOp+deriveEnumerable ''PrefixOp+deriveEnumerable ''Id+deriveEnumerable ''CaseClause+deriveEnumerable ''CatchClause+deriveEnumerable ''Prop+deriveEnumerable ''LValue+deriveEnumerable ''ForInit+deriveEnumerable ''ForInInit+deriveEnumerable ''VarDecl+deriveEnumerable ''Expression+deriveEnumerable ''Statement+deriveEnumerable ''JavaScript++ instance Arbitrary (AssignOp) where- arbitrary = - elements [OpAssign, OpAssignAdd, OpAssignSub, OpAssignMul, OpAssignDiv, - OpAssignMod, OpAssignLShift, OpAssignSpRShift, OpAssignZfRShift,- OpAssignBAnd, OpAssignBXor, OpAssignBOr]+ arbitrary = sized uniform instance Arbitrary (InfixOp) where- arbitrary = - elements [OpLT, OpLEq, OpGT, OpGEq , OpIn , OpInstanceof, OpEq, OpNEq, - OpStrictEq, OpStrictNEq, OpLAnd, OpLOr,- OpMul, OpDiv, OpMod , OpSub, OpLShift, OpSpRShift,- OpZfRShift, OpBAnd, OpBXor, OpBOr, OpAdd]- + arbitrary = sized uniform+ instance Arbitrary (UnaryAssignOp) where- arbitrary = - elements [PrefixInc, PrefixDec, PostfixInc, PostfixDec]+ arbitrary = sized uniform instance Arbitrary (PrefixOp) where- arbitrary = - elements [PrefixLNot, PrefixBNot, PrefixPlus, PrefixMinus, - PrefixTypeof, PrefixVoid, PrefixDelete]-+ arbitrary = sized uniform -instance Arbitrary a => Arbitrary (Id a) where- arbitrary = liftM2 Id arbitrary identifier+instance (Enumerable a, Arbitrary a) => Arbitrary (Id a) where+ arbitrary = sized uniform >>= fixUp shrink (Id a s) = [Id na ns | ns <- shrink s, na <- shrink a] -instance Arbitrary a => Arbitrary (CaseClause a) where- arbitrary = oneof [caseclause, casedefault]- where caseclause = liftM3 CaseClause arbitrary arbitrary arbitrary- casedefault = liftM2 CaseDefault arbitrary arbitrary+instance (Enumerable a, Arbitrary a, Data a) => Arbitrary (CaseClause a) where+ arbitrary = sized uniform shrink (CaseClause a expr stmts) = [CaseClause na ne ns | na <- shrink a, ne <- shrink expr, ns <- shrink stmts] shrink (CaseDefault a stmts) = [CaseDefault na ns | na <- shrink a, ns <- shrink stmts] -instance Arbitrary a => Arbitrary (Prop a) where- arbitrary = oneof [liftM2 PropId arbitrary arbitrary,- liftM2 PropString arbitrary nonEmptyString,- liftM2 PropNum arbitrary nonNegative- ]+instance (Enumerable a, Arbitrary a) => Arbitrary (Prop a) where+ arbitrary = sized uniform shrink (PropId a id) = [PropId na nid | nid <- shrink id, na <- shrink a] shrink (PropString a s) = [PropString na ns | ns <- shrink s, na <- shrink a] shrink (PropNum a i) = [PropNum na ni | ni <- shrink i, na <- shrink a] -instance Arbitrary a => Arbitrary (LValue a) where - arbitrary = oneof [liftM2 LVar arbitrary identifier,- liftM3 LDot arbitrary arbitrary identifier,- liftM3 LBracket arbitrary arbitrary arbitrary]+instance (Data a, Enumerable a, Arbitrary a) => Arbitrary (LValue a) where + arbitrary = sized uniform shrink (LVar a s) = [LVar na ns | ns <- shrink s, na <- shrink a] shrink (LDot a e s) = [LDot na ne ns | ne <- shrink e, ns <-shrink s, na <-shrink a] shrink (LBracket a e1 e2) = [LBracket na ne1 ne2 | ne1 <- shrink e1, ne2 <-shrink e2, na <- shrink a]@@ -75,85 +78,8 @@ cshrink :: Arbitrary a => [a] -> [a] cshrink = concat . shrink -identifier :: Gen String-identifier = sized sizedIdent- where sizedIdent n = do s <- identStart- rest <- identRest (n-1)- return (s:rest)- identStart = arbitrary `suchThat` isIdentStart- identRest n | n < 1 = return ""- identRest n = do p <- identPart- rest <- identRest (n-1)- return (p:rest)- identPart = do arbitrary `suchThat` isIdentPart- isIdentStart c = isLetter c || c == '$' || c == '_'- isIdentPart c = isIdentStart c || isMark c || isNumber c---- minimum size generator-type MSGen a = (Int, Gen a)--sGen :: [MSGen a] -> Gen a-sGen gens = - sized f - where f n | n >= 0 = oneof $ map snd (filter (\(m, _) -> n >= m) gens)- f _ = f 0--recursive :: Gen a -> Gen a-recursive g = sized (\n -> resize (n-1) g)--rarbitrary :: Arbitrary a => Gen a-rarbitrary = recursive arbitrary--rrarbitrary :: Arbitrary a => Gen a-rrarbitrary = recursive $ recursive arbitrary--atLeastOfSize :: Arbitrary a => Int -> Gen a -> Gen a-atLeastOfSize l gen = sized $ \s -> if s < l then resize l gen else gen--listOfN :: Arbitrary a => Int -> Gen a -> Gen [a]-listOfN l gen = sized $ \n ->- let l' = l `max` 0- in do k <- choose (l', l' `max` n)- vectorOf k gen--nonEmptyString :: Gen String-nonEmptyString = sized $ \s -> if s < 1 then stringOfLength 1 else stringOfLength s--regexpBody = nonEmptyString--nonNegative :: (Arbitrary a, Num a) => Gen a-nonNegative = liftM abs arbitrary--stringOfLength :: Int -> Gen String-stringOfLength 0 = return ""-stringOfLength n = do c <- arbitrary- rs <- stringOfLength (n-1)- return (c:rs)--instance Arbitrary a => Arbitrary (Expression a) where- arbitrary = - sGen [(0, liftM ThisRef arbitrary),- (0, liftM NullLit arbitrary),- (0, liftM2 StringLit arbitrary arbitrary),- (0, liftM2 NumLit arbitrary nonNegative),- (0, liftM2 IntLit arbitrary nonNegative),- (0, liftM2 BoolLit arbitrary arbitrary),- (0, liftM4 RegexpLit arbitrary regexpBody arbitrary arbitrary),- (1, liftM2 ArrayLit arbitrary rarbitrary),- (1, liftM2 ObjectLit arbitrary rarbitrary),- (0, liftM2 VarRef arbitrary arbitrary),- (1, liftM3 DotRef arbitrary rarbitrary arbitrary),- (2, liftM3 BracketRef arbitrary rarbitrary rarbitrary),- (3, liftM3 NewExpr arbitrary rarbitrary rrarbitrary),- (1, liftM3 PrefixExpr arbitrary arbitrary rarbitrary),- (2, liftM3 UnaryAssignExpr arbitrary arbitrary rarbitrary),- (2, liftM4 InfixExpr arbitrary arbitrary rarbitrary rarbitrary),- (3, liftM4 CondExpr arbitrary rarbitrary rarbitrary rarbitrary),- (3, liftM4 AssignExpr arbitrary rarbitrary rarbitrary rarbitrary),- (3, liftM2 ListExpr arbitrary (recursive (listOfN 2 arbitrary))),- (3, liftM3 CallExpr arbitrary rarbitrary rrarbitrary),- (1, liftM4 FuncExpr arbitrary arbitrary arbitrary rarbitrary)]- +instance (Enumerable a, Arbitrary a, Data a) => Arbitrary (Expression a) where+ arbitrary = sized uniform >>= fixUp shrink (StringLit a s) = [StringLit na ns | na <- shrink a, ns <- shrink s] shrink (RegexpLit a s b1 b2) = [RegexpLit na ns nb1 nb2 | na <- shrink a, nb1 <- shrink b1, nb2 <- shrink b2, ns <- shrink s] shrink (NumLit a d) = [NumLit na nd | na <- shrink a, nd <- shrink d]@@ -179,59 +105,27 @@ shrink (CallExpr a e es) = (shrink e) ++ [e] ++ (cshrink es) ++ es ++ [CallExpr na ne nes | na <- shrink a, ne <- shrink e, nes <- shrink es] shrink (FuncExpr a mid ids s) = [FuncExpr na nmid nids ns | na <- shrink a, nmid <- shrink mid, nids <- shrink ids, ns <- shrink s] -instance Arbitrary a => Arbitrary (ForInInit a) where- arbitrary = oneof [liftM ForInVar arbitrary,- liftM ForInLVal arbitrary]+instance (Enumerable a, Arbitrary a, Data a) => Arbitrary (ForInInit a) where+ arbitrary = sized uniform >>= fixUp shrink (ForInVar id) = [ForInVar nid | nid <- shrink id] shrink (ForInLVal id) = [ForInLVal nid | nid <- shrink id] -instance Arbitrary a => Arbitrary (ForInit a) where - arbitrary = - frequency [- (2, return NoInit),- (1, liftM VarInit arbitrary),- (1, liftM ExprInit arbitrary)]+instance (Enumerable a, Arbitrary a, Data a) => Arbitrary (ForInit a) where + arbitrary = sized uniform >>= fixUp shrink (NoInit) = [] shrink (VarInit vds) = [VarInit nvds | nvds <- shrink vds] shrink (ExprInit e) = [ExprInit ne | ne <- shrink e] -instance Arbitrary a => Arbitrary (CatchClause a) where- arbitrary = liftM3 CatchClause arbitrary arbitrary arbitrary+instance (Enumerable a, Arbitrary a, Data a) => Arbitrary (CatchClause a) where+ arbitrary = sized uniform >>= fixUp shrink (CatchClause a id s) = [CatchClause na nid ns | na <- shrink a, nid <- shrink id, ns <- shrink s] -instance Arbitrary a => Arbitrary (VarDecl a) where- arbitrary = liftM3 VarDecl arbitrary arbitrary arbitrary+instance (Enumerable a, Arbitrary a, Data a) => Arbitrary (VarDecl a) where+ arbitrary = sized uniform >>= fixUp shrink (VarDecl a id me) = [VarDecl na nid nme | na <- shrink a, nid <- shrink id, nme <- shrink me] -instance Arbitrary a => Arbitrary (Statement a) where- arbitrary = - sGen [(2, liftM2 BlockStmt arbitrary rrarbitrary),- (0, liftM EmptyStmt arbitrary),- (1, liftM2 ExprStmt arbitrary rarbitrary),- (3, liftM4 IfStmt arbitrary rarbitrary rarbitrary rarbitrary),- (2, liftM3 IfSingleStmt arbitrary rarbitrary rarbitrary),- (3, liftM3 SwitchStmt arbitrary rarbitrary rrarbitrary),- (2, liftM3 WhileStmt arbitrary rarbitrary rarbitrary),- (2, liftM3 DoWhileStmt arbitrary rarbitrary rarbitrary),- (0, liftM2 BreakStmt arbitrary arbitrary),- (0, liftM2 ContinueStmt arbitrary arbitrary),- (1, liftM3 LabelledStmt arbitrary arbitrary rarbitrary),- (3, liftM4 ForInStmt arbitrary rarbitrary rarbitrary rarbitrary),- (4, liftM5 ForStmt arbitrary rarbitrary rarbitrary rarbitrary rarbitrary),- (4, arbtry),- (1, liftM2 ThrowStmt arbitrary rarbitrary),- (1, liftM2 ReturnStmt arbitrary rarbitrary),- (2, liftM3 WithStmt arbitrary rarbitrary rarbitrary),- (2, liftM2 VarDeclStmt arbitrary (listOf1 rrarbitrary)),- (1, liftM4 FunctionStmt arbitrary arbitrary arbitrary rarbitrary)]- where arbtry = - do (mCatch, mFinally) <- oneof [liftM2 (,) (return Nothing) (liftM Just rarbitrary),- liftM2 (,) (liftM Just rarbitrary) (return Nothing),- liftM2 (,) (liftM Just rarbitrary) (liftM Just rarbitrary)]- a <- arbitrary - body <- rarbitrary- return $ TryStmt a body mCatch mFinally- +instance (Enumerable a, Arbitrary a, Data a) => Arbitrary (Statement a) where+ arbitrary = sized uniform >>= fixUp shrink (BlockStmt a body) = emptyStmtShrink a ++ [BlockStmt as bs | as <- shrink a, bs <- shrink body] shrink (EmptyStmt a) = emptyStmtShrink a@@ -275,20 +169,185 @@ type LabelSubst = Map (Id ()) (Id ()) emptyConstantPool = Data.Map.empty -instance (Data a, Arbitrary a) => Arbitrary (JavaScript a) where- arbitrary = do {s <- liftM2 Script arbitrary arbitrary;- if isProgramFixable s then fixLabels s- else arbitrary}+instance (Data a, Arbitrary a, Enumerable a) => Arbitrary (JavaScript a) where+ arbitrary = sized uniform >>= fixUp shrink (Script a ss) = [Script na nss | na <- shrink a, nss <- shrink ss]- --- | Fixes labels so that labeled breaks and continues refer to--- existing labeled statements, enclosing them; also, reduces the size--- of the label set. Assumes that the program has a proper syntactic--- structure, i.e. 'isProgramFixable' s = True.-fixLabels :: (Data a) => JavaScript a -> Gen (JavaScript a)-fixLabels s = - fixBreakContinueLabels s >>= removeDuplicateLabels+++-- | A class of AST elements that need fixup after generation+class Fixable a where+ 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+ :: Expression a -> Gen (Expression a))+ >>=transformBiM (fixUpFunStmt+ :: Statement a -> Gen (Statement a))+ >>=transformBiM (return . fixLValue+ :: LValue a -> Gen (LValue a))++instance (Data a) => Fixable (Expression a) where+ fixUp = (fixUpFunExpr . transformBi (identifierFixup :: Id a -> Id a))+ >=>transformBiM (fixUpFunExpr :: 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 (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 (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 (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 (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 (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 (fixUpFunStmt :: Statement a -> Gen (Statement a))+ >=>transformBiM (return . fixLValue :: LValue a -> Gen (LValue a))++instance Fixable (Id a) where+ fixUp = return . identifierFixup++instance (Data a) => Fixable (Prop a) where+ fixUp = transformBiM (return . identifierFixup :: Id a -> Gen (Id a))+ >=>transformBiM (fixUpFunExpr :: 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 (fixUpFunStmt :: Statement a -> Gen (Statement a))+ >=>transformBiM (return . fixLValue :: LValue a -> Gen (LValue a))+ >=>(return . fixLValue)++fixLValue :: LValue a -> LValue a+fixLValue lv = case lv of+ LVar a n -> LVar a $ identifierNameFixup n+ LDot a o n -> LDot a o $ identifierNameFixup n+ LBracket {} -> lv++fixUpFunExpr :: (Data a) => Expression a -> Gen (Expression a)+fixUpFunExpr e = case e of+ FuncExpr a mid params body -> liftM (FuncExpr a mid params) $ fixBreakContinue body+ _ -> 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+ _ -> return s++identifierFixup :: Id a -> Id a+identifierFixup (Id a n) = Id a $ identifierNameFixup n++-- | Renames empty identifiers, as well as identifiers that are+-- keywords or future reserved words by prepending a '_' to them+identifierNameFixup :: String -> String+identifierNameFixup name = if isValidIdentifierName name then name+ else '_':name++-- | Fixes an incorrect nesting of break/continue, making the program+-- abide by the ECMAScript spec (page 92): any continue without a+-- label should be nested within an iteration stmt, any continue with+-- a label should be nested in a labeled statement (not necessarily+-- with the same label); any break statement without a label should be+-- nested in an iteration or switch stmt, any break statement with a+-- label should be nested in a labeled statement (not necessarily with+-- the same label). This is done by either assigning a label (from the+-- set of labels in current scope) to a break/continue statement that+-- doesn't have one (or has a label that's not present in the current+-- scope). Additionally, it removes nested labelled statements with+-- duplicate labels (also a requirement imposed by the spec).+fixBreakContinue :: (Data a) => [Statement a] -> Gen [Statement a]+fixBreakContinue = mapM $ \stmt -> evalStateT (fixBC stmt) ([], [])+ where+ fixBC :: Data a => Statement a -> StateT ([String], [EnclosingStatement]) Gen (Statement a)+ 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+ fixBC stmt@(BreakStmt a mlab) =+ do encls <- gets snd+ case mlab of+ Nothing -> if or $ map 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 _) ->+ 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+ -- if none of the enclosing statements have+ -- labels, remove the label from the break+ -- statement+ [] -> return $ BreakStmt a Nothing+ -- 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)+ 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 _) ->+ if any (elem (unId lab) . getLabelSet) enIts+ then return stmt+ else case concatMap getLabelSet enIts of+ -- if none of the enclosing statements have+ -- labels, remove the label from the continue+ -- statement+ [] -> if not $ null enIts then return $ ContinueStmt a Nothing+ -- if none of the enclosing statements are+ -- iteration statements, substitute the+ -- continue statement for an empty+ -- statement+ else return $ EmptyStmt a+ -- if some of them have labels, add the first+ -- label to the break statement+ ls -> do newLab <- lift $ selectRandomElement ls+ return $ ContinueStmt a (Just $ Id b newLab)+ fixBC s = descendM fixBC s+ -- | choose n elements from a list randomly rChooseElem :: [a] -> Int -> Gen [a] rChooseElem xs n | n > 0 && (not $ null xs) = @@ -296,62 +355,6 @@ else (vectorOf n $ choose (0, n-1)) >>= (\subst -> return $ foldr (\n ys -> (xs!!n):ys) [] subst) rChooseElem _ _ = return [] ---- | A predicate that tells us whether a program has a fixable/correct--- label-break/continue structure. The predicate imposes syntactic--- restrictions on the break, continue and labeled statements as in--- the ECMA spec-isProgramFixable :: (Data a ) => JavaScript a -> Bool-isProgramFixable (Script _ stmts) = - Prelude.and $ - Prelude.map - (\stmt -> isBreakContinueFixable stmt False False False) - stmts---- | Imposes relaxed restrictions on break and continue per ECMAScript--- 5 spec (page 92): any continue without a label should be nested--- within an iteration stmt, any continue with a label should be--- nested in a labeled statement (not necessarily with the same--- label); any break statement without a label should be nested in an--- iteration or switch stmt, any break statement with a label should--- be nested in a labeled statement (not necessarily with the same--- label).-isBreakContinueFixable :: (Data a) => Statement a -> - Bool -> - Bool -> - Bool ->- Bool-isBreakContinueFixable stmt inLabeled inIter inSwitch =- case stmt of- ContinueStmt _ Nothing -> inIter- ContinueStmt _ (Just label) -> inLabeled- BreakStmt _ Nothing -> inIter || inSwitch- BreakStmt _ (Just label) -> inLabeled- LabelledStmt _ label _ -> - continue stmt True inIter inSwitch- _ -> if isIterationStmt stmt then- continue stmt inLabeled True inSwitch- else if isSwitchStmt stmt then- continue stmt inLabeled inIter True - else True- -- _ -> continue stmt inLabeled inIter inSwitch- where continue stmt inLabeled inIter inSwitch =- and $ map (\s -> isBreakContinueFixable s inLabeled inIter inSwitch) (children stmt)- --- | Removes duplicate labels from nested labeled statements in order--- to impose restrictions on labeled statements as per ECMAScript 5--- spec (page 95): nested labeled statements cannot have duplicating--- labels.-removeDuplicateLabels :: Data a => JavaScript a -> Gen (JavaScript a)-removeDuplicateLabels (Script x stmts) =- return $ Script x (map (\stmt -> (evalState (transformM removeDL stmt) [])) stmts)- where- removeDL :: Statement a -> State [String] (Statement a)- removeDL stmt@(LabelledStmt x lab s) = - do {enclosingLabels <- get;- if Prelude.elem (unId lab) enclosingLabels then return s- else modify ((:) $ unId lab) >> return stmt}- removeDL s = return s -- | Selects a random element of the list selectRandomElement :: [a] -> Gen a@@ -359,30 +362,6 @@ let l = length xs in do n <- arbitrary return $ xs !! (n `mod` l - 1)--- | Changes labels of break/continue so that they refer to one of the--- enclosing labels-fixBreakContinueLabels :: Data a => JavaScript a -> Gen (JavaScript a)-fixBreakContinueLabels (Script x stmts) =- do stmts2 <- mapM (\stmt -> (evalStateT (fixBCL stmt) [])) stmts- return $ Script x stmts2- where- fixBCL :: Data a => Statement a -> StateT [String] Gen (Statement a)- fixBCL stmt@(LabelledStmt _ lab s) =- do modify ((:) $ unId lab)- descendM fixBCL stmt- fixBCL stmt@(BreakStmt x (Just (Id y lab))) =- do {labels <- get;- if lab `notElem` labels then- do {newLab <- lift $ selectRandomElement labels;- return $ BreakStmt x (Just $ Id y newLab)}- else return stmt}- fixBCL stmt@(ContinueStmt x (Just (Id y lab))) =- do {labels <- get;- if lab `notElem` labels then- do {newLab <- lift $ selectRandomElement labels;- return $ ContinueStmt x (Just $ Id y newLab)}- else return stmt}- fixBCL s = return s isSwitchStmt :: Statement a -> Bool isSwitchStmt (SwitchStmt _ _ _) = True
+ test/Test/Arbitrary.hs view
@@ -0,0 +1,16 @@+-- | A test for the Arbitrary instances for AST's. Checks that the+-- instances generated are always valid per the 'isValid' predicate in+-- 'Syntax'.+module Test.Arbitrary where++import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Language.ECMAScript3.Syntax+import Language.ECMAScript3.Syntax.Arbitrary++test_arbitrary :: Test+test_arbitrary = testProperty "Arbitrary generates valid ASTs"+ arbitraryGeneratesValidASTs++arbitraryGeneratesValidASTs :: JavaScript () -> Bool+arbitraryGeneratesValidASTs = isValid
test/TestMain.hs view
@@ -5,11 +5,13 @@ import Test.Unit import Test.Pretty import Test.Diff+import Test.Arbitrary -- entry point for the test-suite main = defaultMain tests tests = [tests_diff ,tests_unit+ ,test_arbitrary --,tests_pretty -- disabled the pretty tests until version 1.0 ]