11 #include "HsVersions.h"
18 import Type( isTyVarTy )
19 import Unify ( tcMatchTys )
25 import Id ( idType, evVarPred )
31 import ListSetOps( equivClasses )
36 import StaticFlags( opt_PprStyle_Debug )
37 import Data.List( partition )
38 import Control.Monad( when, unless )
41 %************************************************************************
43 \section{Errors and contexts}
45 %************************************************************************
47 ToDo: for these error messages, should we note the location as coming
48 from the insts, or just whatever seems to be around in the monad just
52 reportUnsolved :: WantedConstraints -> TcM ()
57 = do { -- Zonk to un-flatten any flatten-skols
58 ; wanted <- zonkWC wanted
60 ; env0 <- tcInitTidyEnv
61 ; let tidy_env = tidyFreeTyVars env0 free_tvs
62 free_tvs = tyVarsOfWC wanted
63 err_ctxt = CEC { cec_encl = []
64 , cec_insol = insolubleWC wanted
66 , cec_tidy = tidy_env }
67 tidy_wanted = tidyWC tidy_env wanted
69 ; traceTc "reportUnsolved" (ppr tidy_wanted)
71 ; reportTidyWanteds err_ctxt tidy_wanted }
73 --------------------------------------------
75 --------------------------------------------
78 = CEC { cec_encl :: [Implication] -- Enclosing implications
81 , cec_extra :: SDoc -- Add this to each error message
82 , cec_insol :: Bool -- True <=> we are reporting insoluble errors only
83 -- Main effect: don't say "Cannot deduce..."
84 -- when reporting equality errors; see misMatchOrCND
87 reportTidyImplic :: ReportErrCtxt -> Implication -> TcM ()
88 reportTidyImplic ctxt implic
89 | BracketSkol <- ctLocOrigin (ic_loc implic)
90 , not insoluble -- For Template Haskell brackets report only
91 = return () -- definite errors. The whole thing will be re-checked
92 -- later when we plug it in, and meanwhile there may
93 -- certainly be un-satisfied constraints
96 = reportTidyWanteds ctxt' (ic_wanted implic)
98 insoluble = ic_insol implic
99 ctxt' = ctxt { cec_encl = implic : cec_encl ctxt
100 , cec_insol = insoluble }
102 reportTidyWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
103 reportTidyWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = implics })
104 | cec_insol ctxt -- If there are any insolubles, report only them
105 -- because they are unconditionally wrong
106 -- Moreover, if any of the insolubles are givens, stop right there
107 -- ignoring nested errors, because the code is inaccessible
108 = do { let (given, other) = partitionBag (isGivenOrSolved . evVarX) insols
109 insol_implics = filterBag ic_insol implics
110 ; if isEmptyBag given
111 then do { mapBagM_ (reportInsoluble ctxt) other
112 ; mapBagM_ (reportTidyImplic ctxt) insol_implics }
113 else mapBagM_ (reportInsoluble ctxt) given }
115 | otherwise -- No insoluble ones
116 = ASSERT( isEmptyBag insols )
117 do { let (ambigs, non_ambigs) = partition is_ambiguous (bagToList flats)
118 (tv_eqs, others) = partition is_tv_eq non_ambigs
120 ; groupErrs (reportEqErrs ctxt) tv_eqs
121 ; when (null tv_eqs) $ groupErrs (reportFlat ctxt) others
122 ; mapBagM_ (reportTidyImplic ctxt) implics
124 -- Only report ambiguity if no other errors (at all) happened
125 -- See Note [Avoiding spurious errors] in TcSimplify
126 ; ifErrsM (return ()) $ reportAmbigErrs ctxt skols ambigs }
128 skols = foldr (unionVarSet . ic_skols) emptyVarSet (cec_encl ctxt)
130 -- Report equalities of form (a~ty) first. They are usually
131 -- skolem-equalities, and they cause confusing knock-on
132 -- effects in other errors; see test T4093b.
133 is_tv_eq c | EqPred ty1 ty2 <- evVarOfPred c
134 = tcIsTyVarTy ty1 || tcIsTyVarTy ty2
137 -- Treat it as "ambiguous" if
138 -- (a) it is a class constraint
139 -- (b) it constrains only type variables
140 -- (else we'd prefer to report it as "no instance for...")
141 -- (c) it mentions type variables that are not skolems
142 is_ambiguous d = isTyVarClassPred pred
143 && not (tyVarsOfPred pred `subVarSet` skols)
147 reportInsoluble :: ReportErrCtxt -> FlavoredEvVar -> TcM ()
148 reportInsoluble ctxt (EvVarX ev flav)
149 | EqPred ty1 ty2 <- evVarPred ev
150 = setCtFlavorLoc flav $
151 do { let ctxt2 = ctxt { cec_extra = cec_extra ctxt $$ inaccessible_msg }
152 ; reportEqErr ctxt2 ty1 ty2 }
154 = pprPanic "reportInsoluble" (pprEvVarWithType ev)
156 inaccessible_msg | Given loc GivenOrig <- flav
157 -- If a GivenSolved then we should not report inaccessible code
158 = hang (ptext (sLit "Inaccessible code in"))
159 2 (ppr (ctLocOrigin loc))
162 reportFlat :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
163 -- The [PredType] are already tidied
164 reportFlat ctxt flats origin
165 = do { unless (null dicts) $ reportDictErrs ctxt dicts origin
166 ; unless (null eqs) $ reportEqErrs ctxt eqs origin
167 ; unless (null ips) $ reportIPErrs ctxt ips origin
168 ; ASSERT( null others ) return () }
170 (dicts, non_dicts) = partition isClassPred flats
171 (eqs, non_eqs) = partition isEqPred non_dicts
172 (ips, others) = partition isIPPred non_eqs
174 --------------------------------------------
176 --------------------------------------------
178 groupErrs :: ([PredType] -> CtOrigin -> TcM ()) -- Deal with one group
179 -> [WantedEvVar] -- Unsolved wanteds
181 -- Group together insts with the same origin
182 -- We want to report them together in error messages
186 groupErrs report_err (wanted : wanteds)
187 = do { setCtLoc the_loc $
188 report_err the_vars (ctLocOrigin the_loc)
189 ; groupErrs report_err others }
191 the_loc = evVarX wanted
192 the_key = mk_key the_loc
193 the_vars = map evVarOfPred (wanted:friends)
194 (friends, others) = partition is_friend wanteds
195 is_friend friend = mk_key (evVarX friend) `same_key` the_key
197 mk_key :: WantedLoc -> (SrcSpan, CtOrigin)
198 mk_key loc = (ctLocSpan loc, ctLocOrigin loc)
200 same_key (s1, o1) (s2, o2) = s1==s2 && o1 `same_orig` o2
201 same_orig (OccurrenceOf n1) (OccurrenceOf n2) = n1==n2
202 same_orig ScOrigin ScOrigin = True
203 same_orig DerivOrigin DerivOrigin = True
204 same_orig DefaultOrigin DefaultOrigin = True
205 same_orig _ _ = False
208 -- Add the "arising from..." part to a message about bunch of dicts
209 addArising :: CtOrigin -> SDoc -> SDoc
210 addArising orig msg = msg $$ nest 2 (pprArising orig)
212 pprWithArising :: [WantedEvVar] -> (WantedLoc, SDoc)
213 -- Print something like
214 -- (Eq a) arising from a use of x at y
215 -- (Show a) arising from a use of p at q
216 -- Also return a location for the error message
218 = panic "pprWithArising"
219 pprWithArising [EvVarX ev loc]
220 = (loc, pprEvVarTheta [ev] <+> pprArising (ctLocOrigin loc))
221 pprWithArising ev_vars
222 = (first_loc, vcat (map ppr_one ev_vars))
224 first_loc = evVarX (head ev_vars)
225 ppr_one (EvVarX v loc)
226 = parens (pprPredTy (evVarPred v)) <+> pprArisingAt loc
228 addErrorReport :: ReportErrCtxt -> SDoc -> TcM ()
229 addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt)
231 pprErrCtxtLoc :: ReportErrCtxt -> SDoc
233 = case map (ctLocOrigin . ic_loc) (cec_encl ctxt) of
234 [] -> ptext (sLit "the top level") -- Should not happen
235 (orig:origs) -> ppr_skol orig $$
236 vcat [ ptext (sLit "or") <+> ppr_skol orig | orig <- origs ]
238 ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc)
239 ppr_skol skol_info = ppr skol_info
241 getUserGivens :: ReportErrCtxt -> [([EvVar], GivenLoc)]
242 -- One item for each enclosing implication
243 getUserGivens (CEC {cec_encl = ctxt})
245 [ (givens', loc) | Implic {ic_given = givens, ic_loc = loc} <- ctxt
246 , let givens' = get_user_givens givens
247 , not (null givens') ]
249 get_user_givens givens | opt_PprStyle_Debug = givens
250 | otherwise = filterOut isSilentEvVar givens
251 -- In user mode, don't show the "silent" givens, used for
252 -- the "self" dictionary and silent superclass arguments for dfuns
257 %************************************************************************
259 Implicit parameter errors
261 %************************************************************************
264 reportIPErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
265 reportIPErrs ctxt ips orig
266 = addErrorReport ctxt msg
268 givens = getUserGivens ctxt
271 sep [ ptext (sLit "Unbound implicit parameter") <> plural ips
272 , nest 2 (pprTheta ips) ]
274 = couldNotDeduce givens (ips, orig)
278 %************************************************************************
282 %************************************************************************
285 reportEqErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
286 -- The [PredType] are already tidied
287 reportEqErrs ctxt eqs orig
288 = do { orig' <- zonkTidyOrigin ctxt orig
289 ; mapM_ (report_one orig') eqs }
291 report_one orig (EqPred ty1 ty2)
292 = do { let extra = getWantedEqExtra orig ty1 ty2
293 ctxt' = ctxt { cec_extra = extra $$ cec_extra ctxt }
294 ; reportEqErr ctxt' ty1 ty2 }
296 = pprPanic "reportEqErrs" (ppr pred)
298 getWantedEqExtra :: CtOrigin -> TcType -> TcType -> SDoc
299 getWantedEqExtra (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp }))
301 -- If the types in the error message are the same as the types we are unifying,
302 -- don't add the extra expected/actual message
303 | act `eqType` ty1 && exp `eqType` ty2 = empty
304 | exp `eqType` ty1 && act `eqType` ty2 = empty
305 | otherwise = mkExpectedActualMsg act exp
307 getWantedEqExtra orig _ _ = pprArising orig
309 reportEqErr :: ReportErrCtxt -> TcType -> TcType -> TcM ()
310 -- ty1 and ty2 are already tidied
311 reportEqErr ctxt ty1 ty2
312 | Just tv1 <- tcGetTyVar_maybe ty1 = reportTyVarEqErr ctxt tv1 ty2
313 | Just tv2 <- tcGetTyVar_maybe ty2 = reportTyVarEqErr ctxt tv2 ty1
315 | otherwise -- Neither side is a type variable
316 -- Since the unsolved constraint is canonical,
317 -- it must therefore be of form (F tys ~ ty)
318 = addErrorReport ctxt (misMatchOrCND ctxt ty1 ty2 $$ mkTyFunInfoMsg ty1 ty2)
321 reportTyVarEqErr :: ReportErrCtxt -> TcTyVar -> TcType -> TcM ()
322 -- tv1 and ty2 are already tidied
323 reportTyVarEqErr ctxt tv1 ty2
324 | isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar, or else the thing would
325 -- be oriented the other way round; see TcCanonical.reOrient
326 || isSigTyVar tv1 && not (isTyVarTy ty2)
327 = addErrorReport (addExtraInfo ctxt ty1 ty2)
328 (misMatchOrCND ctxt ty1 ty2)
330 -- So tv is a meta tyvar, and presumably it is
331 -- an *untouchable* meta tyvar, else it'd have been unified
332 | not (k2 `isSubKind` k1) -- Kind error
333 = addErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2)
336 | tv1 `elemVarSet` tyVarsOfType ty2
337 = let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:") 2
338 (sep [ppr ty1, char '=', ppr ty2])
339 in addErrorReport ctxt occCheckMsg
341 -- Check for skolem escape
342 | (implic:_) <- cec_encl ctxt -- Get the innermost context
343 , let esc_skols = varSetElems (tyVarsOfType ty2 `intersectVarSet` ic_skols implic)
344 implic_loc = ic_loc implic
345 , not (null esc_skols)
346 = setCtLoc implic_loc $ -- Override the error message location from the
347 -- place the equality arose to the implication site
348 do { (env1, env_sigs) <- findGlobals ctxt (unitVarSet tv1)
349 ; let msg = misMatchMsg ty1 ty2
350 esc_doc = sep [ ptext (sLit "because type variable") <> plural esc_skols
351 <+> pprQuotedList esc_skols
352 , ptext (sLit "would escape") <+>
353 if isSingleton esc_skols then ptext (sLit "its scope")
354 else ptext (sLit "their scope") ]
355 extra1 = vcat [ nest 2 $ esc_doc
356 , sep [ (if isSingleton esc_skols
357 then ptext (sLit "This (rigid, skolem) type variable is")
358 else ptext (sLit "These (rigid, skolem) type variables are"))
359 <+> ptext (sLit "bound by")
360 , nest 2 $ ppr (ctLocOrigin implic_loc) ] ]
361 ; addErrTcM (env1, msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) }
363 -- Nastiest case: attempt to unify an untouchable variable
364 | (implic:_) <- cec_encl ctxt -- Get the innermost context
365 , let implic_loc = ic_loc implic
366 given = ic_given implic
367 = setCtLoc (ic_loc implic) $
368 do { let msg = misMatchMsg ty1 ty2
369 extra = quotes (ppr tv1)
370 <+> sep [ ptext (sLit "is untouchable")
371 , ptext (sLit "inside the constraints") <+> pprEvVarTheta given
372 , ptext (sLit "bound at") <+> ppr (ctLocOrigin implic_loc)]
373 ; addErrorReport (addExtraInfo ctxt ty1 ty2) (msg $$ nest 2 extra) }
376 = pprTrace "reportTyVarEqErr" (ppr tv1 $$ ppr ty2 $$ ppr (cec_encl ctxt)) $
378 -- I don't think this should happen, and if it does I want to know
379 -- Trac #5130 happened because an actual type error was not
380 -- reported at all! So not reporting is pretty dangerous.
382 -- OLD, OUT OF DATE COMMENT
383 -- This can happen, by a recursive decomposition of frozen
384 -- occurs check constraints
385 -- Example: alpha ~ T Int alpha has frozen.
386 -- Then alpha gets unified to T beta gamma
387 -- So now we have T beta gamma ~ T Int (T beta gamma)
388 -- Decompose to (beta ~ Int, gamma ~ T beta gamma)
389 -- The (gamma ~ T beta gamma) is the occurs check, but
390 -- the (beta ~ Int) isn't an error at all. So return ()
396 mkTyFunInfoMsg :: TcType -> TcType -> SDoc
397 -- See Note [Non-injective type functions]
398 mkTyFunInfoMsg ty1 ty2
399 | Just (tc1,_) <- tcSplitTyConApp_maybe ty1
400 , Just (tc2,_) <- tcSplitTyConApp_maybe ty2
401 , tc1 == tc2, isSynFamilyTyCon tc1
402 = ptext (sLit "NB:") <+> quotes (ppr tc1)
403 <+> ptext (sLit "is a type function") <> (pp_inj tc1)
406 pp_inj tc | isInjectiveTyCon tc = empty
407 | otherwise = ptext (sLit (", and may not be injective"))
409 misMatchOrCND :: ReportErrCtxt -> TcType -> TcType -> SDoc
410 misMatchOrCND ctxt ty1 ty2
411 | cec_insol ctxt = misMatchMsg ty1 ty2 -- If the equality is unconditionally
412 -- insoluble, don't report the context
413 | null givens = misMatchMsg ty1 ty2
414 | otherwise = couldNotDeduce givens ([EqPred ty1 ty2], orig)
416 givens = getUserGivens ctxt
417 orig = TypeEqOrigin (UnifyOrigin ty1 ty2)
419 couldNotDeduce :: [([EvVar], GivenLoc)] -> (ThetaType, CtOrigin) -> SDoc
420 couldNotDeduce givens (wanteds, orig)
421 = vcat [ hang (ptext (sLit "Could not deduce") <+> pprTheta wanteds)
423 , vcat (pp_givens givens)]
425 pp_givens :: [([EvVar], GivenLoc)] -> [SDoc]
429 (g:gs) -> ppr_given (ptext (sLit "from the context")) g
430 : map (ppr_given (ptext (sLit "or from"))) gs
431 where ppr_given herald (gs,loc)
432 = hang (herald <+> pprEvVarTheta gs)
433 2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin loc)
434 , ptext (sLit "at") <+> ppr (ctLocSpan loc)])
436 addExtraInfo :: ReportErrCtxt -> TcType -> TcType -> ReportErrCtxt
437 -- Add on extra info about the types themselves
438 -- NB: The types themselves are already tidied
439 addExtraInfo ctxt ty1 ty2
440 = ctxt { cec_extra = nest 2 (extra1 $$ extra2) $$ cec_extra ctxt }
442 extra1 = typeExtraInfoMsg (cec_encl ctxt) ty1
443 extra2 = typeExtraInfoMsg (cec_encl ctxt) ty2
445 misMatchMsg :: TcType -> TcType -> SDoc -- Types are already tidy
446 misMatchMsg ty1 ty2 = sep [ ptext (sLit "Couldn't match type") <+> quotes (ppr ty1)
447 , nest 15 $ ptext (sLit "with") <+> quotes (ppr ty2)]
449 kindErrorMsg :: TcType -> TcType -> SDoc -- Types are already tidy
451 = vcat [ ptext (sLit "Kind incompatibility when matching types:")
452 , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1
453 , ppr ty2 <+> dcolon <+> ppr k2 ]) ]
458 typeExtraInfoMsg :: [Implication] -> Type -> SDoc
459 -- Shows a bit of extra info about skolem constants
460 typeExtraInfoMsg implics ty
461 | Just tv <- tcGetTyVar_maybe ty
462 , isTcTyVar tv, isSkolemTyVar tv
463 , let pp_tv = quotes (ppr tv)
464 = case tcTyVarDetails tv of
465 SkolemTv {} -> pp_tv <+> ppr_skol (getSkolemInfo implics tv) (getSrcLoc tv)
466 FlatSkol {} -> pp_tv <+> ptext (sLit "is a flattening type variable")
467 RuntimeUnk {} -> pp_tv <+> ptext (sLit "is an interactive-debugger skolem")
470 | otherwise -- Normal case
474 ppr_skol UnkSkol _ = ptext (sLit "is an unknown type variable") -- Unhelpful
475 ppr_skol info loc = sep [ptext (sLit "is a rigid type variable bound by"),
476 sep [ppr info, ptext (sLit "at") <+> ppr loc]]
479 unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc)
480 unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env
481 = do { (env1, act_ty') <- zonkTidyTcType tidy_env act_ty
482 ; (env2, exp_ty') <- zonkTidyTcType env1 exp_ty
483 ; return (env2, mkExpectedActualMsg act_ty' exp_ty') }
485 mkExpectedActualMsg :: Type -> Type -> SDoc
486 mkExpectedActualMsg act_ty exp_ty
487 = vcat [ text "Expected type" <> colon <+> ppr exp_ty
488 , text " Actual type" <> colon <+> ppr act_ty ]
491 Note [Non-injective type functions]
492 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
493 It's very confusing to get a message like
494 Couldn't match expected type `Depend s'
495 against inferred type `Depend s1'
496 so mkTyFunInfoMsg adds:
497 NB: `Depend' is type function, and hence may not be injective
499 Warn of loopy local equalities that were dropped.
502 %************************************************************************
506 %************************************************************************
509 reportDictErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
510 reportDictErrs ctxt wanteds orig
511 = do { inst_envs <- tcGetInstEnvs
512 ; non_overlaps <- mapMaybeM (reportOverlap ctxt inst_envs orig) wanteds
513 ; unless (null non_overlaps) $
514 addErrorReport ctxt (mk_no_inst_err non_overlaps) }
516 mk_no_inst_err :: [PredType] -> SDoc
517 mk_no_inst_err wanteds
518 | null givens -- Top level
519 = vcat [ addArising orig $
520 ptext (sLit "No instance") <> plural min_wanteds
521 <+> ptext (sLit "for") <+> pprTheta min_wanteds
522 , show_fixes (fixes2 ++ fixes3) ]
525 = vcat [ couldNotDeduce givens (min_wanteds, orig)
526 , show_fixes (fix1 : (fixes2 ++ fixes3)) ]
528 givens = getUserGivens ctxt
529 min_wanteds = mkMinimalBySCs wanteds
530 fix1 = sep [ ptext (sLit "add") <+> pprTheta min_wanteds
531 <+> ptext (sLit "to the context of")
532 , nest 2 $ pprErrCtxtLoc ctxt ]
534 fixes2 = case instance_dicts of
536 [_] -> [sep [ptext (sLit "add an instance declaration for"),
537 pprTheta instance_dicts]]
538 _ -> [sep [ptext (sLit "add instance declarations for"),
539 pprTheta instance_dicts]]
540 fixes3 = case orig of
541 DerivOrigin -> [drv_fix]
544 instance_dicts = filterOut isTyVarClassPred min_wanteds
545 -- Insts for which it is worth suggesting an adding an
546 -- instance declaration. Exclude tyvar dicts.
548 drv_fix = vcat [ptext (sLit "use a standalone 'deriving instance' declaration,"),
549 nest 2 $ ptext (sLit "so you can specify the instance context yourself")]
551 show_fixes :: [SDoc] -> SDoc
552 show_fixes [] = empty
553 show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"),
554 nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
556 reportOverlap :: ReportErrCtxt -> (InstEnv,InstEnv) -> CtOrigin
557 -> PredType -> TcM (Maybe PredType)
558 -- Report an overlap error if this class constraint results
559 -- from an overlap (returning Nothing), otherwise return (Just pred)
560 reportOverlap ctxt inst_envs orig pred@(ClassP clas tys)
561 = do { tys_flat <- mapM quickFlattenTy tys
562 -- Note [Flattening in error message generation]
564 ; case lookupInstEnv inst_envs clas tys_flat of
565 ([], _) -> return (Just pred) -- No match
566 -- The case of exactly one match and no unifiers means a
567 -- successful lookup. That can't happen here, because dicts
568 -- only end up here if they didn't match in Inst.lookupInst
570 | debugIsOn -> pprPanic "check_overlap" (ppr pred)
571 res -> do { addErrorReport ctxt (mk_overlap_msg res)
574 mk_overlap_msg (matches, unifiers)
575 = ASSERT( not (null matches) )
576 vcat [ addArising orig (ptext (sLit "Overlapping instances for")
578 , sep [ptext (sLit "Matching instances") <> colon,
579 nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
581 , if not (null overlapping_givens) then
582 sep [ptext (sLit "Matching givens (or their superclasses)") <> colon, nest 2 (vcat overlapping_givens)]
585 , if null overlapping_givens && isSingleton matches && null unifiers then
586 -- Intuitively, some given matched the wanted in their flattened or rewritten (from given equalities)
587 -- form but the matcher can't figure that out because the constraints are non-flat and non-rewritten
588 -- so we simply report back the whole given context. Accelerate Smart.hs showed this problem.
589 sep [ptext (sLit "There exists a (perhaps superclass) match") <> colon, nest 2 (vcat (pp_givens givens))]
592 , if not (isSingleton matches)
593 then -- Two or more matches
595 else -- One match, plus some unifiers
596 ASSERT( not (null unifiers) )
597 parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
598 quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
599 if null (overlapping_givens) then
600 vcat [ ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
601 ptext (sLit "when compiling the other instance declarations")]
604 ispecs = [ispec | (ispec, _) <- matches]
606 givens = getUserGivens ctxt
607 overlapping_givens = unifiable_givens givens
609 unifiable_givens [] = []
610 unifiable_givens (gg:ggs)
611 | Just ggdoc <- matchable gg
612 = ggdoc : unifiable_givens ggs
614 = unifiable_givens ggs
616 matchable (evvars,gloc)
617 = case ev_vars_matching of
619 _ -> Just $ hang (pprTheta ev_vars_matching)
620 2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin gloc)
621 , ptext (sLit "at") <+> ppr (ctLocSpan gloc)])
622 where ev_vars_matching = filter ev_var_matches (map evVarPred evvars)
623 ev_var_matches (ClassP clas' tys')
625 , Just _ <- tcMatchTys (tyVarsOfTypes tys) tys tys'
627 ev_var_matches (ClassP clas' tys') =
628 any ev_var_matches (immSuperClasses clas' tys')
629 ev_var_matches _ = False
632 reportOverlap _ _ _ _ = panic "reportOverlap" -- Not a ClassP
634 ----------------------
635 quickFlattenTy :: TcType -> TcM TcType
636 -- See Note [Flattening in error message generation]
637 quickFlattenTy ty | Just ty' <- tcView ty = quickFlattenTy ty'
638 quickFlattenTy ty@(TyVarTy {}) = return ty
639 quickFlattenTy ty@(ForAllTy {}) = return ty -- See
640 quickFlattenTy ty@(PredTy {}) = return ty -- Note [Quick-flatten polytypes]
641 -- Don't flatten because of the danger or removing a bound variable
642 quickFlattenTy (AppTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
643 ; fy2 <- quickFlattenTy ty2
644 ; return (AppTy fy1 fy2) }
645 quickFlattenTy (FunTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
646 ; fy2 <- quickFlattenTy ty2
647 ; return (FunTy fy1 fy2) }
648 quickFlattenTy (TyConApp tc tys)
649 | not (isSynFamilyTyCon tc)
650 = do { fys <- mapM quickFlattenTy tys
651 ; return (TyConApp tc fys) }
653 = do { let (funtys,resttys) = splitAt (tyConArity tc) tys
654 -- Ignore the arguments of the type family funtys
655 ; v <- newMetaTyVar TauTv (typeKind (TyConApp tc funtys))
656 ; flat_resttys <- mapM quickFlattenTy resttys
657 ; return (foldl AppTy (mkTyVarTy v) flat_resttys) }
660 Note [Flattening in error message generation]
661 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
662 Consider (C (Maybe (F x))), where F is a type function, and we have
664 C (Maybe Int) and C (Maybe a)
665 Since (F x) might turn into Int, this is an overlap situation, and
666 indeed (because of flattening) the main solver will have refrained
667 from solving. But by the time we get to error message generation, we've
668 un-flattened the constraint. So we must *re*-flatten it before looking
669 up in the instance environment, lest we only report one matching
670 instance when in fact there are two.
672 Re-flattening is pretty easy, because we don't need to keep track of
673 evidence. We don't re-use the code in TcCanonical because that's in
674 the TcS monad, and we are in TcM here.
676 Note [Quick-flatten polytypes]
677 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
678 If we see C (Ix a => blah) or C (forall a. blah) we simply refrain from
679 flattening any further. After all, there can be no instance declarations
680 that match such things. And flattening under a for-all is problematic
681 anyway; consider C (forall a. F a)
684 reportAmbigErrs :: ReportErrCtxt -> TcTyVarSet -> [WantedEvVar] -> TcM ()
685 reportAmbigErrs ctxt skols ambigs
686 -- Divide into groups that share a common set of ambiguous tyvars
687 = mapM_ report (equivClasses cmp ambigs_w_tvs)
689 ambigs_w_tvs = [ (d, varSetElems (tyVarsOfEvVarX d `minusVarSet` skols))
691 cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
693 report :: [(WantedEvVar, [TcTyVar])] -> TcM ()
696 do { let main_msg = sep [ text "Ambiguous type variable" <> plural tvs
697 <+> pprQuotedList tvs
698 <+> text "in the constraint" <> plural pairs <> colon
699 , nest 2 pp_wanteds ]
700 ; (tidy_env, mono_msg) <- mkMonomorphismMsg ctxt tvs
701 ; addErrTcM (tidy_env, main_msg $$ mono_msg) }
704 (loc, pp_wanteds) = pprWithArising (map fst pairs)
706 mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc)
707 -- There's an error with these Insts; if they have free type variables
708 -- it's probably caused by the monomorphism restriction.
709 -- Try to identify the offending variable
710 -- ASSUMPTION: the Insts are fully zonked
711 mkMonomorphismMsg ctxt inst_tvs
712 = do { dflags <- getDOpts
713 ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
714 ; return (tidy_env, mk_msg dflags docs) }
716 mk_msg _ _ | any isRuntimeUnkSkol inst_tvs -- See Note [Runtime skolems]
717 = vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
718 (pprWithCommas ppr inst_tvs),
719 ptext (sLit "Use :print or :force to determine these types")]
720 mk_msg _ [] = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)")
721 -- This happens in things like
722 -- f x = show (read "foo")
723 -- where monomorphism doesn't play any role
725 = vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"),
727 monomorphism_fix dflags]
729 monomorphism_fix :: DynFlags -> SDoc
730 monomorphism_fix dflags
731 = ptext (sLit "Probable fix:") <+> vcat
732 [ptext (sLit "give these definition(s) an explicit type signature"),
733 if xopt Opt_MonomorphismRestriction dflags
734 then ptext (sLit "or use -XNoMonomorphismRestriction")
735 else empty] -- Only suggest adding "-XNoMonomorphismRestriction"
736 -- if it is not already set!
738 getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo
740 = WARN( True, ptext (sLit "No skolem info:") <+> ppr tv )
742 getSkolemInfo (implic:implics) tv
743 | tv `elemVarSet` ic_skols implic = ctLocOrigin (ic_loc implic)
744 | otherwise = getSkolemInfo implics tv
746 -----------------------
747 -- findGlobals looks at the value environment and finds values whose
748 -- types mention any of the offending type variables. It has to be
749 -- careful to zonk the Id's type first, so it has to be in the monad.
750 -- We must be careful to pass it a zonked type variable, too.
752 mkEnvSigMsg :: SDoc -> [SDoc] -> SDoc
753 mkEnvSigMsg what env_sigs
754 | null env_sigs = empty
755 | otherwise = vcat [ ptext (sLit "The following variables have types that mention") <+> what
756 , nest 2 (vcat env_sigs) ]
758 findGlobals :: ReportErrCtxt
760 -> TcM (TidyEnv, [SDoc])
763 = do { lcl_ty_env <- case cec_encl ctxt of
765 (i:_) -> return (ic_env i)
766 ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) }
768 go tidy_env acc [] = return (tidy_env, acc)
769 go tidy_env acc (thing : things) = do
770 (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing
772 Just d -> go tidy_env1 (d:acc) things
773 Nothing -> go tidy_env1 acc things
775 ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
777 -----------------------
778 find_thing :: TidyEnv -> (TcType -> Bool)
779 -> TcTyThing -> TcM (TidyEnv, Maybe SDoc)
780 find_thing tidy_env ignore_it (ATcId { tct_id = id })
781 = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id)
782 ; if ignore_it tidy_ty then
783 return (tidy_env, Nothing)
785 { let msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty
786 , nest 2 (parens (ptext (sLit "bound at") <+>
787 ppr (getSrcLoc id)))]
788 ; return (tidy_env', Just msg) } }
790 find_thing tidy_env ignore_it (ATyVar tv ty)
791 = do { (tidy_env1, tidy_ty) <- zonkTidyTcType tidy_env ty
792 ; if ignore_it tidy_ty then
793 return (tidy_env, Nothing)
795 { let -- The name tv is scoped, so we don't need to tidy it
796 msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff
799 eq_stuff | Just tv' <- tcGetTyVar_maybe tidy_ty
800 , getOccName tv == getOccName tv' = empty
801 | otherwise = equals <+> ppr tidy_ty
802 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
803 bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
805 ; return (tidy_env1, Just msg) } }
807 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
809 warnDefaulting :: [FlavoredEvVar] -> Type -> TcM ()
810 warnDefaulting wanteds default_ty
811 = do { warn_default <- doptM Opt_WarnTypeDefaults
812 ; env0 <- tcInitTidyEnv
813 ; let wanted_bag = listToBag wanteds
814 tidy_env = tidyFreeTyVars env0 $
815 tyVarsOfEvVarXs wanted_bag
816 tidy_wanteds = mapBag (tidyFlavoredEvVar tidy_env) wanted_bag
817 (loc, ppr_wanteds) = pprWithArising (map get_wev (bagToList tidy_wanteds))
818 warn_msg = hang (ptext (sLit "Defaulting the following constraint(s) to type")
819 <+> quotes (ppr default_ty))
821 ; setCtLoc loc $ warnTc warn_default warn_msg }
823 get_wev (EvVarX ev (Wanted loc)) = EvVarX ev loc -- Yuk
824 get_wev ev = pprPanic "warnDefaulting" (ppr ev)
827 Note [Runtime skolems]
828 ~~~~~~~~~~~~~~~~~~~~~~
829 We want to give a reasonably helpful error message for ambiguity
830 arising from *runtime* skolems in the debugger. These
831 are created by in RtClosureInspect.zonkRTTIType.
833 %************************************************************************
835 Error from the canonicaliser
836 These ones are called *during* constraint simplification
838 %************************************************************************
841 solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a
842 solverDepthErrorTcS depth stack
843 | null stack -- Shouldn't happen unless you say -fcontext-stack=0
844 = wrapErrTcS $ failWith msg
847 setCtFlavorLoc (cc_flavor top_item) $
848 do { ev_vars <- mapM (zonkEvVar . cc_id) stack
849 ; env0 <- tcInitTidyEnv
850 ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfEvVars ev_vars)
851 tidy_ev_vars = map (tidyEvVar tidy_env) ev_vars
852 ; failWithTcM (tidy_env, hang msg 2 (pprEvVars tidy_ev_vars)) }
854 top_item = head stack
855 msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
856 , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
858 flattenForAllErrorTcS :: CtFlavor -> TcType -> Bag CanonicalCt -> TcS a
859 flattenForAllErrorTcS fl ty _bad_eqs
862 do { env0 <- tcInitTidyEnv
863 ; let (env1, ty') = tidyOpenType env0 ty
864 msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:")
866 ; failWithTcM (env1, msg) }
869 %************************************************************************
873 %************************************************************************
876 setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
877 setCtFlavorLoc (Wanted loc) thing = setCtLoc loc thing
878 setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing
879 setCtFlavorLoc (Given loc _gk) thing = setCtLoc loc thing
882 %************************************************************************
886 %************************************************************************
889 zonkTidyTcType :: TidyEnv -> TcType -> TcM (TidyEnv, TcType)
890 zonkTidyTcType env ty = do { ty' <- zonkTcType ty
891 ; return (tidyOpenType env ty') }
893 zonkTidyOrigin :: ReportErrCtxt -> CtOrigin -> TcM CtOrigin
894 zonkTidyOrigin ctxt (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp }))
895 = do { (env1, act') <- zonkTidyTcType (cec_tidy ctxt) act
896 ; (_env2, exp') <- zonkTidyTcType env1 exp
897 ; return (TypeEqOrigin (UnifyOrigin { uo_actual = act', uo_expected = exp' })) }
898 -- Drop the returned env on the floor; we may conceivably thereby get
899 -- inconsistent naming between uses of this function
900 zonkTidyOrigin _ orig = return orig