11 #include "HsVersions.h"
18 import Type( isTyVarTy )
32 import ListSetOps( equivClasses )
37 import StaticFlags( opt_PprStyle_Debug )
38 import Data.List( partition )
39 import Control.Monad( when, unless )
42 %************************************************************************
44 \section{Errors and contexts}
46 %************************************************************************
48 ToDo: for these error messages, should we note the location as coming
49 from the insts, or just whatever seems to be around in the monad just
53 reportUnsolved :: WantedConstraints -> TcM ()
58 = do { -- Zonk to un-flatten any flatten-skols
59 ; wanted <- zonkWC wanted
61 ; env0 <- tcInitTidyEnv
62 ; let tidy_env = tidyFreeTyVars env0 free_tvs
63 free_tvs = tyVarsOfWC wanted
64 err_ctxt = CEC { cec_encl = []
65 , cec_insol = insolubleWC wanted
67 , cec_tidy = tidy_env }
68 tidy_wanted = tidyWC tidy_env wanted
70 ; traceTc "reportUnsolved" (ppr tidy_wanted)
72 ; reportTidyWanteds err_ctxt tidy_wanted }
74 --------------------------------------------
76 --------------------------------------------
79 = CEC { cec_encl :: [Implication] -- Enclosing implications
82 , cec_extra :: SDoc -- Add this to each error message
83 , cec_insol :: Bool -- True <=> we are reporting insoluble errors only
84 -- Main effect: don't say "Cannot deduce..."
85 -- when reporting equality errors; see misMatchOrCND
88 reportTidyImplic :: ReportErrCtxt -> Implication -> TcM ()
89 reportTidyImplic ctxt implic
90 | BracketSkol <- ctLocOrigin (ic_loc implic)
91 , not insoluble -- For Template Haskell brackets report only
92 = return () -- definite errors. The whole thing will be re-checked
93 -- later when we plug it in, and meanwhile there may
94 -- certainly be un-satisfied constraints
97 = reportTidyWanteds ctxt' (ic_wanted implic)
99 insoluble = ic_insol implic
100 ctxt' = ctxt { cec_encl = implic : cec_encl ctxt
101 , cec_insol = insoluble }
103 reportTidyWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
104 reportTidyWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = implics })
105 | cec_insol ctxt -- If there are any insolubles, report only them
106 -- because they are unconditionally wrong
107 -- Moreover, if any of the insolubles are givens, stop right there
108 -- ignoring nested errors, because the code is inaccessible
109 = do { let (given, other) = partitionBag (isGiven . evVarX) insols
110 insol_implics = filterBag ic_insol implics
111 ; if isEmptyBag given
112 then do { mapBagM_ (reportInsoluble ctxt) other
113 ; mapBagM_ (reportTidyImplic ctxt) insol_implics }
114 else mapBagM_ (reportInsoluble ctxt) given }
116 | otherwise -- No insoluble ones
117 = ASSERT( isEmptyBag insols )
118 do { let (ambigs, non_ambigs) = partition is_ambiguous (bagToList flats)
119 (tv_eqs, others) = partition is_tv_eq non_ambigs
121 ; groupErrs (reportEqErrs ctxt) tv_eqs
122 ; when (null tv_eqs) $ groupErrs (reportFlat ctxt) others
123 ; mapBagM_ (reportTidyImplic ctxt) implics
125 -- Only report ambiguity if no other errors (at all) happened
126 -- See Note [Avoiding spurious errors] in TcSimplify
127 ; ifErrsM (return ()) $ reportAmbigErrs ctxt skols ambigs }
129 skols = foldr (unionVarSet . ic_skols) emptyVarSet (cec_encl ctxt)
131 -- Report equalities of form (a~ty) first. They are usually
132 -- skolem-equalities, and they cause confusing knock-on
133 -- effects in other errors; see test T4093b.
134 is_tv_eq c | EqPred ty1 ty2 <- evVarOfPred c
135 = tcIsTyVarTy ty1 || tcIsTyVarTy ty2
138 -- Treat it as "ambiguous" if
139 -- (a) it is a class constraint
140 -- (b) it constrains only type variables
141 -- (else we'd prefer to report it as "no instance for...")
142 -- (c) it mentions type variables that are not skolems
143 is_ambiguous d = isTyVarClassPred pred
144 && not (tyVarsOfPred pred `subVarSet` skols)
148 reportInsoluble :: ReportErrCtxt -> FlavoredEvVar -> TcM ()
149 reportInsoluble ctxt (EvVarX ev flav)
150 | EqPred ty1 ty2 <- evVarPred ev
151 = setCtFlavorLoc flav $
152 do { let ctxt2 = ctxt { cec_extra = cec_extra ctxt $$ inaccessible_msg }
153 ; reportEqErr ctxt2 ty1 ty2 }
155 = pprPanic "reportInsoluble" (pprEvVarWithType ev)
157 inaccessible_msg | Given loc <- flav
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 (pprPred (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 `tcEqType` ty1 && exp `tcEqType` ty2 = empty
304 | exp `tcEqType` ty1 && act `tcEqType` 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)
428 (g:gs) -> ppr_given (ptext (sLit "from the context")) g
429 : map (ppr_given (ptext (sLit "or from"))) gs
431 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])]
580 , if not (isSingleton matches)
581 then -- Two or more matches
583 else -- One match, plus some unifiers
584 ASSERT( not (null unifiers) )
585 parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
586 quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
587 ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
588 ptext (sLit "when compiling the other instance declarations")])]
590 ispecs = [ispec | (ispec, _) <- matches]
592 reportOverlap _ _ _ _ = panic "reportOverlap" -- Not a ClassP
594 ----------------------
595 quickFlattenTy :: TcType -> TcM TcType
596 -- See Note [Flattening in error message generation]
597 quickFlattenTy ty | Just ty' <- tcView ty = quickFlattenTy ty'
598 quickFlattenTy ty@(TyVarTy {}) = return ty
599 quickFlattenTy ty@(ForAllTy {}) = return ty -- See
600 quickFlattenTy ty@(PredTy {}) = return ty -- Note [Quick-flatten polytypes]
601 -- Don't flatten because of the danger or removing a bound variable
602 quickFlattenTy (AppTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
603 ; fy2 <- quickFlattenTy ty2
604 ; return (AppTy fy1 fy2) }
605 quickFlattenTy (FunTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
606 ; fy2 <- quickFlattenTy ty2
607 ; return (FunTy fy1 fy2) }
608 quickFlattenTy (TyConApp tc tys)
609 | not (isSynFamilyTyCon tc)
610 = do { fys <- mapM quickFlattenTy tys
611 ; return (TyConApp tc fys) }
613 = do { let (funtys,resttys) = splitAt (tyConArity tc) tys
614 -- Ignore the arguments of the type family funtys
615 ; v <- newMetaTyVar TauTv (typeKind (TyConApp tc funtys))
616 ; flat_resttys <- mapM quickFlattenTy resttys
617 ; return (foldl AppTy (mkTyVarTy v) flat_resttys) }
620 Note [Flattening in error message generation]
621 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
622 Consider (C (Maybe (F x))), where F is a type function, and we have
624 C (Maybe Int) and C (Maybe a)
625 Since (F x) might turn into Int, this is an overlap situation, and
626 indeed (because of flattening) the main solver will have refrained
627 from solving. But by the time we get to error message generation, we've
628 un-flattened the constraint. So we must *re*-flatten it before looking
629 up in the instance environment, lest we only report one matching
630 instance when in fact there are two.
632 Re-flattening is pretty easy, because we don't need to keep track of
633 evidence. We don't re-use the code in TcCanonical because that's in
634 the TcS monad, and we are in TcM here.
636 Note [Quick-flatten polytypes]
637 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
638 If we see C (Ix a => blah) or C (forall a. blah) we simply refrain from
639 flattening any further. After all, there can be no instance declarations
640 that match such things. And flattening under a for-all is problematic
641 anyway; consider C (forall a. F a)
644 reportAmbigErrs :: ReportErrCtxt -> TcTyVarSet -> [WantedEvVar] -> TcM ()
645 reportAmbigErrs ctxt skols ambigs
646 -- Divide into groups that share a common set of ambiguous tyvars
647 = mapM_ report (equivClasses cmp ambigs_w_tvs)
649 ambigs_w_tvs = [ (d, varSetElems (tyVarsOfEvVarX d `minusVarSet` skols))
651 cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
653 report :: [(WantedEvVar, [TcTyVar])] -> TcM ()
656 do { let main_msg = sep [ text "Ambiguous type variable" <> plural tvs
657 <+> pprQuotedList tvs
658 <+> text "in the constraint" <> plural pairs <> colon
659 , nest 2 pp_wanteds ]
660 ; (tidy_env, mono_msg) <- mkMonomorphismMsg ctxt tvs
661 ; addErrTcM (tidy_env, main_msg $$ mono_msg) }
664 (loc, pp_wanteds) = pprWithArising (map fst pairs)
666 mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc)
667 -- There's an error with these Insts; if they have free type variables
668 -- it's probably caused by the monomorphism restriction.
669 -- Try to identify the offending variable
670 -- ASSUMPTION: the Insts are fully zonked
671 mkMonomorphismMsg ctxt inst_tvs
672 = do { dflags <- getDOpts
673 ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
674 ; return (tidy_env, mk_msg dflags docs) }
676 mk_msg _ _ | any isRuntimeUnkSkol inst_tvs -- See Note [Runtime skolems]
677 = vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
678 (pprWithCommas ppr inst_tvs),
679 ptext (sLit "Use :print or :force to determine these types")]
680 mk_msg _ [] = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)")
681 -- This happens in things like
682 -- f x = show (read "foo")
683 -- where monomorphism doesn't play any role
685 = vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"),
687 monomorphism_fix dflags]
689 monomorphism_fix :: DynFlags -> SDoc
690 monomorphism_fix dflags
691 = ptext (sLit "Probable fix:") <+> vcat
692 [ptext (sLit "give these definition(s) an explicit type signature"),
693 if xopt Opt_MonomorphismRestriction dflags
694 then ptext (sLit "or use -XNoMonomorphismRestriction")
695 else empty] -- Only suggest adding "-XNoMonomorphismRestriction"
696 -- if it is not already set!
698 getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo
700 = WARN( True, ptext (sLit "No skolem info:") <+> ppr tv )
702 getSkolemInfo (implic:implics) tv
703 | tv `elemVarSet` ic_skols implic = ctLocOrigin (ic_loc implic)
704 | otherwise = getSkolemInfo implics tv
706 -----------------------
707 -- findGlobals looks at the value environment and finds values whose
708 -- types mention any of the offending type variables. It has to be
709 -- careful to zonk the Id's type first, so it has to be in the monad.
710 -- We must be careful to pass it a zonked type variable, too.
712 mkEnvSigMsg :: SDoc -> [SDoc] -> SDoc
713 mkEnvSigMsg what env_sigs
714 | null env_sigs = empty
715 | otherwise = vcat [ ptext (sLit "The following variables have types that mention") <+> what
716 , nest 2 (vcat env_sigs) ]
718 findGlobals :: ReportErrCtxt
720 -> TcM (TidyEnv, [SDoc])
723 = do { lcl_ty_env <- case cec_encl ctxt of
725 (i:_) -> return (ic_env i)
726 ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) }
728 go tidy_env acc [] = return (tidy_env, acc)
729 go tidy_env acc (thing : things) = do
730 (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing
732 Just d -> go tidy_env1 (d:acc) things
733 Nothing -> go tidy_env1 acc things
735 ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
737 -----------------------
738 find_thing :: TidyEnv -> (TcType -> Bool)
739 -> TcTyThing -> TcM (TidyEnv, Maybe SDoc)
740 find_thing tidy_env ignore_it (ATcId { tct_id = id })
741 = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id)
742 ; if ignore_it tidy_ty then
743 return (tidy_env, Nothing)
745 { let msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty
746 , nest 2 (parens (ptext (sLit "bound at") <+>
747 ppr (getSrcLoc id)))]
748 ; return (tidy_env', Just msg) } }
750 find_thing tidy_env ignore_it (ATyVar tv ty)
751 = do { (tidy_env1, tidy_ty) <- zonkTidyTcType tidy_env ty
752 ; if ignore_it tidy_ty then
753 return (tidy_env, Nothing)
755 { let -- The name tv is scoped, so we don't need to tidy it
756 msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff
759 eq_stuff | Just tv' <- tcGetTyVar_maybe tidy_ty
760 , getOccName tv == getOccName tv' = empty
761 | otherwise = equals <+> ppr tidy_ty
762 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
763 bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
765 ; return (tidy_env1, Just msg) } }
767 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
769 warnDefaulting :: [FlavoredEvVar] -> Type -> TcM ()
770 warnDefaulting wanteds default_ty
771 = do { warn_default <- doptM Opt_WarnTypeDefaults
772 ; env0 <- tcInitTidyEnv
773 ; let wanted_bag = listToBag wanteds
774 tidy_env = tidyFreeTyVars env0 $
775 tyVarsOfEvVarXs wanted_bag
776 tidy_wanteds = mapBag (tidyFlavoredEvVar tidy_env) wanted_bag
777 (loc, ppr_wanteds) = pprWithArising (map get_wev (bagToList tidy_wanteds))
778 warn_msg = hang (ptext (sLit "Defaulting the following constraint(s) to type")
779 <+> quotes (ppr default_ty))
781 ; setCtLoc loc $ warnTc warn_default warn_msg }
783 get_wev (EvVarX ev (Wanted loc)) = EvVarX ev loc -- Yuk
784 get_wev ev = pprPanic "warnDefaulting" (ppr ev)
787 Note [Runtime skolems]
788 ~~~~~~~~~~~~~~~~~~~~~~
789 We want to give a reasonably helpful error message for ambiguity
790 arising from *runtime* skolems in the debugger. These
791 are created by in RtClosureInspect.zonkRTTIType.
793 %************************************************************************
795 Error from the canonicaliser
796 These ones are called *during* constraint simplification
798 %************************************************************************
801 solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a
802 solverDepthErrorTcS depth stack
803 | null stack -- Shouldn't happen unless you say -fcontext-stack=0
804 = wrapErrTcS $ failWith msg
807 setCtFlavorLoc (cc_flavor top_item) $
808 do { ev_vars <- mapM (zonkEvVar . cc_id) stack
809 ; env0 <- tcInitTidyEnv
810 ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfEvVars ev_vars)
811 tidy_ev_vars = map (tidyEvVar tidy_env) ev_vars
812 ; failWithTcM (tidy_env, hang msg 2 (pprEvVars tidy_ev_vars)) }
814 top_item = head stack
815 msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
816 , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
818 flattenForAllErrorTcS :: CtFlavor -> TcType -> Bag CanonicalCt -> TcS a
819 flattenForAllErrorTcS fl ty _bad_eqs
822 do { env0 <- tcInitTidyEnv
823 ; let (env1, ty') = tidyOpenType env0 ty
824 msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:")
826 ; failWithTcM (env1, msg) }
829 %************************************************************************
833 %************************************************************************
836 setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
837 setCtFlavorLoc (Wanted loc) thing = setCtLoc loc thing
838 setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing
839 setCtFlavorLoc (Given loc) thing = setCtLoc loc thing
842 %************************************************************************
846 %************************************************************************
849 zonkTidyTcType :: TidyEnv -> TcType -> TcM (TidyEnv, TcType)
850 zonkTidyTcType env ty = do { ty' <- zonkTcType ty
851 ; return (tidyOpenType env ty') }
853 zonkTidyOrigin :: ReportErrCtxt -> CtOrigin -> TcM CtOrigin
854 zonkTidyOrigin ctxt (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp }))
855 = do { (env1, act') <- zonkTidyTcType (cec_tidy ctxt) act
856 ; (_env2, exp') <- zonkTidyTcType env1 exp
857 ; return (TypeEqOrigin (UnifyOrigin { uo_actual = act', uo_expected = exp' })) }
858 -- Drop the returned env on the floor; we may conceivably thereby get
859 -- inconsistent naming between uses of this function
860 zonkTidyOrigin _ orig = return orig