diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 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.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, 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 @@ -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) 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 @@ -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 diff --git a/src/Language/ECMAScript3/Syntax.hs b/src/Language/ECMAScript3/Syntax.hs --- a/src/Language/ECMAScript3/Syntax.hs +++ b/src/Language/ECMAScript3/Syntax.hs @@ -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 \ ... \ 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 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 @@ -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 diff --git a/test/Test/Arbitrary.hs b/test/Test/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/test/Test/Arbitrary.hs @@ -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 diff --git a/test/TestMain.hs b/test/TestMain.hs --- a/test/TestMain.hs +++ b/test/TestMain.hs @@ -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 ]