Refactor the desugaring of RULE lhss a bit

This is just a tidy-up.  Previously we were calling occurAnalyse
twice on each LHS which was silly and a bit unclean too.  

This patch should have no overall effect, though.

2 files changed, 34 insertions, 33 deletions

diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index ab9f8c7c26..45baa67125 100644
--- 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
@@ -255,16 +254,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, 
diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 764e44b470..a47551ebe2 100644
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -23,6 +23,7 @@ import {-# SOURCE #-}	Match( matchWrapper )
 import DsMonad
 import DsGRHSs
 import DsUtils
+import OccurAnal
 
 import HsSyn		-- lots of things
 import CoreSyn		-- lots of things
@@ -32,12 +33,11 @@ import CoreFVs
 
 import TcHsSyn	( mkArbitraryType )	-- Mis-placed?
 import TcType
-import OccurAnal
 import CostCentre
 import Module
 import Id
 import Name	( localiseName )
-import Var	( TyVar )
+import Var	( Var, TyVar )
 import VarSet
 import Rules
 import VarEnv
@@ -333,27 +333,17 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
     do	{ let poly_name = idName poly_id
 	; spec_name <- newLocalName poly_name
 	; ds_spec_expr  <- dsExpr spec_expr
-	; let (bndrs, body) = collectBinders (occurAnalyseExpr ds_spec_expr)
-	      -- ds_spec_expr may look like
-	      --     /\a. f a Int dOrdInt
-	      -- or  /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl
-		-- The occurrence-analysis does two things
-		-- (a) identifies unused binders: Note [Unused spec binders]
-		-- (b) sorts dict bindings into NonRecs 
-		--	so they can be inlined by decomposeRuleLhs
-	      mb_lhs = decomposeRuleLhs body
-
-	-- Check for dead binders: Note [Unused spec binders]
-	; case filter isDeadBinder bndrs of {
-		bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing }
-		   | otherwise -> 
+	; case (decomposeRuleLhs ds_spec_expr) of {
+	    Nothing -> do { warnDs decomp_msg; return Nothing } ;
 
-	  case mb_lhs of
-	    Nothing -> do { warnDs decomp_msg; return Nothing }
+	    Just (bndrs, _fn, args) ->
 
-	    Just (_, args) -> do {
+	-- Check for dead binders: Note [Unused spec binders]
+	  case filter isDeadBinder bndrs of {
+		bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing } 
+		   | otherwise -> do
 
-	  f_body <- fix_up (Let mono_bind (Var mono_id))
+	{ f_body <- fix_up (Let mono_bind (Var mono_id))
 
 	; let	  local_poly  = setIdNotExported poly_id
 			-- Very important to make the 'f' non-exported,
@@ -372,7 +362,7 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
 			        (extra_dict_bndrs ++ bndrs) args
 				(mkVarApps (Var spec_id) bndrs)
 	; return (Just (addInlineInfo inl spec_id spec_rhs, rule))
-	} } }
+	} } } }
   where
 	-- Bind to Any any of all_ptvs that aren't 
 	-- relevant for this particular function 
@@ -463,19 +453,31 @@ confused. Hence the use of 'localise' to make it Internal.
 %************************************************************************
 
 \begin{code}
-decomposeRuleLhs :: CoreExpr -> Maybe (Id, [CoreExpr])
+decomposeRuleLhs :: CoreExpr -> Maybe ([Var], Id, [CoreExpr])
+-- Take apart the LHS of a RULE.  It's suuposed to look like
+--     /\a. f a Int dOrdInt
+-- or  /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl
+-- That is, the RULE binders are lambda-bound
 -- Returns Nothing if the LHS isn't of the expected shape
 decomposeRuleLhs lhs 
-  = go emptyVarEnv (occurAnalyseExpr lhs)	-- Occurrence analysis sorts out the dict
-						-- bindings so we know if they are recursive
+  = case (decomp emptyVarEnv body) of
+	Nothing 	-> Nothing
+	Just (fn, args) -> Just (bndrs, fn, args)
   where
+    occ_lhs = occurAnalyseExpr lhs
+		-- The occurrence-analysis does two things
+		-- (a) identifies unused binders: Note [Unused spec binders]
+		-- (b) sorts dict bindings into NonRecs 
+		--	so they can be inlined by 'decomp'
+    (bndrs, body) = collectBinders occ_lhs
+
         -- Substitute dicts in the LHS args, so that there 
         -- aren't any lets getting in the way
         -- Note that we substitute the function too; we might have this as
         -- a LHS:       let f71 = M.f Int in f71
-    go env (Let (NonRec dict rhs) body) 
-        = go (extendVarEnv env dict (simpleSubst env rhs)) body
-    go env body 
+    decomp env (Let (NonRec dict rhs) body) 
+        = decomp (extendVarEnv env dict (simpleSubst env rhs)) body
+    decomp env body 
         = case collectArgs (simpleSubst env body) of
             (Var fn, args) -> Just (fn, args)
             _              -> Nothing