Remember the free vars in HsRule.

diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs
index c6e75ba..45dc113 100644 (file)
--- a/ghc/compiler/deSugar/Desugar.lhs
+++ b/ghc/compiler/deSugar/Desugar.lhs
@@ -263,7 +263,7 @@ ppr_ds_rules rules
 
 \begin{code}
 dsRule :: Module -> IdSet -> LRuleDecl Id -> DsM (Maybe CoreRule)
-dsRule mod in_scope (L loc (HsRule name act vars lhs rhs))
+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]
        ; lhs'  <- dsLExpr lhs

diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs
index 69b75b4..b5c2179 100644 (file)
--- a/ghc/compiler/hsSyn/HsBinds.lhs
+++ b/ghc/compiler/hsSyn/HsBinds.lhs
@@ -40,6 +40,7 @@ data HsLocalBinds id  -- Bindings in a 'let' expression
                        -- or a 'where' clause
   = HsValBinds (HsValBinds id)
   | HsIPBinds  (HsIPBinds id)
+
   | EmptyLocalBinds
 
 data HsValBinds id     -- Value bindings (not implicit parameters)

diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs
index dadcc6b..8ff3985 100644 (file)
--- a/ghc/compiler/hsSyn/HsDecls.lhs
+++ b/ghc/compiler/hsSyn/HsDecls.lhs
@@ -36,6 +36,7 @@ import HsBinds                ( HsValBinds(..), HsBind, LHsBinds, plusHsValBinds,
 import HsPat           ( HsConDetails(..), hsConArgs )
 import HsImpExp                ( pprHsVar )
 import HsTypes
+import NameSet          ( NameSet )
 import HscTypes                ( DeprecTxt )
 import CoreSyn         ( RuleName )
 import Kind            ( Kind, pprKind )
@@ -750,7 +751,9 @@ data RuleDecl name
        Activation
        [RuleBndr name]         -- Forall'd vars; after typechecking this includes tyvars
        (Located (HsExpr name)) -- LHS
+        NameSet                 -- Free-vars from the LHS
        (Located (HsExpr name)) -- RHS
+        NameSet                 -- Free-vars from the RHS
 
 data RuleBndr name
   = RuleBndr (Located name)
@@ -760,7 +763,7 @@ collectRuleBndrSigTys :: [RuleBndr name] -> [LHsType name]
 collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]
 
 instance OutputableBndr name => Outputable (RuleDecl name) where
-  ppr (HsRule name act ns lhs rhs)
+  ppr (HsRule name act ns lhs fv_lhs rhs fv_rhs)
        = sep [text "{-# RULES" <+> doubleQuotes (ftext name) <+> ppr act,
               nest 4 (pp_forall <+> pprExpr (unLoc lhs)), 
               nest 4 (equals <+> pprExpr (unLoc rhs) <+> text "#-}") ]

diff --git a/ghc/compiler/parser/Parser.y.pp b/ghc/compiler/parser/Parser.y.pp
index 156cedc..d49ec76 100644 (file)
--- a/ghc/compiler/parser/Parser.y.pp
+++ b/ghc/compiler/parser/Parser.y.pp
@@ -532,7 +532,7 @@ rule        :: { LHsDecl RdrName }
        : STRING activation rule_forall infixexp '=' exp
             { LL $ RuleD (HsRule (getSTRING $1) 
                                  ($2 `orElse` AlwaysActive) 
-                                 $3 $4 $6) }
+                                 $3 $4 placeHolderNames $6 placeHolderNames) }
 
 activation :: { Maybe Activation } 
         : {- empty -}                           { Nothing }

diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 2d6da1f..9150440 100644 (file)
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -330,25 +330,25 @@ extendTyVarEnvForMethodBinds tyvars thing_inside
 %*********************************************************
 
 \begin{code}
-rnHsRuleDecl (HsRule rule_name act vars lhs rhs)
+rnHsRuleDecl (HsRule rule_name act vars lhs fv_lhs rhs fv_rhs)
   = bindPatSigTyVarsFV (collectRuleBndrSigTys vars)    $
 
     bindLocatedLocalsFV doc (map get_var vars)         $ \ ids ->
     mapFvRn rn_var (vars `zip` ids)            `thenM` \ (vars', fv_vars) ->
 
-    rnLExpr lhs                                        `thenM` \ (lhs', fv_lhs) ->
-    rnLExpr rhs                                        `thenM` \ (rhs', fv_rhs) ->
+    rnLExpr lhs                                        `thenM` \ (lhs', fv_lhs') ->
+    rnLExpr rhs                                        `thenM` \ (rhs', fv_rhs') ->
     let
        mb_bad = validRuleLhs ids lhs'
     in
     checkErr (isNothing mb_bad)
             (badRuleLhsErr rule_name lhs' mb_bad)      `thenM_`
     let
-       bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)]
+       bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
     in
     mappM (addErr . badRuleVar rule_name) bad_vars     `thenM_`
-    returnM (HsRule rule_name act vars' lhs' rhs',
-            fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
+    returnM (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
+            fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs')
   where
     doc = text "In the transformation rule" <+> ftext rule_name
   

diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index c2355a0..6389f34 100644 (file)
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -822,7 +822,7 @@ zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id]
 zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs
 
 zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
-zonkRule env (HsRule name act (vars::[RuleBndr TcId]) lhs rhs)
+zonkRule env (HsRule name act (vars::[RuleBndr TcId]) lhs fv_lhs rhs fv_rhs)
   = mappM zonk_bndr vars               `thenM` \ new_bndrs ->
     newMutVar emptyVarSet              `thenM` \ unbound_tv_set ->
     let
@@ -858,7 +858,7 @@ zonkRule env (HsRule name act (vars::[RuleBndr TcId]) lhs rhs)
        final_bndrs :: [Located Var]
        final_bndrs = map noLoc (varSetElems unbound_tvs) ++ new_bndrs
     in
-    returnM (HsRule name act (map RuleBndr final_bndrs) new_lhs new_rhs)
+    returnM (HsRule name act (map RuleBndr final_bndrs) new_lhs fv_lhs new_rhs fv_rhs)
                -- I hate this map RuleBndr stuff
   where
    zonk_bndr (RuleBndr v) 

diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs
index 5017533..b14c2c9 100644 (file)
--- a/ghc/compiler/typecheck/TcRules.lhs
+++ b/ghc/compiler/typecheck/TcRules.lhs
@@ -28,7 +28,7 @@ tcRules :: [LRuleDecl Name] -> TcM [LRuleDecl TcId]
 tcRules decls = mappM (wrapLocM tcRule) decls
 
 tcRule :: RuleDecl Name -> TcM (RuleDecl TcId)
-tcRule (HsRule name act vars lhs rhs)
+tcRule (HsRule name act vars lhs fv_lhs rhs fv_rhs)
   = addErrCtxt (ruleCtxt name)                 $
     traceTc (ptext SLIT("---- Rule ------")
                 <+> ppr name)                  `thenM_` 
@@ -84,8 +84,8 @@ tcRule (HsRule name act vars lhs rhs)
 
     returnM (HsRule name act
                    (map (RuleBndr . noLoc) (forall_tvs2 ++ tpl_ids))   -- yuk
-                   (mkHsDictLet lhs_binds lhs')
-                   (mkHsDictLet rhs_binds rhs'))
+                   (mkHsDictLet lhs_binds lhs') fv_lhs
+                   (mkHsDictLet rhs_binds rhs') fv_rhs)
   where
 
 tcRuleBndrs [] thing_inside = thing_inside []