Commit 49861e71 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Reject bad 'deriving' directives (fixes Trac #5287)

The 'deriving' mechanism that infers the context for
an instance declarations was going into a loop, as a
result of an instance like
       instance C a b => D [a]
where the 'b' isn't mentioned in the head.

This patch identifies those cases.  I also needed to make
TcErrors generate a suitable error message.  On the way
I improved the reporting of "ambiguous" variables;
for example arrowfail001 now generates a better message.
parent 725e6ee4
......@@ -1372,21 +1372,7 @@ inferInstanceContexts oflag infer_specs
, ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs })
= setSrcSpan loc $
addErrCtxt (derivInstCtxt the_pred) $
do { -- Check for a bizarre corner case, when the derived instance decl should
-- have form instance C a b => D (T a) where ...
-- Note that 'b' isn't a parameter of T. This gives rise to all sorts
-- of problems; in particular, it's hard to compare solutions for
-- equality when finding the fixpoint. Moreover, simplifyDeriv
-- has an assert failure because it finds a TyVar when it expects
-- only TcTyVars. So I just rule it out for now. I'm not
-- even sure how it can arise.
; let tv_set = mkVarSet tyvars
weird_preds = [pred | pred <- deriv_rhs
, not (tyVarsOfPred pred `subVarSet` tv_set)]
; mapM_ (addErrTc . badDerivedPred) weird_preds
; theta <- simplifyDeriv orig the_pred tyvars deriv_rhs
do { theta <- simplifyDeriv orig the_pred tyvars deriv_rhs
-- checkValidInstance tyvars theta clas inst_tys
-- Not necessary; see Note [Exotic derived instance contexts]
-- in TcSimplify
......@@ -1745,10 +1731,4 @@ standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for"
derivInstCtxt :: PredType -> Message
derivInstCtxt pred
= ptext (sLit "When deriving the instance for") <+> parens (ppr pred)
badDerivedPred :: PredType -> Message
badDerivedPred pred
= vcat [ptext (sLit "Can't derive instances where the instance context mentions"),
ptext (sLit "type variables that are not data type parameters"),
nest 2 (ptext (sLit "Offending constraint:") <+> ppr pred)]
\end{code}
......@@ -123,10 +123,8 @@ reportTidyWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = impli
-- Only report ambiguity if no other errors (at all) happened
-- See Note [Avoiding spurious errors] in TcSimplify
; ifErrsM (return ()) $ reportAmbigErrs ctxt skols ambigs }
; ifErrsM (return ()) $ reportAmbigErrs ctxt ambigs }
where
skols = foldr (unionVarSet . ic_skols) emptyVarSet (cec_encl ctxt)
-- Report equalities of form (a~ty) first. They are usually
-- skolem-equalities, and they cause confusing knock-on
-- effects in other errors; see test T4093b.
......@@ -138,9 +136,9 @@ reportTidyWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = impli
-- (a) it is a class constraint
-- (b) it constrains only type variables
-- (else we'd prefer to report it as "no instance for...")
-- (c) it mentions type variables that are not skolems
-- (c) it mentions a (presumably un-filled-in) meta type variable
is_ambiguous d = isTyVarClassPred pred
&& not (tyVarsOfPred pred `subVarSet` skols)
&& any isAmbiguousTyVar (varSetElems (tyVarsOfPred pred))
where
pred = evVarOfPred d
......@@ -217,13 +215,13 @@ pprWithArising :: [WantedEvVar] -> (WantedLoc, SDoc)
pprWithArising []
= panic "pprWithArising"
pprWithArising [EvVarX ev loc]
= (loc, pprEvVarTheta [ev] <+> pprArising (ctLocOrigin loc))
= (loc, hang (pprEvVarTheta [ev]) 2 (pprArising (ctLocOrigin loc)))
pprWithArising ev_vars
= (first_loc, vcat (map ppr_one ev_vars))
where
first_loc = evVarX (head ev_vars)
ppr_one (EvVarX v loc)
= parens (pprPredTy (evVarPred v)) <+> pprArisingAt loc
= hang (parens (pprPredTy (evVarPred v))) 2 (pprArisingAt loc)
addErrorReport :: ReportErrCtxt -> SDoc -> TcM ()
addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt)
......@@ -684,59 +682,58 @@ that match such things. And flattening under a for-all is problematic
anyway; consider C (forall a. F a)
\begin{code}
reportAmbigErrs :: ReportErrCtxt -> TcTyVarSet -> [WantedEvVar] -> TcM ()
reportAmbigErrs ctxt skols ambigs
reportAmbigErrs :: ReportErrCtxt -> [WantedEvVar] -> TcM ()
reportAmbigErrs ctxt ambigs
-- Divide into groups that share a common set of ambiguous tyvars
= mapM_ report (equivClasses cmp ambigs_w_tvs)
where
ambigs_w_tvs = [ (d, varSetElems (tyVarsOfEvVarX d `minusVarSet` skols))
= mapM_ (reportAmbigGroup ctxt) (equivClasses cmp ambigs_w_tvs)
where
ambigs_w_tvs = [ (d, filter isAmbiguousTyVar (varSetElems (tyVarsOfEvVarX d)))
| d <- ambigs ]
cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
report :: [(WantedEvVar, [TcTyVar])] -> TcM ()
report pairs
= setCtLoc loc $
do { let main_msg = sep [ text "Ambiguous type variable" <> plural tvs
<+> pprQuotedList tvs
<+> text "in the constraint" <> plural pairs <> colon
, nest 2 pp_wanteds ]
; (tidy_env, mono_msg) <- mkMonomorphismMsg ctxt tvs
; addErrTcM (tidy_env, main_msg $$ mono_msg) }
where
(_, tvs) : _ = pairs
(loc, pp_wanteds) = pprWithArising (map fst pairs)
mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc)
-- There's an error with these Insts; if they have free type variables
-- it's probably caused by the monomorphism restriction.
-- Try to identify the offending variable
-- ASSUMPTION: the Insts are fully zonked
mkMonomorphismMsg ctxt inst_tvs
= do { dflags <- getDOpts
; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
; return (tidy_env, mk_msg dflags docs) }
reportAmbigGroup :: ReportErrCtxt -> [(WantedEvVar, [TcTyVar])] -> TcM ()
-- The pairs all have the same [TcTyVar]
reportAmbigGroup ctxt pairs
= setCtLoc loc $
do { dflags <- getDOpts
; (tidy_env, docs) <- findGlobals ctxt (mkVarSet tvs)
; addErrTcM (tidy_env, main_msg $$ mk_msg dflags docs) }
where
mk_msg _ _ | any isRuntimeUnkSkol inst_tvs -- See Note [Runtime skolems]
(wev, tvs) : _ = pairs
(loc, pp_wanteds) = pprWithArising (map fst pairs)
main_msg = sep [ text "Ambiguous type variable" <> plural tvs
<+> pprQuotedList tvs
<+> text "in the constraint" <> plural pairs <> colon
, nest 2 pp_wanteds ]
mk_msg dflags docs
| any isRuntimeUnkSkol tvs -- See Note [Runtime skolems]
= vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
(pprWithCommas ppr inst_tvs),
ptext (sLit "Use :print or :force to determine these types")]
mk_msg _ [] = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)")
(pprWithCommas ppr tvs),
ptext (sLit "Use :print or :force to determine these types")]
| DerivOrigin <- ctLocOrigin (evVarX wev)
= ptext (sLit "Probable fix: use a 'standalone deriving' declaration instead")
| null docs
= ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)")
-- This happens in things like
-- f x = show (read "foo")
-- where monomorphism doesn't play any role
mk_msg dflags docs
| otherwise
= vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"),
nest 2 (vcat docs),
monomorphism_fix dflags]
monomorphism_fix :: DynFlags -> SDoc
monomorphism_fix dflags
= ptext (sLit "Probable fix:") <+> vcat
[ptext (sLit "give these definition(s) an explicit type signature"),
if xopt Opt_MonomorphismRestriction dflags
then ptext (sLit "or use -XNoMonomorphismRestriction")
else empty] -- Only suggest adding "-XNoMonomorphismRestriction"
-- if it is not already set!
mono_fix dflags]
mono_fix :: DynFlags -> SDoc
mono_fix dflags
= ptext (sLit "Probable fix:") <+> vcat
[ptext (sLit "give these definition(s) an explicit type signature"),
if xopt Opt_MonomorphismRestriction dflags
then ptext (sLit "or use -XNoMonomorphismRestriction")
else empty] -- Only suggest adding "-XNoMonomorphismRestriction"
-- if it is not already set!
getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo
getSkolemInfo [] tv
......
......@@ -42,10 +42,10 @@ module TcMType (
-- Checking type validity
Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType,
SourceTyCtxt(..), checkValidTheta,
checkValidInstHead, checkValidInstance,
checkValidInstHead, checkValidInstance, validDerivPred,
checkInstTermination, checkValidTypeInst, checkTyFamFreeness,
arityErr,
growPredTyVars, growThetaTyVars, validDerivPred,
growPredTyVars, growThetaTyVars,
--------------------------------
-- Zonking
......@@ -1385,6 +1385,29 @@ instTypeErr pp_ty msg
nest 2 msg]
\end{code}
validDeivPred checks for OK 'deriving' context. See Note [Exotic
derived instance contexts] in TcSimplify. However the predicate is
here because it uses sizeTypes, fvTypes.
Also check for a bizarre corner case, when the derived instance decl
would look like
instance C a b => D (T a) where ...
Note that 'b' isn't a parameter of T. This gives rise to all sorts of
problems; in particular, it's hard to compare solutions for equality
when finding the fixpoint, and that means the inferContext loop does
not converge. See Trac #5287.
\begin{code}
validDerivPred :: TyVarSet -> PredType -> Bool
validDerivPred tv_set (ClassP _ tys)
= hasNoDups fvs
&& sizeTypes tys == length fvs
&& all (`elemVarSet` tv_set) fvs
where
fvs = fvTypes tys
validDerivPred _ _ = False
\end{code}
%************************************************************************
%* *
......@@ -1464,17 +1487,6 @@ smallerMsg = ptext (sLit "Constraint is no smaller than the instance head")
undecidableMsg = ptext (sLit "Use -XUndecidableInstances to permit this")
\end{code}
validDeivPred checks for OK 'deriving' context. See Note [Exotic
derived instance contexts] in TcSimplify. However the predicate is
here because it uses sizeTypes, fvTypes.
\begin{code}
validDerivPred :: PredType -> Bool
validDerivPred (ClassP _ tys) = hasNoDups fvs && sizeTypes tys == length fvs
where fvs = fvTypes tys
validDerivPred _ = False
\end{code}
%************************************************************************
%* *
......
......@@ -94,6 +94,7 @@ simplifyDeriv orig pred tvs theta
; let skol_subst = zipTopTvSubst tvs $ map mkTyVarTy tvs_skols
subst_skol = zipTopTvSubst tvs_skols $ map mkTyVarTy tvs
skol_set = mkVarSet tvs_skols
doc = parens $ ptext (sLit "deriving") <+> parens (ppr pred)
; wanted <- newFlatWanteds orig (substTheta skol_subst theta)
......@@ -106,8 +107,8 @@ simplifyDeriv orig pred tvs theta
; let (good, bad) = partitionBagWith get_good (wc_flat residual_wanted)
-- See Note [Exotic derived instance contexts]
get_good :: WantedEvVar -> Either PredType WantedEvVar
get_good wev | validDerivPred p = Left p
| otherwise = Right wev
get_good wev | validDerivPred skol_set p = Left p
| otherwise = Right wev
where p = evVarOfPred wev
; reportUnsolved (residual_wanted { wc_flat = bad })
......
......@@ -28,7 +28,7 @@ module TcType (
MetaDetails(Flexi, Indirect), MetaInfo(..),
isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isMetaTyVarTy,
isSigTyVar, isOverlappableTyVar, isTyConableTyVar,
metaTvRef,
isAmbiguousTyVar, metaTvRef,
isFlexi, isIndirect, isRuntimeUnkSkol,
--------------------------------
......@@ -573,7 +573,7 @@ isImmutableTyVar tv
| otherwise = True
isTyConableTyVar, isSkolemTyVar, isOverlappableTyVar,
isMetaTyVar :: TcTyVar -> Bool
isMetaTyVar, isAmbiguousTyVar :: TcTyVar -> Bool
isTyConableTyVar tv
-- True of a meta-type variable that can be filled in
......@@ -601,8 +601,20 @@ isOverlappableTyVar tv
isMetaTyVar tv
= ASSERT2( isTcTyVar tv, ppr tv )
case tcTyVarDetails tv of
MetaTv _ _ -> True
_ -> False
MetaTv {} -> True
_ -> False
-- isAmbiguousTyVar is used only when reporting type errors
-- It picks out variables that are unbound, namely meta
-- type variables and the RuntimUnk variables created by
-- RtClosureInspect.zonkRTTIType. These are "ambiguous" in
-- the sense that they stand for an as-yet-unknown type
isAmbiguousTyVar tv
= ASSERT2( isTcTyVar tv, ppr tv )
case tcTyVarDetails tv of
MetaTv {} -> True
RuntimeUnk {} -> True
_ -> False
isMetaTyVarTy :: TcType -> Bool
isMetaTyVarTy (TyVarTy tv) = isMetaTyVar tv
......
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