Using blacklist of places not to cover, rather than reverse-engineer deriving.

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

diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index 4b60768..cb861ae 100644 (file)
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -19,6 +19,7 @@ import MkIface
 import Id
 import Name
 import CoreSyn
+import OccurAnal
 import PprCore
 import DsMonad
 import DsExpr
@@ -89,7 +90,7 @@ deSugar hsc_env
                     HscNothing -> return (Just ([], [], NoStubs, noHpcInfo, emptyModBreaks))
                      _        -> do (binds_cvr,ds_hpc_info, modBreaks) 
                                              <- if opt_Hpc || target == HscInterpreted
-                                                 then addCoverageTicksToBinds dflags mod mod_loc binds
+                                                 then addCoverageTicksToBinds dflags mod mod_loc (typeEnvTyCons type_env) binds 
                                                  else return (binds, noHpcInfo, emptyModBreaks)
                                     initDs hsc_env mod rdr_env type_env $ do
                                        { core_prs <- dsTopLHsBinds auto_scc binds_cvr
@@ -172,7 +173,9 @@ deSugar hsc_env
                mg_binds        = ds_binds,
                mg_foreign      = ds_fords,
                mg_hpc_info     = ds_hpc_info,
-                mg_modBreaks    = modBreaks }
+                mg_modBreaks    = modBreaks,
+                mg_vect_info    = noVectInfo
+              }
         ; return (Just mod_guts)
        }}}
 
@@ -277,13 +280,13 @@ ppr_ds_rules rules
 dsRule :: Module -> IdSet -> LRuleDecl Id -> DsM (Maybe CoreRule)
 dsRule mod in_scope (L loc (HsRule name act vars lhs tv_lhs rhs fv_rhs))
   = putSrcSpanDs loc $ 
-    do { let bndrs     = [var | RuleBndr (L _ var) <- vars]
+    do { let bndrs = [var | RuleBndr (L _ var) <- vars]
        ; lhs'  <- dsLExpr lhs
        ; rhs'  <- dsLExpr rhs
 
-       ; case decomposeRuleLhs bndrs lhs' of {
+       ; case decomposeRuleLhs (occurAnalyseExpr lhs') of {
                Nothing -> do { warnDs msg; return Nothing } ;
-               Just (bndrs', fn_id, args) -> do
+               Just (fn_id, args) -> do
        
        -- Substitute the dict bindings eagerly,
        -- and take the body apart into a (f args) form
@@ -294,7 +297,7 @@ dsRule mod in_scope (L loc (HsRule name act vars lhs tv_lhs rhs fv_rhs))
              fn_name   = idName fn_id
 
              rule = Rule { ru_name = name, ru_fn = fn_name, ru_act = act,
-                           ru_bndrs = bndrs', ru_args = args, ru_rhs = rhs', 
+                           ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs', 
                            ru_rough = roughTopNames args, 
                            ru_local = local_rule }
        ; return (Just rule)