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')]
- in
- mappM (addErr . badRuleVar rule_name) bad_vars `thenM_`
+
+ checkValidRule rule_name ids lhs' fv_lhs' `thenM_`
+
returnM (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs')
where
rn_var (RuleBndrSig (L loc v) t, id)
= rnHsTypeFVs doc t `thenM` \ (t', fvs) ->
returnM (RuleBndrSig (L loc id) t', fvs)
+
+badRuleVar name var
+ = sep [ptext SLIT("Rule") <+> doubleQuotes (ftext name) <> colon,
+ ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
+ ptext SLIT("does not appear on left hand side")]
\end{code}
-Check the shape of a transformation rule LHS. Currently
-we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
-not one of the @forall@'d variables. We also restrict the form of the LHS so
-that it may be plausibly matched. Basically you only get to write ordinary
-applications. (E.g. a case expression is not allowed: too elaborate.)
+Note [Rule LHS validity checking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Check the shape of a transformation rule LHS. Currently we only allow
+LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
+@forall@'d variables.
-NB: if you add new cases here, make sure you add new ones to TcRule.ruleLhsTvs
+We used restrict the form of the 'ei' to prevent you writing rules
+with LHSs with a complicated desugaring (and hence unlikely to match);
+(e.g. a case expression is not allowed: too elaborate.)
+But there are legitimate non-trivial args ei, like sections and
+lambdas. So it seems simmpler not to check at all, and that is why
+check_e is commented out.
+
\begin{code}
+checkValidRule rule_name ids lhs' fv_lhs'
+ = do { -- Check for the form of the LHS
+ case (validRuleLhs ids lhs') of
+ Nothing -> return ()
+ Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)
+
+ -- Check that LHS vars are all bound
+ ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
+ ; mappM (addErr . badRuleVar rule_name) bad_vars }
+
validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
-- Nothing => OK
-- Just e => Not ok, and e is the offending expression
check (HsVar v) | v `notElem` foralls = Nothing
check other = Just other -- Failure
- checkl_e (L loc e) = check_e e
+ -- Check an argument
+ checkl_e (L loc e) = Nothing -- Was (check_e e); see Note [Rule LHS validity checking]
+{- Commented out; see Note [Rule LHS validity checking] above
check_e (HsVar v) = Nothing
check_e (HsPar e) = checkl_e e
check_e (HsLit e) = Nothing
check_e other = Just other -- Fails
checkl_es es = foldr (seqMaybe . checkl_e) Nothing es
+-}
-badRuleLhsErr name lhs (Just bad_e)
+badRuleLhsErr name lhs bad_e
= sep [ptext SLIT("Rule") <+> ftext name <> colon,
nest 4 (vcat [ptext SLIT("Illegal expression:") <+> ppr bad_e,
ptext SLIT("in left-hand side:") <+> ppr lhs])]
$$
ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
-
-badRuleVar name var
- = sep [ptext SLIT("Rule") <+> doubleQuotes (ftext name) <> colon,
- ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
- ptext SLIT("does not appear on left hand side")]
\end{code}