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