summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndreyChudnov <>2014-03-15 20:52:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-03-15 20:52:00 (GMT)
commitf82d352677ef3e45fd2f6b8abe5d17fbbe6bae83 (patch)
tree079c798d41c09fac9f67a692b9c984010be47e87
parentf249531e555cb9fd0ed4a68f787727315c0c8f13 (diff)
version 0.160.16
-rw-r--r--CHANGELOG8
-rw-r--r--LICENSE2
-rw-r--r--language-ecmascript.cabal14
-rw-r--r--src/Language/ECMAScript3/Parser.hs2
-rw-r--r--src/Language/ECMAScript3/PrettyPrint.hs50
-rw-r--r--src/Language/ECMAScript3/Syntax.hs178
-rw-r--r--src/Language/ECMAScript3/Syntax/Arbitrary.hs469
-rw-r--r--test/Test/Arbitrary.hs16
-rw-r--r--test/TestMain.hs2
9 files changed, 484 insertions, 257 deletions
diff --git a/CHANGELOG b/CHANGELOG
index a829e8b..579005e 100644
--- 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
index ac6e4ee..31c5c13 100644
--- 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
index 0c0f15b..975995b 100644
--- 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 head
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 @@ Library
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-Suite test
Test.Diff
Test.Unit
Test.Pretty
+ Test.Arbitrary
Build-Depends:
base >= 4 && < 5,
mtl >= 1 && < 3,
@@ -83,7 +85,7 @@ Test-Suite test
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
index f582e16..da6831d 100644
--- a/src/Language/ECMAScript3/Parser.hs
+++ b/src/Language/ECMAScript3/Parser.hs
@@ -29,7 +29,7 @@ import Language.ECMAScript3.Lexer hiding (identifier)
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
index 183dd99..fa0a309 100644
--- a/src/Language/ECMAScript3/PrettyPrint.hs
+++ b/src/Language/ECMAScript3/PrettyPrint.hs
@@ -12,10 +12,14 @@ module Language.ECMAScript3.PrettyPrint (Pretty (..)
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 (ForInInit a) where
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 @@ instance Pretty (Prop a) where
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
@@ -245,6 +249,44 @@ ppVarDecl hasIn vd = case vd of
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
jsEscape:: String -> String
diff --git a/src/Language/ECMAScript3/Syntax.hs b/src/Language/ECMAScript3/Syntax.hs
index d3f6f61..7ed1448 100644
--- 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 @@ module Language.ECMAScript3.Syntax (JavaScript(..)
,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.Typeable (Typeable)
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 @@ isIterationStmt s = case s of
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
index cd587a3..8354897 100644
--- a/src/Language/ECMAScript3/Syntax/Arbitrary.hs
+++ b/src/Language/ECMAScript3/Syntax/Arbitrary.hs
@@ -8,7 +8,7 @@ import Language.ECMAScript3.Syntax
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 Data.Generics.Str
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 @@ instance Arbitrary a => Arbitrary (LValue a) where
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 @@ instance Arbitrary a => Arbitrary (Expression a) where
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 @@ emptyStmtShrink a = [EmptyStmt a2 | a2 <- shrink a]
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 @@ rChooseElem xs n | n > 0 && (not $ null xs) =
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 @@ selectRandomElement xs =
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
index 0000000..ca59670
--- /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
index 9a088bb..8b92727 100644
--- a/test/TestMain.hs
+++ b/test/TestMain.hs
@@ -5,11 +5,13 @@ import Test.Framework
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
]