try/switch accounted for in ANF

src/WebBits/JavaScript/Core.hs

@@ -1,6 +1,14 @@
-module WebBits.JavaScript.Core where
+module WebBits.JavaScript.Core 
+  ( Id
+  , FOp(..)
+  , Lit(..)
+  , Expr(..)
+  , Stmt(..)
+  , stmtLabel
+  ) where
 
 import Data.Generics
+import Control.Arrow (first,second,(***))
 
 type Id = String
 
@@ -76,10 +84,80 @@ data Stmt a
   | ThrowStmt a (Expr a)
   | ReturnStmt a (Maybe (Expr a))
   | LabelledStmt a Id (Stmt a)
-  | BreakStmt a
-  | ContinueStmt a
+  | BreakStmt a Int
+  | ContinueStmt a Int
   | SwitchStmt a Id [(Lit a,Stmt a)]
   | EnterStmt a
   | ExitStmt a
   deriving (Show,Data,Typeable,Eq,Ord)  
 
+stmtLabel :: Stmt a -> a
+stmtLabel stmt = case stmt of
+  (SeqStmt a ss) -> a
+  (EmptyStmt a) -> a
+  (AssignStmt a v e) -> a
+  (DeleteStmt a v1 v2) -> a
+  (NewStmt a result constr args) -> a
+  (CallStmt a result fn args) -> a
+  (MethodCallStmt a result obj method args) -> a
+  (IndirectMethodCallStmt a result obj method args) -> a
+  (IfStmt a e s1 s2) -> a
+  (WhileStmt a e s) -> a
+  (ForInStmt a v e s) -> a
+  (TryStmt a s1 v s2 s3) -> a
+  (ReturnStmt a Nothing) -> a
+  (ReturnStmt a (Just e)) -> a
+  (LabelledStmt a v s) -> a
+  (BreakStmt a v) -> a
+  (ContinueStmt a v) -> a
+  (SwitchStmt a v cs) -> a
+  (EnterStmt a) -> a
+  (ExitStmt a) -> a
+
+
+-- Instances
+
+instance Functor Lit where
+  fmap f (StringLit a s) = StringLit (f a) s
+  fmap f (RegexpLit a s g ci) = RegexpLit (f a) s g ci
+  fmap f (NumLit a d) = NumLit (f a) d
+  fmap f (IntLit a n) = IntLit (f a) n
+  fmap f (BoolLit a b) = BoolLit (f a) b
+  fmap f (NullLit a) = NullLit (f a)
+  fmap f (ArrayLit a es) = ArrayLit (f a) (map (fmap f) es)
+  fmap f (ObjectLit a es) = ObjectLit (f a) (map (second (fmap f)) es)
+
+instance Functor Expr where
+  fmap f (Lit l) = Lit (fmap f l)
+  fmap f (This a) = This (f a)
+  fmap f (VarRef a v) = VarRef (f a) v
+  fmap f (BracketRef a e1 e2) = BracketRef (f a) (fmap f e1) (fmap f e2)
+  fmap f (OpExpr a op es) = OpExpr (f a) op (map (fmap f) es)
+  fmap f (FuncExpr a args locals s) =
+    FuncExpr (f a) args locals (fmap f s)
+
+instance Functor Stmt where
+  fmap f (SeqStmt a ss) = SeqStmt (f a) (map (fmap f) ss)
+  fmap f (EmptyStmt a) = EmptyStmt (f a)
+  fmap f (AssignStmt a v e) = AssignStmt (f a) v (fmap f e)
+  fmap f (DeleteStmt a v1 v2) = DeleteStmt (f a) v1 v2
+  fmap f (NewStmt a result constr args) = NewStmt (f a) result constr args
+  fmap f (CallStmt a result fn args) = CallStmt (f a) result fn args
+  fmap f (MethodCallStmt a result obj method args) =
+    MethodCallStmt (f a) result obj method args
+  fmap f (IndirectMethodCallStmt a result obj method args) =
+    IndirectMethodCallStmt (f a) result obj method args
+  fmap f (IfStmt a e s1 s2) = IfStmt (f a) (fmap f e) (fmap f s1) (fmap f s2)
+  fmap f (WhileStmt a e s) = WhileStmt (f a) (fmap f e) (fmap f s)
+  fmap f (ForInStmt a v e s) = ForInStmt (f a) v (fmap f e) (fmap f s)
+  fmap f (TryStmt a s1 v s2 s3) = 
+    TryStmt (f a) (fmap f s1) v (fmap f s2) (fmap f s3)
+  fmap f (ReturnStmt a Nothing) = ReturnStmt (f a) Nothing
+  fmap f (ReturnStmt a (Just e)) = ReturnStmt (f a) (Just (fmap f e))
+  fmap f (LabelledStmt a v s) = LabelledStmt (f a) v (fmap f s)
+  fmap f (BreakStmt a v) = BreakStmt (f a) v
+  fmap f (ContinueStmt a v) = ContinueStmt (f a) v
+  fmap f (SwitchStmt a v cs) =
+    SwitchStmt (f a) v (map (fmap f *** fmap f) cs)
+  fmap f (EnterStmt a) = EnterStmt (f a)
+  fmap f (ExitStmt a) = ExitStmt (f a)

src/WebBits/JavaScript/Simplify.hs

@@ -83,6 +83,7 @@ removeForStmt (ForStmt p init maybeTest maybeIncr body) = stmts where
     Just e -> ExprStmt p e
 removeForStmt stmt = stmt 
 
+-- TODO: This won't work.  A break/continue in the body will fail.
 removeDoWhileStmt :: Statement SourcePos -> Statement SourcePos
 removeDoWhileStmt (DoWhileStmt p body test) = stmts where
   stmts = BlockStmt p [body,WhileStmt p test body]
@@ -146,7 +147,7 @@ newStmtLabel :: State Int (Id SourcePos)
 newStmtLabel = do
   n <- get
   put (n+1)
-  return (Id noPos ("+label" ++ show n))
+  return (Id noPos ("__webbitslabel" ++ show n))
 
 
 -- |If the expression is not a variable-reference, create a name for it.
@@ -332,7 +333,12 @@ purifyStmt labels stmt = case stmt of
     s1' <- purifyStmt labels s1
     s2' <- purifyStmt labels s2
     return (BlockStmt p [BlockStmt p ess,IfStmt p e' s1' s2'])
-  SwitchStmt p e cases -> fail "cannot handle switch yet"
+  SwitchStmt p e cases -> do
+    (eStmts,e') <- purifyExpr e
+    l <- newStmtLabel
+    cases' <- mapM (purifyCase ((l,ImplicitSwitchLabel):labels)) cases
+    return $ BlockStmt p [BlockStmt p eStmts,
+                          LabelledStmt p l $ SwitchStmt p e' cases']
   WhileStmt p e s -> do
     (ess,e') <- purifyExpr e
     l <- newStmtLabel
@@ -366,7 +372,15 @@ purifyStmt labels stmt = case stmt of
     l <- newStmtLabel
     body' <- purifyStmt ((l,ImplicitLoopLabel):labels) body
     return (BlockStmt p [BlockStmt p exprStmts,ForInStmt p init expr' body']) 
-  TryStmt p body catches finally -> fail "cannot handle try yet"
+  TryStmt p body catches Nothing -> do
+    body' <- purifyStmt labels body
+    catches' <- mapM (purifyCatch labels) catches
+    return (TryStmt p body' catches' Nothing)
+  TryStmt p body catches (Just finally) -> do
+    body' <- purifyStmt labels body
+    catches' <- mapM (purifyCatch labels) catches
+    finally' <- purifyStmt labels finally
+    return (TryStmt p body' catches' (Just finally'))
   ThrowStmt p e -> do
     (es,e') <- purifyExpr e
     return (BlockStmt p [BlockStmt p es,ThrowStmt p e'])
@@ -393,3 +407,25 @@ purifyDecl decl@(VarDecl p id rhs) = case rhs of
   Just expr -> do
     (ss,e) <- purifyExpr expr
     return (ss,VarDecl p id (Just e))
+
+-- TODO: binding for id?
+purifyCatch labels (CatchClause p id s) = do
+  s' <- purifyStmt labels s
+  return (CatchClause p id s')
+
+
+-- |Assumes that the head of 'labels' is an 'ImplicitSwitchLabel'.  After
+-- purification, the list of statements in the body is a single block
+-- statement.
+purifyCase :: [(Id SourcePos,LabelType)]
+           -> CaseClause SourcePos -> State Int (CaseClause SourcePos)
+purifyCase labels (CaseDefault p ss) = do
+  s' <- purifyStmt labels (BlockStmt p ss)
+  return (CaseDefault p [s'])
+purifyCase labels (CaseClause p e ss) = do
+  (es,e') <- purifyExpr e
+  case es of
+    [] -> do s' <- purifyStmt labels (BlockStmt p ss)
+             return (CaseClause p e' [s'])
+    otherwise -> fail $ "semantic error(!!!) at " ++ show p ++ "\n" ++
+                        "the case expression should be side-effect free"

src/WebBits/JavaScript/ToCore.hs

@@ -4,14 +4,31 @@ module WebBits.JavaScript.ToCore
   ) where
 
 import Control.Monad
+import Data.Generics
+import Control.Monad.State.Strict
+import qualified Data.Map as M
+import qualified Data.Foldable as Foldable
+
 import WebBits.Common (pp)
 import Text.PrettyPrint.HughesPJ (render)
 import qualified WebBits.JavaScript.Core as Core
 import WebBits.JavaScript
 import WebBits.JavaScript.Simplify (simplify)
 
-jsToCore :: Show a => [Statement a] -> [Core.Stmt a]
-jsToCore (VarDeclStmt{}:stmts) = map stmt stmts
+
+numberStmts :: [Statement SourcePos] -> [Statement (Int,SourcePos)]
+numberStmts stmts = evalState (gmapM (mkM numberM) stmts') 0 where
+  stmts' :: [Statement (Int,SourcePos)]
+  stmts' = map (fmap (\p -> (0,p))) stmts
+  numberM :: (Int,SourcePos) -> State Int (Int,SourcePos)
+  numberM (_,p) = do
+    n <- get
+    put (n+1)
+    return (n,p)
+
+jsToCore :: [Statement SourcePos]
+         -> [Core.Stmt (Int,SourcePos)]
+jsToCore (VarDeclStmt{}:stmts) = map (stmt M.empty) (numberStmts stmts)
 jsToCore stmts = error $ "jsToCore: missing global vars:\n" ++ show stmts
 
 unId (Id _ v) = v
@@ -55,31 +72,50 @@ unPrefix op = case op of
   PrefixVoid -> Core.PrefixVoid
   otherwise -> error $ "unPrefix cannot translate:\n" ++ show op
 
-stmt :: Show a => Statement a -> Core.Stmt a
-stmt (BlockStmt p ss) = Core.SeqStmt p (map stmt ss)
-stmt (EmptyStmt p) = Core.EmptyStmt p
-stmt (ExprStmt p (AssignExpr _ OpAssign (VarRef _ (Id _ r))  rhs)) = case rhs of
-  CallExpr p (DotRef _ f id) args ->
-    Core.MethodCallStmt p r (unVar f) (unId id) (map unVar args)
-  CallExpr p (BracketRef _ f m) args ->
-    Core.IndirectMethodCallStmt p r (unVar f) (unVar m) (map unVar args)
-  CallExpr p f args -> Core.CallStmt p r (unVar f) (map unVar args)
-  NewExpr p f args -> Core.NewStmt p r (unVar f) (map unVar args)
-  PrefixExpr p PrefixDelete id -> Core.DeleteStmt p r (unVar id)
-  e -> Core.AssignStmt p r (expr e) 
-stmt (IfStmt p e s1 s2) = Core.IfStmt p (expr e) (stmt s1) (stmt s2)
-stmt (WhileStmt p e s) = Core.WhileStmt p (expr e) (stmt s)
-stmt (ForInStmt p (ForInNoVar id) e s) =
-  Core.ForInStmt p (unId id) (expr e) (stmt s)
-stmt (ReturnStmt p maybeE) = Core.ReturnStmt p (liftM expr maybeE)
-stmt s = error $ "cannot translate this statement to core syntax:\n" ++ 
+unlabelled (LabelledStmt _ _ s) = unlabelled s
+unlabelled s = s
+
+getLabel f = case Foldable.find (const True) f of
+  Just a -> a
+  Nothing -> error "getLabel failed"
+
+-- Takes a map from string labels to statement numbers
+stmt :: M.Map String Int
+     -> Statement (Int,SourcePos)
+     -> Core.Stmt (Int,SourcePos)
+stmt lbl (BlockStmt p ss) = Core.SeqStmt p (map (stmt lbl) ss)
+stmt lbl (EmptyStmt p) = Core.EmptyStmt p
+stmt lbl (ExprStmt p (AssignExpr _ OpAssign (VarRef _ (Id _ r))  rhs)) = 
+  case rhs of
+    CallExpr p (DotRef _ f id) args ->
+      Core.MethodCallStmt p r (unVar f) (unId id) (map unVar args)
+    CallExpr p (BracketRef _ f m) args ->
+      Core.IndirectMethodCallStmt p r (unVar f) (unVar m) (map unVar args)
+    CallExpr p f args -> Core.CallStmt p r (unVar f) (map unVar args)
+    NewExpr p f args -> Core.NewStmt p r (unVar f) (map unVar args)
+    PrefixExpr p PrefixDelete id -> Core.DeleteStmt p r (unVar id)
+    e -> Core.AssignStmt p r (expr e) 
+stmt lbl (IfStmt p e s1 s2) = Core.IfStmt p (expr e) (stmt lbl s1) (stmt lbl s2)
+stmt lbl (WhileStmt p e s) = Core.WhileStmt p (expr e) (stmt lbl s)
+stmt lbl (ForInStmt p (ForInNoVar id) e s) =
+  Core.ForInStmt p (unId id) (expr e) (stmt lbl s)
+stmt lbl (ReturnStmt p maybeE) = Core.ReturnStmt p (liftM expr maybeE)
+stmt lbl (LabelledStmt p (Id _ id) s) =
+  stmt (M.insert id (fst $ getLabel $ unlabelled s) lbl) s
+stmt lbl (BreakStmt p (Just (Id _ id))) = case M.lookup id lbl of
+  Just n -> Core.BreakStmt p n
+  Nothing -> error "invalid label for break"
+stmt lbl (ContinueStmt p (Just (Id _ id))) = case M.lookup id lbl of
+  Just n -> Core.ContinueStmt p n
+  Nothing -> error "invalid label for break"
+
+stmt _ s = error $ "cannot translate this statement to core syntax:\n" ++ 
   (render $ pp s) ++ "\n" ++ show s
 
 field (PropString _ s,e) = (Left s,expr e)
 field (PropNum _ n,e) = (Right n,expr e)
 field (PropId _ (Id _ s),e) = (Left s,expr e) 
 
-expr :: Show a => Expression a -> Core.Expr a
 expr (StringLit p s) =  Core.Lit (Core.StringLit p s)
 expr (RegexpLit p s b0 b1) = Core.Lit (Core.RegexpLit p s b0 b1)
 expr (NumLit p x) = Core.Lit (Core.NumLit p x)
@@ -89,7 +125,8 @@ expr (ArrayLit p es) = Core.Lit (Core.ArrayLit p (map expr es))
 expr (ObjectLit p fields) = Core.Lit (Core.ObjectLit p $ map field fields)
 expr (VarRef p (Id _ v)) = Core.VarRef p v
 expr (FuncExpr p args (BlockStmt _ ((VarDeclStmt p' decls):body))) = 
- Core.FuncExpr p (map unId args) (map unDecl decls) (stmt (BlockStmt p' body)) 
+ Core.FuncExpr p (map unId args) (map unDecl decls) 
+               (stmt M.empty (BlockStmt p' body)) 
 expr (InfixExpr p op lhs rhs) =
  Core.OpExpr p (unInfix op) [expr lhs,expr rhs] 
 expr (PrefixExpr p op e) = Core.OpExpr p (unPrefix op) [expr e]