From: simonpj Date: Tue, 17 Sep 2002 10:08:51 +0000 (+0000) Subject: [project @ 2002-09-17 10:08:48 by simonpj] X-Git-Tag: Approx_11550_changesets_converted~1667 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=67419f264a735dfd95001d0d8aedb28d01cdb18a;p=ghc-hetmet.git [project @ 2002-09-17 10:08:48 by simonpj] Unbork head...ruleLhsTvs does not crash now --- diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index e67b4ad..d90f63a 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -57,8 +57,8 @@ import Outputable import SrcLoc ( SrcLoc ) import CmdLineOpts ( DynFlag(..) ) -- Warn of unused for-all'd tyvars -import Maybes ( maybeToBool ) -import Maybe ( maybe, catMaybes ) +import Maybes ( maybeToBool, seqMaybe ) +import Maybe ( maybe, catMaybes, isNothing ) \end{code} @rnSourceDecl@ `renames' declarations. @@ -394,8 +394,11 @@ rnHsRuleDecl (HsRule rule_name act vars lhs rhs src_loc) rnExpr lhs `thenM` \ (lhs', fv_lhs) -> rnExpr rhs `thenM` \ (rhs', fv_rhs) -> - checkErr (validRuleLhs ids lhs') - (badRuleLhsErr rule_name lhs') `thenM_` + 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 @@ -415,18 +418,37 @@ rnHsRuleDecl (HsRule rule_name act vars lhs rhs src_loc) 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. +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.) NB: if you add new cases here, make sure you add new ones to TcRule.ruleLhsTvs \begin{code} +validRuleLhs :: [Name] -> RenamedHsExpr -> Maybe RenamedHsExpr +-- Nothing => OK +-- Just e => Not ok, and e is the offending expression validRuleLhs foralls lhs = check lhs where - check (OpApp _ op _ _) = check op - check (HsApp e1 e2) = check e1 - check (HsVar v) | v `notElem` foralls = True - check other = False + check (OpApp e1 op _ e2) = check op `seqMaybe` check_e e1 `seqMaybe` check_e e2 + check (HsApp e1 e2) = check e1 `seqMaybe` check_e e2 + check (HsVar v) | v `notElem` foralls = Nothing + check other = Just other -- Failure + + check_e (HsVar v) = Nothing + check_e (HsPar e) = check_e e + check_e (HsLit e) = Nothing + check_e (HsOverLit e) = Nothing + + check_e (OpApp e1 op _ e2) = check_e e1 `seqMaybe` check_e op `seqMaybe` check_e e2 + check_e (HsApp e1 e2) = check_e e1 `seqMaybe` check_e e2 + check_e (NegApp e _) = check_e e + check_e (ExplicitList _ es) = check_es es + check_e (ExplicitTuple es _) = check_es es + check_e other = Just other -- Fails + + check_es es = foldr (seqMaybe . check_e) Nothing es \end{code} @@ -912,9 +934,10 @@ getRnStats eps imported_decls badDataCon name = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)] -badRuleLhsErr name lhs +badRuleLhsErr name lhs (Just bad_e) = sep [ptext SLIT("Rule") <+> ftext name <> colon, - nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)] + 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") diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs index 6f9890b..766266d 100644 --- a/ghc/compiler/typecheck/TcRules.lhs +++ b/ghc/compiler/typecheck/TcRules.lhs @@ -15,7 +15,7 @@ import TcHsSyn ( TypecheckedRuleDecl, TcExpr, mkHsLet ) import TcRnMonad import TcSimplify ( tcSimplifyToDicts, tcSimplifyInferCheck ) import TcMType ( newTyVarTy ) -import TcType ( TcTyVarSet, tyVarsOfTypes, openTypeKind ) +import TcType ( TcTyVarSet, tyVarsOfTypes, tyVarsOfType, openTypeKind ) import TcIfaceSig ( tcCoreExpr, tcCoreLamBndrs, tcVar ) import TcMonoType ( tcHsSigType, UserTypeCtxt(..), tcAddScopedTyVars ) import TcExpr ( tcMonoExpr ) @@ -132,15 +132,29 @@ ruleLhsTvs :: TcExpr -> TcTyVarSet -- Fortunately the form of the LHS is pretty limited (see RnSource.validRuleLhs) -- so we don't need to deal with the whole of HsSyn. -- -ruleLhsTvs (OpApp e1 op _ e2) - = ruleLhsTvs e1 `unionVarSet` ruleLhsTvs op `unionVarSet` ruleLhsTvs e2 -ruleLhsTvs (HsApp e1 e2) - = ruleLhsTvs e1 `unionVarSet` ruleLhsTvs e2 -ruleLhsTvs (HsVar v) = emptyVarSet -- I don't think we need the tyvars of the Id -ruleLhsTvs (TyApp e1 tys) - = ruleLhsTvs e1 `unionVarSet` tyVarsOfTypes tys +-- Uh oh! validRuleLhs only checks the function part of rule LHSs! + +ruleLhsTvs (HsPar e) = ruleLhsTvs e +ruleLhsTvs (HsLit e) = emptyVarSet +ruleLhsTvs (HsOverLit e) = emptyVarSet +ruleLhsTvs (HsVar v) = emptyVarSet -- I don't think we need the tyvars of the Id + +ruleLhsTvs (OpApp e1 op _ e2) = ruleLhsTvs e1 `unionVarSet` ruleLhsTvs op + `unionVarSet` ruleLhsTvs e2 +ruleLhsTvs (HsApp e1 e2) = ruleLhsTvs e1 `unionVarSet` ruleLhsTvs e2 +ruleLhsTvs (TyApp e1 tys) = ruleLhsTvs e1 `unionVarSet` tyVarsOfTypes tys +ruleLhsTvs (DictApp e ds) = ruleLhsTvs e +ruleLhsTvs (NegApp e _) = ruleLhsTvs e +ruleLhsTvs (ExplicitList ty es) = tyVarsOfType ty `unionVarSet` ruleLhsTvs_s es +ruleLhsTvs (ExplicitTuple es _) = ruleLhsTvs_s es + +-- Type abstractions can occur in rules like +-- "foldr k z (build g) = g k z" +ruleLhsTvs (TyLam tvs e) = ruleLhsTvs e `delVarSetList` tvs +ruleLhsTvs (DictLam ids e) = ruleLhsTvs e ruleLhsTvs e = pprPanic "ruleLhsTvs" (ppr e) +ruleLhsTvs_s es = foldr (unionVarSet . ruleLhsTvs) emptyVarSet es ruleCtxt name = ptext SLIT("When checking the transformation rule") <+> doubleQuotes (ftext name)