Implement generalised list comprehensions

[ghc-hetmet.git] / compiler / deSugar / Coverage.lhs

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 54304f7..d8de328 100644 (file)
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -5,11 +5,11 @@
 \section[Coverage]{@coverage@: the main function}
 
 \begin{code}
-{-# OPTIONS_GHC -w #-}
+{-# OPTIONS -w #-}
 -- The above warning supression flag is a temporary kludge.
 -- While working on this module you are encouraged to remove it and fix
 -- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
 -- for details
 
 module Coverage (addCoverageTicksToBinds) where
@@ -65,7 +65,7 @@ addCoverageTicksToBinds
         :: DynFlags
         -> Module
         -> ModLocation          -- of the current module
-       -> [TyCon]              -- type constructor in this module
+        -> [TyCon]             -- type constructor in this module
         -> LHsBinds Id
         -> IO (LHsBinds Id, HpcInfo, ModBreaks)
 
@@ -195,12 +195,8 @@ addTickLHsBind (L pos (pat@(PatBind { pat_rhs = rhs }))) = do
 -}                        
   return $ L pos $ pat { pat_rhs = rhs' }
 
-{- only internal stuff, not from source, uses VarBind, so we ignore it.
-addTickLHsBind (VarBind var_id var_rhs) = do
-  var_rhs' <- addTickLHsExpr var_rhs  
-  return $ VarBind var_id var_rhs'
--}
-addTickLHsBind other = return other
+-- Only internal stuff, not from source, uses VarBind, so we ignore it.
+addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind
 
 -- Add a tick to the expression no matter what it is.  There is one exception:
 -- for the debugger, if the expression is a 'let', then we don't want to add
@@ -446,23 +442,34 @@ addTickStmt isGuard (BindStmt pat e bind fail) = do
                (addTickSyntaxExpr hpcSrcSpan fail)
 addTickStmt isGuard (ExprStmt e bind' ty) = do
        liftM3 ExprStmt
-               (addTick e)
+               (addTick isGuard e)
                (addTickSyntaxExpr hpcSrcSpan bind')
                (return ty)
-  where
-   addTick e | Just fn <- isGuard = addBinTickLHsExpr fn e
-             | otherwise          = addTickLHsExprAlways e
-
 addTickStmt isGuard (LetStmt binds) = do
        liftM LetStmt
                (addTickHsLocalBinds binds)
 addTickStmt isGuard (ParStmt pairs) = do
-       liftM ParStmt (mapM process pairs)
-  where
-       process (stmts,ids) = 
-               liftM2 (,) 
-                       (addTickLStmts isGuard stmts)
-                       (return ids)
+    liftM ParStmt 
+        (mapM (addTickStmtAndBinders isGuard) pairs)
+addTickStmt isGuard (TransformStmt (stmts, ids) usingExpr maybeByExpr) = do
+    liftM3 TransformStmt 
+        (addTickStmtAndBinders isGuard (stmts, ids))
+        (addTickLHsExprAlways usingExpr)
+        (addTickMaybeByLHsExpr maybeByExpr)
+addTickStmt isGuard (GroupStmt (stmts, binderMap) groupByClause) = do
+    liftM2 GroupStmt 
+        (addTickStmtAndBinders isGuard (stmts, binderMap))
+        (case groupByClause of
+            GroupByNothing usingExpr -> addTickLHsExprAlways usingExpr >>= (return . GroupByNothing)
+            GroupBySomething eitherUsingExpr byExpr -> do
+                eitherUsingExpr' <- mapEitherM addTickLHsExprAlways (addTickSyntaxExpr hpcSrcSpan) eitherUsingExpr
+                byExpr' <- addTickLHsExprAlways byExpr
+                return $ GroupBySomething eitherUsingExpr' byExpr')
+    where
+        mapEitherM f g x = do
+          case x of
+            Left a -> f a >>= (return . Left)
+            Right b -> g b >>= (return . Right)
 addTickStmt isGuard (RecStmt stmts ids1 ids2 tys dictbinds) = do
        liftM5 RecStmt 
                (addTickLStmts isGuard stmts)
@@ -471,6 +478,20 @@ addTickStmt isGuard (RecStmt stmts ids1 ids2 tys dictbinds) = do
                (return tys)
                (addTickDictBinds dictbinds)
 
+addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
+                  | otherwise          = addTickLHsExprAlways e
+
+addTickStmtAndBinders isGuard (stmts, ids) = 
+    liftM2 (,) 
+        (addTickLStmts isGuard stmts)
+        (return ids)
+
+addTickMaybeByLHsExpr :: Maybe (LHsExpr Id) -> TM (Maybe (LHsExpr Id))
+addTickMaybeByLHsExpr maybeByExpr = 
+    case maybeByExpr of
+        Nothing -> return Nothing
+        Just byExpr -> addTickLHsExprAlways byExpr >>= (return . Just)
+
 addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
 addTickHsLocalBinds (HsValBinds binds) = 
        liftM HsValBinds 
@@ -637,7 +658,7 @@ bindLocals :: [Id] -> TM a -> TM a
 bindLocals new_ids (TM m)
   = TM $ \ env st -> 
                  case m env{ inScope = inScope env `extendVarSetList` new_ids } st of
-                   (r, fv, st') -> (r, fv `delListFromUFM` occs, st')
+                   (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st')
   where occs = [ nameOccName (idName id) | id <- new_ids ] 
 
 isBlackListed :: SrcSpan -> TM Bool