From f85903abe9103e545ea5b1dc6fdd6b672da4f3f2 Mon Sep 17 00:00:00 2001 From: Lemmih Date: Wed, 1 Mar 2006 19:41:45 +0000 Subject: [PATCH] Remember the free vars in HsRule. --- ghc/compiler/deSugar/Desugar.lhs | 2 +- ghc/compiler/hsSyn/HsBinds.lhs | 1 + ghc/compiler/hsSyn/HsDecls.lhs | 5 ++++- ghc/compiler/parser/Parser.y.pp | 2 +- ghc/compiler/rename/RnSource.lhs | 12 ++++++------ ghc/compiler/typecheck/TcHsSyn.lhs | 4 ++-- ghc/compiler/typecheck/TcRules.lhs | 6 +++--- 7 files changed, 18 insertions(+), 14 deletions(-) diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index c6e75ba..45dc113 100644 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 [] -- 1.7.10.4