Add (a) CoreM monad, (b) new Annotations feature

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

diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index ab9f8c7..8387146 100644 (file)
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -17,7 +17,6 @@ import MkIface
 import Id
 import Name
 import CoreSyn
-import OccurAnal
 import PprCore
 import DsMonad
 import DsExpr
@@ -64,7 +63,8 @@ deSugar hsc_env
                            tcg_fix_env      = fix_env,
                            tcg_inst_env     = inst_env,
                            tcg_fam_inst_env = fam_inst_env,
-                           tcg_warns      = warns,
+                           tcg_warns        = warns,
+                           tcg_anns         = anns,
                            tcg_binds        = binds,
                            tcg_fords        = fords,
                            tcg_rules        = rules,
@@ -134,6 +134,7 @@ deSugar hsc_env
                mg_rdr_env      = rdr_env,
                mg_fix_env      = fix_env,
                mg_warns        = warns,
+               mg_anns         = anns,
                mg_types        = type_env,
                mg_insts        = insts,
                mg_fam_insts    = fam_insts,
@@ -255,16 +256,16 @@ ppr_ds_rules rules
 dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
 dsRule (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 (occurAnalyseExpr lhs') of {
-               Nothing -> do { warnDs msg; return Nothing } ;
-               Just (fn_id, args) -> do
-       
        -- Substitute the dict bindings eagerly,
        -- and take the body apart into a (f args) form
+       ; case decomposeRuleLhs (mkLams bndrs' lhs') of {
+               Nothing -> do { warnDs msg; return Nothing } ;
+               Just (bndrs, fn_id, args) -> do
+       
        { let local_rule = isLocalId fn_id
                -- NB: isLocalId is False of implicit Ids.  This is good becuase
                -- we don't want to attach rules to the bindings of implicit Ids,