version 0.170.17

5 files changed, 432 insertions, 32 deletions

diff --git a/CHANGELOG b/CHANGELOG
index 36ecb7d..a9973f0 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -1,5 +1,8 @@
 Version change log.
 
+=0.17=
+Added helper functions for code generation (see Language.ECMAScript3.Syntax.CodeGen). Bug fixes to the Arbitrary instances.
+
 =0.16.2=
 Build fixes for GHC 7.4.2 and 7.8.2.
 
diff --git a/LICENSE b/LICENSE
index 31c5c13..7369370 100644
--- a/LICENSE
+++ b/LICENSE
@@ -1,5 +1,5 @@
 Copyright (c) 2007--2012, Brown University, 2008-2012 Claudiu Saftoiu,
-2012-2014 Stevens Institute of Technology.
+2012-2015 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 1d99d61..21f28d0 100644
--- a/language-ecmascript.cabal
+++ b/language-ecmascript.cabal
@@ -1,8 +1,8 @@
 Name:           language-ecmascript
-Version:        0.16.2
+Version:        0.17
 Cabal-Version:	>= 1.10
 Copyright:      (c) 2007-2012 Brown University, (c) 2008-2010 Claudiu Saftoiu,
-                (c) 2012-2014 Stevens Institute of Technology
+                (c) 2012-2015 Stevens Institute of Technology
 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.16.2
+   tag: 0.17
 
 Library
   Hs-Source-Dirs:
@@ -56,6 +56,7 @@ Library
     Language.ECMAScript3.Syntax
     Language.ECMAScript3.Syntax.Annotations
     Language.ECMAScript3.Syntax.Arbitrary
+    Language.ECMAScript3.Syntax.CodeGen
     Language.ECMAScript3.Syntax.QuasiQuote
     Language.ECMAScript3.Analysis.Environment
     Language.ECMAScript3.Analysis.LabelSets
diff --git a/src/Language/ECMAScript3/Syntax/Arbitrary.hs b/src/Language/ECMAScript3/Syntax/Arbitrary.hs
index 48c27a6..d48140c 100644
--- a/src/Language/ECMAScript3/Syntax/Arbitrary.hs
+++ b/src/Language/ECMAScript3/Syntax/Arbitrary.hs
@@ -22,6 +22,7 @@ import Test.Feat
 import Test.Feat.Class
 import Test.Feat.Enumerate
 import Test.Feat.Modifiers
+import Control.Arrow
 
 deriveEnumerable ''AssignOp
 deriveEnumerable ''InfixOp
@@ -179,15 +180,15 @@ 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
+  fixUp  = transformBiM (return . identifierFixup
+                         :: Id a -> Gen (Id a))
+                     >=>transformBiM (fixUpFunExpr
                                       :: Expression a -> Gen (Expression a))
-                     >>=transformBiM (fixUpFunStmt
+                     >=>transformBiM (fixUpFunStmt
                                       :: Statement a -> Gen (Statement a))
-                     >>=transformBiM (return . fixLValue
+                     >=>transformBiM (return . fixLValue
                                       :: LValue a -> Gen (LValue a))
+                     >=>(\(Script a ss)-> liftM (Script a) $ fixBreakContinue ss)
 
 instance (Data a) => Fixable (Expression a) where
   fixUp = (fixUpFunExpr . transformBi (identifierFixup :: Id a -> Id a))
@@ -298,27 +299,25 @@ fixBreakContinue = mapM $ \stmt -> evalStateT (fixBC stmt) ([], [])
       fixBC stmt@(LabelledStmt a lab s) =
         do labs <- gets fst
            if (unId lab) `elem` labs
-              -- if duplicate label, delete the current statement (but
-              -- keep it's child statement)
-              then descendM fixBC stmt
-              else liftM (LabelledStmt a lab) $ descendM fixBC s
+             -- if duplicate label, delete the current statement (but
+             -- keep it's child statement)
+             then descendM fixBC s
+             else pushLabel lab $ descendM fixBC stmt
       fixBC stmt@(BreakStmt a mlab) =
         do encls <- gets snd
-           case mlab of
-             Nothing  -> if or $ map isIterSwitch encls then return stmt
+           case (mlab, encls) of
+             (_, [])  -> return $ EmptyStmt a
+             (Nothing, _)  -> if all isIterSwitch encls
+                         then return stmt
                          -- if none of the enclosing statements is an
                          -- iteration or switch statement, substitute
                          -- the break statement for an empty statement
                          else return $ EmptyStmt a
-             Just lab@(Id b _) ->
+             (Just lab@(Id b _), _) ->
                if any (elem (unId lab) . getLabelSet) encls
                then return stmt
-               else if not $ and $ map isIterSwitch encls
-                       -- if none of the enclosing statements is an
-                       -- iteration or switch statement, substitute
-                       -- the break statement for an empty statement
-                    then return $ EmptyStmt a
-                    else case concatMap getLabelSet encls of
+               else if all isIterSwitch encls
+                    then case concatMap getLabelSet encls of
                       -- if none of the enclosing statements have
                       -- labels, remove the label from the break
                       -- statement
@@ -326,17 +325,21 @@ fixBreakContinue = mapM $ \stmt -> evalStateT (fixBC stmt) ([], [])
                       -- if some of them have labels, add the first
                       -- label to the break statement
                       ls -> do newLab <- lift $ selectRandomElement ls
-                               return $ BreakStmt a (Just $ Id b newLab)
+                               return $ BreakStmt a $ Just $ Id b newLab
+                    -- if none of the enclosing statements is an
+                    -- iteration or switch statement, substitute
+                    -- the break statement for an empty statement
+                    else return $ EmptyStmt a
       fixBC stmt@(ContinueStmt a mlab) =
         do encls <- gets snd
            let enIts = filter isIter encls
-           case mlab of
-             Nothing  -> if not $ null enIts  then return stmt
-                         -- if none of the enclosing statements are
-                         -- iteration statements, substitute the
-                         -- continue statement for an empty statement
-                         else return $ EmptyStmt a
-             Just lab@(Id b _) ->
+           case (mlab, enIts) of
+             -- if none of the enclosing statements are
+             -- iteration statements, substitute the
+             -- continue statement for an empty statement
+             (_, [])  -> return $ EmptyStmt a
+             (Nothing, _)  -> return stmt
+             (Just lab@(Id b _), _) ->
                if any (elem (unId lab) . getLabelSet) enIts
                then return stmt
                else case concatMap getLabelSet enIts of
@@ -353,7 +356,14 @@ fixBreakContinue = mapM $ \stmt -> evalStateT (fixBC stmt) ([], [])
                             -- label to the break statement
                       ls -> do newLab <- lift $ selectRandomElement ls
                                return $ ContinueStmt a (Just $ Id b newLab)
-      fixBC s = descendM fixBC s
+      fixBC s@(WhileStmt {})   = iterCommon s
+      fixBC s@(DoWhileStmt {}) = iterCommon s
+      fixBC s@(ForStmt {})     = iterCommon s
+      fixBC s@(ForInStmt {})   = iterCommon s
+      fixBC s@(SwitchStmt {})  = pushEnclosing EnclosingSwitch $ descendM fixBC s
+      fixBC s@(BlockStmt {})   = pushEnclosing EnclosingOther $ descendM fixBC s
+      fixBC s                  = descendM fixBC s
+      iterCommon s             = pushEnclosing EnclosingIter $ descendM fixBC s
 
 -- | choose n elements from a list randomly
 rChooseElem :: [a] -> Int -> Gen [a]
diff --git a/src/Language/ECMAScript3/Syntax/CodeGen.hs b/src/Language/ECMAScript3/Syntax/CodeGen.hs
new file mode 100644
index 0000000..01dc1c9
--- /dev/null
+++ b/src/Language/ECMAScript3/Syntax/CodeGen.hs
@@ -0,0 +1,386 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
+-- | Utility combinator functions for simplifying writing programmatic
+-- generation of ECMAScript code. Recommended to use together with the
+-- -XOverloadedStrings GHC extension.
+module Language.ECMAScript3.Syntax.CodeGen where
+
+import Language.ECMAScript3.Syntax
+import Data.Default.Class
+import Data.String
+
+script :: Default a => [Statement a] -> JavaScript a
+script = Script def
+
+instance Default a => IsString (Id a) where
+  fromString = Id def
+
+instance Default a => IsString (Prop a) where
+  fromString = PropString def
+
+ident :: Default a => String -> Id a
+ident = Id def
+
+propId :: Default a => Id a -> Prop a
+propId = PropId def
+
+propS :: Default a => String -> Prop a
+propS = PropString def
+
+propN :: Default a => Integer -> Prop a
+propN = PropNum def
+
+instance Default a => IsString (LValue a) where
+  fromString = LVar def
+
+lvar :: Default a => String -> LValue a
+lvar = LVar def
+
+ldot :: Default a => Expression a -> String -> LValue a
+ldot = LDot def
+
+lbrack :: Default a => Expression a -> Expression a -> LValue a
+lbrack = LBracket def
+
+instance Default a => IsString (Expression a) where
+  fromString = StringLit def
+
+string :: Default a => String -> Expression a
+string = StringLit def
+
+regexp :: Default a => String -> Bool -> Bool -> Expression a
+regexp = RegexpLit def
+
+number :: Default a => Double -> Expression a
+number = NumLit def
+
+bool :: Default a => Bool -> Expression a
+bool = BoolLit def
+
+int :: Default a => Int -> Expression a
+int    = IntLit def
+
+null_ :: Default a => Expression a
+null_   = NullLit def
+
+array :: Default a => [Expression a] -> Expression a
+array = ArrayLit def
+
+object :: Default a => [(Prop a, Expression a)] -> Expression a
+object = ObjectLit def
+
+this :: Default a => Expression a
+this = ThisRef def
+
+var :: Default a => Id a -> Expression a
+var = VarRef def
+
+dot :: Default a => Expression a -> Id a -> Expression a
+dot = DotRef def
+
+brack :: Default a => Expression a -> Expression a -> Expression a
+brack = BracketRef def
+
+new :: Default a => Expression a -> [Expression a] -> Expression a
+new = NewExpr def
+
+prefix :: Default a => PrefixOp -> Expression a -> Expression a
+prefix = PrefixExpr def
+
+lnot :: Default a => Expression a -> Expression a
+lnot = prefix PrefixLNot
+
+bnot :: Default a => Expression a -> Expression a
+bnot = prefix PrefixBNot
+
+plus :: Default a => Expression a -> Expression a
+plus = prefix PrefixPlus
+
+minus :: Default a => Expression a -> Expression a
+minus = prefix PrefixMinus
+
+typeof :: Default a => Expression a -> Expression a
+typeof = prefix PrefixTypeof
+
+void :: Default a => Expression a -> Expression a
+void = prefix PrefixVoid
+
+delete :: Default a => Expression a -> Expression a
+delete = prefix PrefixDelete
+
+uassign :: Default a => UnaryAssignOp -> LValue a -> Expression a
+uassign = UnaryAssignExpr def
+
+preinc :: Default a => LValue a -> Expression a
+preinc = uassign PrefixInc
+
+predec :: Default a => LValue a -> Expression a
+predec = uassign PrefixDec
+
+postinc :: Default a => LValue a -> Expression a
+postinc = uassign PostfixInc
+
+postdec :: Default a => LValue a -> Expression a
+postdec = uassign PostfixDec
+
+infixe
+  :: Default a =>
+     InfixOp -> Expression a -> Expression a -> Expression a
+infixe = InfixExpr def
+
+lt :: Default a => Expression a -> Expression a -> Expression a
+lt = infixe OpLT
+
+le :: Default a => Expression a -> Expression a -> Expression a
+le = infixe OpLEq
+
+gt :: Default a => Expression a -> Expression a -> Expression a
+gt = infixe OpGT
+
+ge :: Default a => Expression a -> Expression a -> Expression a
+ge = infixe OpGEq
+
+in_ :: Default a => Expression a -> Expression a -> Expression a
+in_= infixe OpIn
+
+instanceof
+  :: Default a => Expression a -> Expression a -> Expression a
+instanceof = infixe OpInstanceof
+
+eq :: Default a => Expression a -> Expression a -> Expression a
+eq = infixe OpEq
+
+neq :: Default a => Expression a -> Expression a -> Expression a
+neq = infixe OpNEq
+
+steq :: Default a => Expression a -> Expression a -> Expression a
+steq = infixe OpStrictEq
+
+stneq :: Default a => Expression a -> Expression a -> Expression a
+stneq = infixe OpStrictNEq
+
+land :: Default a => Expression a -> Expression a -> Expression a
+land = infixe OpLAnd
+
+lor :: Default a => Expression a -> Expression a -> Expression a
+lor  = infixe OpLOr
+
+mul :: Default a => Expression a -> Expression a -> Expression a
+mul = infixe OpMul
+
+div :: Default a => Expression a -> Expression a -> Expression a
+div = infixe OpDiv
+
+mod :: Default a => Expression a -> Expression a -> Expression a
+mod = infixe OpMod
+
+sub :: Default a => Expression a -> Expression a -> Expression a
+sub = infixe OpSub
+
+lshift :: Default a => Expression a -> Expression a -> Expression a
+lshift = infixe OpLShift
+
+srshift
+  :: Default a => Expression a -> Expression a -> Expression a
+srshift = infixe OpSpRShift
+
+zrshift
+  :: Default a => Expression a -> Expression a -> Expression a
+zrshift = infixe OpZfRShift
+
+band :: Default a => Expression a -> Expression a -> Expression a
+band = infixe OpBAnd
+
+bor :: Default a => Expression a -> Expression a -> Expression a
+bor = infixe OpBOr
+
+xor :: Default a => Expression a -> Expression a -> Expression a
+xor = infixe OpBXor
+
+add :: Default a => Expression a -> Expression a -> Expression a
+add = infixe OpAdd
+
+cond
+  :: Default a =>
+     Expression a -> Expression a -> Expression a -> Expression a
+cond = CondExpr def
+
+assignop :: Default a => AssignOp -> LValue a -> Expression a -> Expression a
+assignop = AssignExpr def
+
+assign
+  :: Default a => LValue a -> Expression a -> Expression a
+assign = assignop OpAssign
+
+assignadd :: Default a => LValue a -> Expression a -> Expression a
+assignadd = assignop OpAssignAdd
+
+assignsub :: Default a => LValue a -> Expression a -> Expression a
+assignsub = assignop OpAssignSub
+
+assignmul :: Default a => LValue a -> Expression a -> Expression a
+assignmul = assignop OpAssignMul
+
+assigndiv :: Default a => LValue a -> Expression a -> Expression a
+assigndiv = assignop OpAssignDiv
+
+assignmod :: Default a => LValue a -> Expression a -> Expression a
+assignmod = assignop OpAssignMod
+
+assignlshift
+  :: Default a => LValue a -> Expression a -> Expression a
+assignlshift = assignop OpAssignLShift
+
+assignsrshift
+  :: Default a => LValue a -> Expression a -> Expression a
+assignsrshift = assignop OpAssignSpRShift
+
+assignzrshift
+  :: Default a => LValue a -> Expression a -> Expression a
+assignzrshift = assignop OpAssignZfRShift
+
+assignband :: Default a => LValue a -> Expression a -> Expression a
+assignband = assignop OpAssignBAnd
+
+assignxor :: Default a => LValue a -> Expression a -> Expression a
+assignxor = assignop OpAssignBXor
+
+assignbor :: Default a => LValue a -> Expression a -> Expression a
+assignbor = assignop OpAssignBOr
+
+list :: Default a => [Expression a] -> Expression a
+list = ListExpr def
+
+call :: Default a => Expression a -> [Expression a] -> Expression a
+call = CallExpr def
+
+func
+  :: Default a => Id a -> [Id a] -> [Statement a] -> Expression a
+func id = FuncExpr def (Just id)
+
+lambda :: Default a => [Id a] -> [Statement a] -> Expression a
+lambda = FuncExpr def Nothing
+
+casee :: Default a => Expression a -> [Statement a] -> CaseClause a
+casee = CaseClause def
+
+defaultc :: Default a => [Statement a] -> CaseClause a
+defaultc = CaseDefault def
+
+catch :: Default a => Id a -> Statement a -> CatchClause a
+catch = CatchClause def
+
+vardecl :: Default a => Id a -> VarDecl a
+vardecl id = VarDecl def id Nothing
+
+varinit :: Default a => Id a -> Expression a -> VarDecl a
+varinit id = VarDecl def id . Just
+
+block :: Default a => [Statement a] -> Statement a
+block = BlockStmt def
+
+empty :: Default a => Statement a
+empty = EmptyStmt def
+
+expr :: Default a => Expression a -> Statement a
+expr = ExprStmt def
+
+ifte
+  :: Default a =>
+     Expression a -> Statement a -> Statement a -> Statement a
+ifte = IfStmt def
+
+ift :: Default a => Expression a -> Statement a -> Statement a
+ift  = IfSingleStmt def
+
+switch
+  :: Default a => Expression a -> [CaseClause a] -> Statement a
+switch = SwitchStmt def
+
+while :: Default a => Expression a -> Statement a -> Statement a
+while = WhileStmt def
+
+dowhile :: Default a => Statement a -> Expression a -> Statement a
+dowhile = DoWhileStmt def
+
+break :: Default a => Maybe (Id a) -> Statement a
+break = BreakStmt def
+
+continue :: Default a => Maybe (Id a) -> Statement a
+continue = ContinueStmt def
+
+label :: Default a => Id a -> Statement a -> Statement a
+label = LabelledStmt def
+
+forin
+  :: Default a =>
+     ForInInit a -> Expression a -> Statement a -> Statement a
+forin = ForInStmt def
+
+for
+  :: Default a =>
+     ForInit a
+     -> Maybe (Expression a)
+     -> Maybe (Expression a)
+     -> Statement a
+     -> Statement a
+for = ForStmt def
+
+try :: Default a => Statement a -> Statement a
+try b = TryStmt def b Nothing Nothing
+
+trycatch
+  :: Default a =>
+     Statement a -> CatchClause a -> Maybe (Statement a) -> Statement a
+trycatch b c = TryStmt def b (Just c)
+
+tryfinally
+  :: Default a => Statement a -> Statement a -> Statement a
+tryfinally b f = TryStmt def b Nothing (Just f)
+
+trycatchfinally
+  :: Default a =>
+     Statement a -> CatchClause a -> Statement a -> Statement a
+trycatchfinally b c f = TryStmt def b (Just c) (Just f)
+
+throw :: Default a => Expression a -> Statement a
+throw = ThrowStmt def
+
+returns :: Default a => Expression a -> Statement a
+returns = ReturnStmt def . Just
+
+ret :: Default a => Statement a
+ret = ReturnStmt def Nothing
+
+with :: Default a => Expression a -> Statement a -> Statement a
+with = WithStmt def
+
+vardecls :: Default a => [VarDecl a] -> Statement a
+vardecls = VarDeclStmt def
+
+function
+  :: Default a => Id a -> [Id a] -> [Statement a] -> Statement a
+function = FunctionStmt def
+
+-- | Convert an identifier to a String literal
+id2string :: Id a -> Expression a
+id2string (Id a s) = StringLit a s
+
+-- | Helper function to convert LValues to expressions
+lv2e :: LValue a -> Expression a
+lv2e lval = case lval of
+  LVar a vname -> VarRef a (Id a vname)
+  LDot a obj fname -> DotRef a obj (Id a fname)
+  LBracket a obj field -> BracketRef a obj field
+
+-- | Convert an expression to an l-value. May fail with an error
+e2lv :: Expression a -> LValue a
+e2lv e = case e of
+  VarRef a (Id _ vname) -> LVar a vname
+  DotRef a obj (Id _ fname) -> LDot a obj fname
+  BracketRef a obj field -> LBracket a obj field
+  _ -> error "expr2LVal: Can't convert an expression to an LValue"
+  
+forInInit2lv :: ForInInit a -> LValue a
+forInInit2lv i = case i of
+  ForInVar (Id a s) -> LVar a s
+  ForInLVal lv      -> lv