Commit f85903ab authored by David Himmelstrup's avatar David Himmelstrup

Remember the free vars in HsRule.

parent f6baf3ba
......@@ -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
......
......@@ -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)
......
......@@ -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 "#-}") ]
......
......@@ -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 }
......
......@@ -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
......
......@@ -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)
......
......@@ -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 []
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment