11 #include "HsVersions.h"
18 import Type( isTyVarTy )
24 import Id ( idType, evVarPred )
30 import ListSetOps( equivClasses )
35 import StaticFlags( opt_PprStyle_Debug )
36 import Data.List( partition )
37 import Control.Monad( when, unless )
40 %************************************************************************
42 \section{Errors and contexts}
44 %************************************************************************
46 ToDo: for these error messages, should we note the location as coming
47 from the insts, or just whatever seems to be around in the monad just
51 reportUnsolved :: WantedConstraints -> TcM ()
56 = do { -- Zonk to un-flatten any flatten-skols
57 ; wanted <- zonkWC wanted
59 ; env0 <- tcInitTidyEnv
60 ; let tidy_env = tidyFreeTyVars env0 free_tvs
61 free_tvs = tyVarsOfWC wanted
62 err_ctxt = CEC { cec_encl = []
63 , cec_insol = insolubleWC wanted
65 , cec_tidy = tidy_env }
66 tidy_wanted = tidyWC tidy_env wanted
68 ; traceTc "reportUnsolved" (ppr tidy_wanted)
70 ; reportTidyWanteds err_ctxt tidy_wanted }
72 --------------------------------------------
74 --------------------------------------------
77 = CEC { cec_encl :: [Implication] -- Enclosing implications
80 , cec_extra :: SDoc -- Add this to each error message
81 , cec_insol :: Bool -- True <=> we are reporting insoluble errors only
82 -- Main effect: don't say "Cannot deduce..."
83 -- when reporting equality errors; see misMatchOrCND
86 reportTidyImplic :: ReportErrCtxt -> Implication -> TcM ()
87 reportTidyImplic ctxt implic
88 | BracketSkol <- ctLocOrigin (ic_loc implic)
89 , not insoluble -- For Template Haskell brackets report only
90 = return () -- definite errors. The whole thing will be re-checked
91 -- later when we plug it in, and meanwhile there may
92 -- certainly be un-satisfied constraints
95 = reportTidyWanteds ctxt' (ic_wanted implic)
97 insoluble = ic_insol implic
98 ctxt' = ctxt { cec_encl = implic : cec_encl ctxt
99 , cec_insol = insoluble }
101 reportTidyWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
102 reportTidyWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = implics })
103 | cec_insol ctxt -- If there are any insolubles, report only them
104 -- because they are unconditionally wrong
105 -- Moreover, if any of the insolubles are givens, stop right there
106 -- ignoring nested errors, because the code is inaccessible
107 = do { let (given, other) = partitionBag (isGiven . evVarX) insols
108 insol_implics = filterBag ic_insol implics
109 ; if isEmptyBag given
110 then do { mapBagM_ (reportInsoluble ctxt) other
111 ; mapBagM_ (reportTidyImplic ctxt) insol_implics }
112 else mapBagM_ (reportInsoluble ctxt) given }
114 | otherwise -- No insoluble ones
115 = ASSERT( isEmptyBag insols )
116 do { let (ambigs, non_ambigs) = partition is_ambiguous (bagToList flats)
117 (tv_eqs, others) = partition is_tv_eq non_ambigs
119 ; groupErrs (reportEqErrs ctxt) tv_eqs
120 ; when (null tv_eqs) $ groupErrs (reportFlat ctxt) others
121 ; mapBagM_ (reportTidyImplic ctxt) implics
123 -- Only report ambiguity if no other errors (at all) happened
124 -- See Note [Avoiding spurious errors] in TcSimplify
125 ; ifErrsM (return ()) $ reportAmbigErrs ctxt skols ambigs }
127 skols = foldr (unionVarSet . ic_skols) emptyVarSet (cec_encl ctxt)
129 -- Report equalities of form (a~ty) first. They are usually
130 -- skolem-equalities, and they cause confusing knock-on
131 -- effects in other errors; see test T4093b.
132 is_tv_eq c | EqPred ty1 ty2 <- evVarOfPred c
133 = tcIsTyVarTy ty1 || tcIsTyVarTy ty2
136 -- Treat it as "ambiguous" if
137 -- (a) it is a class constraint
138 -- (b) it constrains only type variables
139 -- (else we'd prefer to report it as "no instance for...")
140 -- (c) it mentions type variables that are not skolems
141 is_ambiguous d = isTyVarClassPred pred
142 && not (tyVarsOfPred pred `subVarSet` skols)
146 reportInsoluble :: ReportErrCtxt -> FlavoredEvVar -> TcM ()
147 reportInsoluble ctxt (EvVarX ev flav)
148 | EqPred ty1 ty2 <- evVarPred ev
149 = setCtFlavorLoc flav $
150 do { let ctxt2 = ctxt { cec_extra = cec_extra ctxt $$ inaccessible_msg }
151 ; reportEqErr ctxt2 ty1 ty2 }
153 = pprPanic "reportInsoluble" (pprEvVarWithType ev)
155 inaccessible_msg | Given loc <- flav
156 = hang (ptext (sLit "Inaccessible code in"))
157 2 (ppr (ctLocOrigin loc))
160 reportFlat :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
161 -- The [PredType] are already tidied
162 reportFlat ctxt flats origin
163 = do { unless (null dicts) $ reportDictErrs ctxt dicts origin
164 ; unless (null eqs) $ reportEqErrs ctxt eqs origin
165 ; unless (null ips) $ reportIPErrs ctxt ips origin
166 ; ASSERT( null others ) return () }
168 (dicts, non_dicts) = partition isClassPred flats
169 (eqs, non_eqs) = partition isEqPred non_dicts
170 (ips, others) = partition isIPPred non_eqs
172 --------------------------------------------
174 --------------------------------------------
176 groupErrs :: ([PredType] -> CtOrigin -> TcM ()) -- Deal with one group
177 -> [WantedEvVar] -- Unsolved wanteds
179 -- Group together insts with the same origin
180 -- We want to report them together in error messages
184 groupErrs report_err (wanted : wanteds)
185 = do { setCtLoc the_loc $
186 report_err the_vars (ctLocOrigin the_loc)
187 ; groupErrs report_err others }
189 the_loc = evVarX wanted
190 the_key = mk_key the_loc
191 the_vars = map evVarOfPred (wanted:friends)
192 (friends, others) = partition is_friend wanteds
193 is_friend friend = mk_key (evVarX friend) `same_key` the_key
195 mk_key :: WantedLoc -> (SrcSpan, CtOrigin)
196 mk_key loc = (ctLocSpan loc, ctLocOrigin loc)
198 same_key (s1, o1) (s2, o2) = s1==s2 && o1 `same_orig` o2
199 same_orig (OccurrenceOf n1) (OccurrenceOf n2) = n1==n2
200 same_orig ScOrigin ScOrigin = True
201 same_orig DerivOrigin DerivOrigin = True
202 same_orig DefaultOrigin DefaultOrigin = True
203 same_orig _ _ = False
206 -- Add the "arising from..." part to a message about bunch of dicts
207 addArising :: CtOrigin -> SDoc -> SDoc
208 addArising orig msg = msg $$ nest 2 (pprArising orig)
210 pprWithArising :: [WantedEvVar] -> (WantedLoc, SDoc)
211 -- Print something like
212 -- (Eq a) arising from a use of x at y
213 -- (Show a) arising from a use of p at q
214 -- Also return a location for the error message
216 = panic "pprWithArising"
217 pprWithArising [EvVarX ev loc]
218 = (loc, pprEvVarTheta [ev] <+> pprArising (ctLocOrigin loc))
219 pprWithArising ev_vars
220 = (first_loc, vcat (map ppr_one ev_vars))
222 first_loc = evVarX (head ev_vars)
223 ppr_one (EvVarX v loc)
224 = parens (pprPredTy (evVarPred v)) <+> pprArisingAt loc
226 addErrorReport :: ReportErrCtxt -> SDoc -> TcM ()
227 addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt)
229 pprErrCtxtLoc :: ReportErrCtxt -> SDoc
231 = case map (ctLocOrigin . ic_loc) (cec_encl ctxt) of
232 [] -> ptext (sLit "the top level") -- Should not happen
233 (orig:origs) -> ppr_skol orig $$
234 vcat [ ptext (sLit "or") <+> ppr_skol orig | orig <- origs ]
236 ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc)
237 ppr_skol skol_info = ppr skol_info
239 getUserGivens :: ReportErrCtxt -> [([EvVar], GivenLoc)]
240 -- One item for each enclosing implication
241 getUserGivens (CEC {cec_encl = ctxt})
243 [ (givens', loc) | Implic {ic_given = givens, ic_loc = loc} <- ctxt
244 , let givens' = get_user_givens givens
245 , not (null givens') ]
247 get_user_givens givens | opt_PprStyle_Debug = givens
248 | otherwise = filterOut isSilentEvVar givens
249 -- In user mode, don't show the "silent" givens, used for
250 -- the "self" dictionary and silent superclass arguments for dfuns
255 %************************************************************************
257 Implicit parameter errors
259 %************************************************************************
262 reportIPErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
263 reportIPErrs ctxt ips orig
264 = addErrorReport ctxt msg
266 givens = getUserGivens ctxt
269 sep [ ptext (sLit "Unbound implicit parameter") <> plural ips
270 , nest 2 (pprTheta ips) ]
272 = couldNotDeduce givens (ips, orig)
276 %************************************************************************
280 %************************************************************************
283 reportEqErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
284 -- The [PredType] are already tidied
285 reportEqErrs ctxt eqs orig
286 = do { orig' <- zonkTidyOrigin ctxt orig
287 ; mapM_ (report_one orig') eqs }
289 report_one orig (EqPred ty1 ty2)
290 = do { let extra = getWantedEqExtra orig ty1 ty2
291 ctxt' = ctxt { cec_extra = extra $$ cec_extra ctxt }
292 ; reportEqErr ctxt' ty1 ty2 }
294 = pprPanic "reportEqErrs" (ppr pred)
296 getWantedEqExtra :: CtOrigin -> TcType -> TcType -> SDoc
297 getWantedEqExtra (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp }))
299 -- If the types in the error message are the same as the types we are unifying,
300 -- don't add the extra expected/actual message
301 | act `eqType` ty1 && exp `eqType` ty2 = empty
302 | exp `eqType` ty1 && act `eqType` ty2 = empty
303 | otherwise = mkExpectedActualMsg act exp
305 getWantedEqExtra orig _ _ = pprArising orig
307 reportEqErr :: ReportErrCtxt -> TcType -> TcType -> TcM ()
308 -- ty1 and ty2 are already tidied
309 reportEqErr ctxt ty1 ty2
310 | Just tv1 <- tcGetTyVar_maybe ty1 = reportTyVarEqErr ctxt tv1 ty2
311 | Just tv2 <- tcGetTyVar_maybe ty2 = reportTyVarEqErr ctxt tv2 ty1
313 | otherwise -- Neither side is a type variable
314 -- Since the unsolved constraint is canonical,
315 -- it must therefore be of form (F tys ~ ty)
316 = addErrorReport ctxt (misMatchOrCND ctxt ty1 ty2 $$ mkTyFunInfoMsg ty1 ty2)
319 reportTyVarEqErr :: ReportErrCtxt -> TcTyVar -> TcType -> TcM ()
320 -- tv1 and ty2 are already tidied
321 reportTyVarEqErr ctxt tv1 ty2
322 | isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar, or else the thing would
323 -- be oriented the other way round; see TcCanonical.reOrient
324 || isSigTyVar tv1 && not (isTyVarTy ty2)
325 = addErrorReport (addExtraInfo ctxt ty1 ty2)
326 (misMatchOrCND ctxt ty1 ty2)
328 -- So tv is a meta tyvar, and presumably it is
329 -- an *untouchable* meta tyvar, else it'd have been unified
330 | not (k2 `isSubKind` k1) -- Kind error
331 = addErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2)
334 | tv1 `elemVarSet` tyVarsOfType ty2
335 = let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:") 2
336 (sep [ppr ty1, char '=', ppr ty2])
337 in addErrorReport ctxt occCheckMsg
339 -- Check for skolem escape
340 | (implic:_) <- cec_encl ctxt -- Get the innermost context
341 , let esc_skols = varSetElems (tyVarsOfType ty2 `intersectVarSet` ic_skols implic)
342 implic_loc = ic_loc implic
343 , not (null esc_skols)
344 = setCtLoc implic_loc $ -- Override the error message location from the
345 -- place the equality arose to the implication site
346 do { (env1, env_sigs) <- findGlobals ctxt (unitVarSet tv1)
347 ; let msg = misMatchMsg ty1 ty2
348 esc_doc = sep [ ptext (sLit "because type variable") <> plural esc_skols
349 <+> pprQuotedList esc_skols
350 , ptext (sLit "would escape") <+>
351 if isSingleton esc_skols then ptext (sLit "its scope")
352 else ptext (sLit "their scope") ]
353 extra1 = vcat [ nest 2 $ esc_doc
354 , sep [ (if isSingleton esc_skols
355 then ptext (sLit "This (rigid, skolem) type variable is")
356 else ptext (sLit "These (rigid, skolem) type variables are"))
357 <+> ptext (sLit "bound by")
358 , nest 2 $ ppr (ctLocOrigin implic_loc) ] ]
359 ; addErrTcM (env1, msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) }
361 -- Nastiest case: attempt to unify an untouchable variable
362 | (implic:_) <- cec_encl ctxt -- Get the innermost context
363 , let implic_loc = ic_loc implic
364 given = ic_given implic
365 = setCtLoc (ic_loc implic) $
366 do { let msg = misMatchMsg ty1 ty2
367 extra = quotes (ppr tv1)
368 <+> sep [ ptext (sLit "is untouchable")
369 , ptext (sLit "inside the constraints") <+> pprEvVarTheta given
370 , ptext (sLit "bound at") <+> ppr (ctLocOrigin implic_loc)]
371 ; addErrorReport (addExtraInfo ctxt ty1 ty2) (msg $$ nest 2 extra) }
374 = pprTrace "reportTyVarEqErr" (ppr tv1 $$ ppr ty2 $$ ppr (cec_encl ctxt)) $
376 -- I don't think this should happen, and if it does I want to know
377 -- Trac #5130 happened because an actual type error was not
378 -- reported at all! So not reporting is pretty dangerous.
380 -- OLD, OUT OF DATE COMMENT
381 -- This can happen, by a recursive decomposition of frozen
382 -- occurs check constraints
383 -- Example: alpha ~ T Int alpha has frozen.
384 -- Then alpha gets unified to T beta gamma
385 -- So now we have T beta gamma ~ T Int (T beta gamma)
386 -- Decompose to (beta ~ Int, gamma ~ T beta gamma)
387 -- The (gamma ~ T beta gamma) is the occurs check, but
388 -- the (beta ~ Int) isn't an error at all. So return ()
394 mkTyFunInfoMsg :: TcType -> TcType -> SDoc
395 -- See Note [Non-injective type functions]
396 mkTyFunInfoMsg ty1 ty2
397 | Just (tc1,_) <- tcSplitTyConApp_maybe ty1
398 , Just (tc2,_) <- tcSplitTyConApp_maybe ty2
399 , tc1 == tc2, isSynFamilyTyCon tc1
400 = ptext (sLit "NB:") <+> quotes (ppr tc1)
401 <+> ptext (sLit "is a type function") <> (pp_inj tc1)
404 pp_inj tc | isInjectiveTyCon tc = empty
405 | otherwise = ptext (sLit (", and may not be injective"))
407 misMatchOrCND :: ReportErrCtxt -> TcType -> TcType -> SDoc
408 misMatchOrCND ctxt ty1 ty2
409 | cec_insol ctxt = misMatchMsg ty1 ty2 -- If the equality is unconditionally
410 -- insoluble, don't report the context
411 | null givens = misMatchMsg ty1 ty2
412 | otherwise = couldNotDeduce givens ([EqPred ty1 ty2], orig)
414 givens = getUserGivens ctxt
415 orig = TypeEqOrigin (UnifyOrigin ty1 ty2)
417 couldNotDeduce :: [([EvVar], GivenLoc)] -> (ThetaType, CtOrigin) -> SDoc
418 couldNotDeduce givens (wanteds, orig)
419 = vcat [ hang (ptext (sLit "Could not deduce") <+> pprTheta wanteds)
426 (g:gs) -> ppr_given (ptext (sLit "from the context")) g
427 : map (ppr_given (ptext (sLit "or from"))) gs
429 ppr_given herald (gs,loc)
430 = hang (herald <+> pprEvVarTheta gs)
431 2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin loc)
432 , ptext (sLit "at") <+> ppr (ctLocSpan loc)])
434 addExtraInfo :: ReportErrCtxt -> TcType -> TcType -> ReportErrCtxt
435 -- Add on extra info about the types themselves
436 -- NB: The types themselves are already tidied
437 addExtraInfo ctxt ty1 ty2
438 = ctxt { cec_extra = nest 2 (extra1 $$ extra2) $$ cec_extra ctxt }
440 extra1 = typeExtraInfoMsg (cec_encl ctxt) ty1
441 extra2 = typeExtraInfoMsg (cec_encl ctxt) ty2
443 misMatchMsg :: TcType -> TcType -> SDoc -- Types are already tidy
444 misMatchMsg ty1 ty2 = sep [ ptext (sLit "Couldn't match type") <+> quotes (ppr ty1)
445 , nest 15 $ ptext (sLit "with") <+> quotes (ppr ty2)]
447 kindErrorMsg :: TcType -> TcType -> SDoc -- Types are already tidy
449 = vcat [ ptext (sLit "Kind incompatibility when matching types:")
450 , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1
451 , ppr ty2 <+> dcolon <+> ppr k2 ]) ]
456 typeExtraInfoMsg :: [Implication] -> Type -> SDoc
457 -- Shows a bit of extra info about skolem constants
458 typeExtraInfoMsg implics ty
459 | Just tv <- tcGetTyVar_maybe ty
460 , isTcTyVar tv, isSkolemTyVar tv
461 , let pp_tv = quotes (ppr tv)
462 = case tcTyVarDetails tv of
463 SkolemTv {} -> pp_tv <+> ppr_skol (getSkolemInfo implics tv) (getSrcLoc tv)
464 FlatSkol {} -> pp_tv <+> ptext (sLit "is a flattening type variable")
465 RuntimeUnk {} -> pp_tv <+> ptext (sLit "is an interactive-debugger skolem")
468 | otherwise -- Normal case
472 ppr_skol UnkSkol _ = ptext (sLit "is an unknown type variable") -- Unhelpful
473 ppr_skol info loc = sep [ptext (sLit "is a rigid type variable bound by"),
474 sep [ppr info, ptext (sLit "at") <+> ppr loc]]
477 unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc)
478 unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env
479 = do { (env1, act_ty') <- zonkTidyTcType tidy_env act_ty
480 ; (env2, exp_ty') <- zonkTidyTcType env1 exp_ty
481 ; return (env2, mkExpectedActualMsg act_ty' exp_ty') }
483 mkExpectedActualMsg :: Type -> Type -> SDoc
484 mkExpectedActualMsg act_ty exp_ty
485 = vcat [ text "Expected type" <> colon <+> ppr exp_ty
486 , text " Actual type" <> colon <+> ppr act_ty ]
489 Note [Non-injective type functions]
490 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
491 It's very confusing to get a message like
492 Couldn't match expected type `Depend s'
493 against inferred type `Depend s1'
494 so mkTyFunInfoMsg adds:
495 NB: `Depend' is type function, and hence may not be injective
497 Warn of loopy local equalities that were dropped.
500 %************************************************************************
504 %************************************************************************
507 reportDictErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
508 reportDictErrs ctxt wanteds orig
509 = do { inst_envs <- tcGetInstEnvs
510 ; non_overlaps <- mapMaybeM (reportOverlap ctxt inst_envs orig) wanteds
511 ; unless (null non_overlaps) $
512 addErrorReport ctxt (mk_no_inst_err non_overlaps) }
514 mk_no_inst_err :: [PredType] -> SDoc
515 mk_no_inst_err wanteds
516 | null givens -- Top level
517 = vcat [ addArising orig $
518 ptext (sLit "No instance") <> plural min_wanteds
519 <+> ptext (sLit "for") <+> pprTheta min_wanteds
520 , show_fixes (fixes2 ++ fixes3) ]
523 = vcat [ couldNotDeduce givens (min_wanteds, orig)
524 , show_fixes (fix1 : (fixes2 ++ fixes3)) ]
526 givens = getUserGivens ctxt
527 min_wanteds = mkMinimalBySCs wanteds
528 fix1 = sep [ ptext (sLit "add") <+> pprTheta min_wanteds
529 <+> ptext (sLit "to the context of")
530 , nest 2 $ pprErrCtxtLoc ctxt ]
532 fixes2 = case instance_dicts of
534 [_] -> [sep [ptext (sLit "add an instance declaration for"),
535 pprTheta instance_dicts]]
536 _ -> [sep [ptext (sLit "add instance declarations for"),
537 pprTheta instance_dicts]]
538 fixes3 = case orig of
539 DerivOrigin -> [drv_fix]
542 instance_dicts = filterOut isTyVarClassPred min_wanteds
543 -- Insts for which it is worth suggesting an adding an
544 -- instance declaration. Exclude tyvar dicts.
546 drv_fix = vcat [ptext (sLit "use a standalone 'deriving instance' declaration,"),
547 nest 2 $ ptext (sLit "so you can specify the instance context yourself")]
549 show_fixes :: [SDoc] -> SDoc
550 show_fixes [] = empty
551 show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"),
552 nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
554 reportOverlap :: ReportErrCtxt -> (InstEnv,InstEnv) -> CtOrigin
555 -> PredType -> TcM (Maybe PredType)
556 -- Report an overlap error if this class constraint results
557 -- from an overlap (returning Nothing), otherwise return (Just pred)
558 reportOverlap ctxt inst_envs orig pred@(ClassP clas tys)
559 = do { tys_flat <- mapM quickFlattenTy tys
560 -- Note [Flattening in error message generation]
562 ; case lookupInstEnv inst_envs clas tys_flat of
563 ([], _) -> return (Just pred) -- No match
564 -- The case of exactly one match and no unifiers means a
565 -- successful lookup. That can't happen here, because dicts
566 -- only end up here if they didn't match in Inst.lookupInst
568 | debugIsOn -> pprPanic "check_overlap" (ppr pred)
569 res -> do { addErrorReport ctxt (mk_overlap_msg res)
572 mk_overlap_msg (matches, unifiers)
573 = ASSERT( not (null matches) )
574 vcat [ addArising orig (ptext (sLit "Overlapping instances for")
576 , sep [ptext (sLit "Matching instances") <> colon,
577 nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
578 , if not (isSingleton matches)
579 then -- Two or more matches
581 else -- One match, plus some unifiers
582 ASSERT( not (null unifiers) )
583 parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
584 quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
585 ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
586 ptext (sLit "when compiling the other instance declarations")])]
588 ispecs = [ispec | (ispec, _) <- matches]
590 reportOverlap _ _ _ _ = panic "reportOverlap" -- Not a ClassP
592 ----------------------
593 quickFlattenTy :: TcType -> TcM TcType
594 -- See Note [Flattening in error message generation]
595 quickFlattenTy ty | Just ty' <- tcView ty = quickFlattenTy ty'
596 quickFlattenTy ty@(TyVarTy {}) = return ty
597 quickFlattenTy ty@(ForAllTy {}) = return ty -- See
598 quickFlattenTy ty@(PredTy {}) = return ty -- Note [Quick-flatten polytypes]
599 -- Don't flatten because of the danger or removing a bound variable
600 quickFlattenTy (AppTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
601 ; fy2 <- quickFlattenTy ty2
602 ; return (AppTy fy1 fy2) }
603 quickFlattenTy (FunTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
604 ; fy2 <- quickFlattenTy ty2
605 ; return (FunTy fy1 fy2) }
606 quickFlattenTy (TyConApp tc tys)
607 | not (isSynFamilyTyCon tc)
608 = do { fys <- mapM quickFlattenTy tys
609 ; return (TyConApp tc fys) }
611 = do { let (funtys,resttys) = splitAt (tyConArity tc) tys
612 -- Ignore the arguments of the type family funtys
613 ; v <- newMetaTyVar TauTv (typeKind (TyConApp tc funtys))
614 ; flat_resttys <- mapM quickFlattenTy resttys
615 ; return (foldl AppTy (mkTyVarTy v) flat_resttys) }
618 Note [Flattening in error message generation]
619 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
620 Consider (C (Maybe (F x))), where F is a type function, and we have
622 C (Maybe Int) and C (Maybe a)
623 Since (F x) might turn into Int, this is an overlap situation, and
624 indeed (because of flattening) the main solver will have refrained
625 from solving. But by the time we get to error message generation, we've
626 un-flattened the constraint. So we must *re*-flatten it before looking
627 up in the instance environment, lest we only report one matching
628 instance when in fact there are two.
630 Re-flattening is pretty easy, because we don't need to keep track of
631 evidence. We don't re-use the code in TcCanonical because that's in
632 the TcS monad, and we are in TcM here.
634 Note [Quick-flatten polytypes]
635 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
636 If we see C (Ix a => blah) or C (forall a. blah) we simply refrain from
637 flattening any further. After all, there can be no instance declarations
638 that match such things. And flattening under a for-all is problematic
639 anyway; consider C (forall a. F a)
642 reportAmbigErrs :: ReportErrCtxt -> TcTyVarSet -> [WantedEvVar] -> TcM ()
643 reportAmbigErrs ctxt skols ambigs
644 -- Divide into groups that share a common set of ambiguous tyvars
645 = mapM_ report (equivClasses cmp ambigs_w_tvs)
647 ambigs_w_tvs = [ (d, varSetElems (tyVarsOfEvVarX d `minusVarSet` skols))
649 cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
651 report :: [(WantedEvVar, [TcTyVar])] -> TcM ()
654 do { let main_msg = sep [ text "Ambiguous type variable" <> plural tvs
655 <+> pprQuotedList tvs
656 <+> text "in the constraint" <> plural pairs <> colon
657 , nest 2 pp_wanteds ]
658 ; (tidy_env, mono_msg) <- mkMonomorphismMsg ctxt tvs
659 ; addErrTcM (tidy_env, main_msg $$ mono_msg) }
662 (loc, pp_wanteds) = pprWithArising (map fst pairs)
664 mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc)
665 -- There's an error with these Insts; if they have free type variables
666 -- it's probably caused by the monomorphism restriction.
667 -- Try to identify the offending variable
668 -- ASSUMPTION: the Insts are fully zonked
669 mkMonomorphismMsg ctxt inst_tvs
670 = do { dflags <- getDOpts
671 ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
672 ; return (tidy_env, mk_msg dflags docs) }
674 mk_msg _ _ | any isRuntimeUnkSkol inst_tvs -- See Note [Runtime skolems]
675 = vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
676 (pprWithCommas ppr inst_tvs),
677 ptext (sLit "Use :print or :force to determine these types")]
678 mk_msg _ [] = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)")
679 -- This happens in things like
680 -- f x = show (read "foo")
681 -- where monomorphism doesn't play any role
683 = vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"),
685 monomorphism_fix dflags]
687 monomorphism_fix :: DynFlags -> SDoc
688 monomorphism_fix dflags
689 = ptext (sLit "Probable fix:") <+> vcat
690 [ptext (sLit "give these definition(s) an explicit type signature"),
691 if xopt Opt_MonomorphismRestriction dflags
692 then ptext (sLit "or use -XNoMonomorphismRestriction")
693 else empty] -- Only suggest adding "-XNoMonomorphismRestriction"
694 -- if it is not already set!
696 getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo
698 = WARN( True, ptext (sLit "No skolem info:") <+> ppr tv )
700 getSkolemInfo (implic:implics) tv
701 | tv `elemVarSet` ic_skols implic = ctLocOrigin (ic_loc implic)
702 | otherwise = getSkolemInfo implics tv
704 -----------------------
705 -- findGlobals looks at the value environment and finds values whose
706 -- types mention any of the offending type variables. It has to be
707 -- careful to zonk the Id's type first, so it has to be in the monad.
708 -- We must be careful to pass it a zonked type variable, too.
710 mkEnvSigMsg :: SDoc -> [SDoc] -> SDoc
711 mkEnvSigMsg what env_sigs
712 | null env_sigs = empty
713 | otherwise = vcat [ ptext (sLit "The following variables have types that mention") <+> what
714 , nest 2 (vcat env_sigs) ]
716 findGlobals :: ReportErrCtxt
718 -> TcM (TidyEnv, [SDoc])
721 = do { lcl_ty_env <- case cec_encl ctxt of
723 (i:_) -> return (ic_env i)
724 ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) }
726 go tidy_env acc [] = return (tidy_env, acc)
727 go tidy_env acc (thing : things) = do
728 (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing
730 Just d -> go tidy_env1 (d:acc) things
731 Nothing -> go tidy_env1 acc things
733 ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
735 -----------------------
736 find_thing :: TidyEnv -> (TcType -> Bool)
737 -> TcTyThing -> TcM (TidyEnv, Maybe SDoc)
738 find_thing tidy_env ignore_it (ATcId { tct_id = id })
739 = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id)
740 ; if ignore_it tidy_ty then
741 return (tidy_env, Nothing)
743 { let msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty
744 , nest 2 (parens (ptext (sLit "bound at") <+>
745 ppr (getSrcLoc id)))]
746 ; return (tidy_env', Just msg) } }
748 find_thing tidy_env ignore_it (ATyVar tv ty)
749 = do { (tidy_env1, tidy_ty) <- zonkTidyTcType tidy_env ty
750 ; if ignore_it tidy_ty then
751 return (tidy_env, Nothing)
753 { let -- The name tv is scoped, so we don't need to tidy it
754 msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff
757 eq_stuff | Just tv' <- tcGetTyVar_maybe tidy_ty
758 , getOccName tv == getOccName tv' = empty
759 | otherwise = equals <+> ppr tidy_ty
760 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
761 bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
763 ; return (tidy_env1, Just msg) } }
765 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
767 warnDefaulting :: [FlavoredEvVar] -> Type -> TcM ()
768 warnDefaulting wanteds default_ty
769 = do { warn_default <- doptM Opt_WarnTypeDefaults
770 ; env0 <- tcInitTidyEnv
771 ; let wanted_bag = listToBag wanteds
772 tidy_env = tidyFreeTyVars env0 $
773 tyVarsOfEvVarXs wanted_bag
774 tidy_wanteds = mapBag (tidyFlavoredEvVar tidy_env) wanted_bag
775 (loc, ppr_wanteds) = pprWithArising (map get_wev (bagToList tidy_wanteds))
776 warn_msg = hang (ptext (sLit "Defaulting the following constraint(s) to type")
777 <+> quotes (ppr default_ty))
779 ; setCtLoc loc $ warnTc warn_default warn_msg }
781 get_wev (EvVarX ev (Wanted loc)) = EvVarX ev loc -- Yuk
782 get_wev ev = pprPanic "warnDefaulting" (ppr ev)
785 Note [Runtime skolems]
786 ~~~~~~~~~~~~~~~~~~~~~~
787 We want to give a reasonably helpful error message for ambiguity
788 arising from *runtime* skolems in the debugger. These
789 are created by in RtClosureInspect.zonkRTTIType.
791 %************************************************************************
793 Error from the canonicaliser
794 These ones are called *during* constraint simplification
796 %************************************************************************
799 solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a
800 solverDepthErrorTcS depth stack
801 | null stack -- Shouldn't happen unless you say -fcontext-stack=0
802 = wrapErrTcS $ failWith msg
805 setCtFlavorLoc (cc_flavor top_item) $
806 do { ev_vars <- mapM (zonkEvVar . cc_id) stack
807 ; env0 <- tcInitTidyEnv
808 ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfEvVars ev_vars)
809 tidy_ev_vars = map (tidyEvVar tidy_env) ev_vars
810 ; failWithTcM (tidy_env, hang msg 2 (pprEvVars tidy_ev_vars)) }
812 top_item = head stack
813 msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
814 , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
816 flattenForAllErrorTcS :: CtFlavor -> TcType -> Bag CanonicalCt -> TcS a
817 flattenForAllErrorTcS fl ty _bad_eqs
820 do { env0 <- tcInitTidyEnv
821 ; let (env1, ty') = tidyOpenType env0 ty
822 msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:")
824 ; failWithTcM (env1, msg) }
827 %************************************************************************
831 %************************************************************************
834 setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
835 setCtFlavorLoc (Wanted loc) thing = setCtLoc loc thing
836 setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing
837 setCtFlavorLoc (Given loc) thing = setCtLoc loc thing
840 %************************************************************************
844 %************************************************************************
847 zonkTidyTcType :: TidyEnv -> TcType -> TcM (TidyEnv, TcType)
848 zonkTidyTcType env ty = do { ty' <- zonkTcType ty
849 ; return (tidyOpenType env ty') }
851 zonkTidyOrigin :: ReportErrCtxt -> CtOrigin -> TcM CtOrigin
852 zonkTidyOrigin ctxt (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp }))
853 = do { (env1, act') <- zonkTidyTcType (cec_tidy ctxt) act
854 ; (_env2, exp') <- zonkTidyTcType env1 exp
855 ; return (TypeEqOrigin (UnifyOrigin { uo_actual = act', uo_expected = exp' })) }
856 -- Drop the returned env on the floor; we may conceivably thereby get
857 -- inconsistent naming between uses of this function
858 zonkTidyOrigin _ orig = return orig