Fix a recomp bug: make classes/datatypes depend directly on DFuns (#4469)

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

diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index d154e04..60dec30 100644 (file)
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -34,7 +34,6 @@ import CoreMonad      ( endPass, CoreToDo(..) )
 import ErrUtils
 import Outputable
 import SrcLoc
-import FastString
 import Coverage
 import Util
 import MonadUtils
@@ -138,7 +137,7 @@ deSugar hsc_env
 
        ; endPass dflags CoreDesugar ds_binds ds_rules_for_imps
 
-        ; used_names <- mkUsedNames tcg_env
+        ; let used_names = mkUsedNames tcg_env
        ; deps <- mkDependencies tcg_env
 
         ; let mod_guts = ModGuts {     
@@ -338,16 +337,17 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
   = putSrcSpanDs loc $ 
     do { let bndrs' = [var | RuleBndr (L _ var) <- vars]
 
-       ; lhs' <- unsetOptM Opt_EnableRewriteRules $
-                 dsLExpr lhs   -- Note [Desugaring RULE left hand sides]
+        ; lhs' <- unsetOptM Opt_EnableRewriteRules $
+                  unsetOptM Opt_WarnIdentities $
+                  dsLExpr lhs   -- Note [Desugaring RULE left hand sides]
 
        ; rhs' <- dsLExpr rhs
 
        -- Substitute the dict bindings eagerly,
        -- and take the body apart into a (f args) form
-       ; case decomposeRuleLhs lhs' of {
-               Nothing -> do { warnDs msg; return Nothing } ;
-               Just (fn_id, args) -> do
+       ; case decomposeRuleLhs bndrs' lhs' of {
+               Left msg -> do { warnDs msg; return Nothing } ;
+               Right (final_bndrs, fn_id, args) -> do
        
        { let is_local = isLocalId fn_id
                -- NB: isLocalId is False of implicit Ids.  This is good becuase
@@ -356,12 +356,9 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
              fn_name   = idName fn_id
              final_rhs = simpleOptExpr rhs'    -- De-crap it
              rule      = mkRule False {- Not auto -} is_local 
-                                 name act fn_name bndrs' args final_rhs
+                                 name act fn_name final_bndrs args final_rhs
        ; return (Just rule)
        } } }
-  where
-    msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar; ignored"))
-            2 (ppr lhs)
 \end{code}
 
 Note [Desugaring RULE left hand sides]
@@ -374,4 +371,6 @@ switching off EnableRewriteRules.  See DsExpr.dsExplicitList.
 
 That keeps the desugaring of list comprehensions simple too.
 
-
+Nor do we want to warn of conversion identities on the LHS;
+the rule is precisly to optimise them:
+  {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}