11 #include "HsVersions.h"
23 import Id ( idType, evVarPred )
29 import ListSetOps( equivClasses )
34 import StaticFlags( opt_PprStyle_Debug )
35 import Data.List( partition )
36 import Control.Monad( when, unless )
39 %************************************************************************
41 \section{Errors and contexts}
43 %************************************************************************
45 ToDo: for these error messages, should we note the location as coming
46 from the insts, or just whatever seems to be around in the monad just
50 reportUnsolved :: WantedConstraints -> TcM ()
55 = do { -- Zonk to un-flatten any flatten-skols
56 ; wanted <- zonkWC wanted
58 ; env0 <- tcInitTidyEnv
59 ; let tidy_env = tidyFreeTyVars env0 free_tvs
60 free_tvs = tyVarsOfWC wanted
61 err_ctxt = CEC { cec_encl = []
62 , cec_insol = insolubleWC wanted
64 , cec_tidy = tidy_env }
65 tidy_wanted = tidyWC tidy_env wanted
67 ; traceTc "reportUnsolved" (ppr tidy_wanted)
69 ; reportTidyWanteds err_ctxt tidy_wanted }
71 --------------------------------------------
73 --------------------------------------------
76 = CEC { cec_encl :: [Implication] -- Enclosing implications
79 , cec_extra :: SDoc -- Add this to each error message
80 , cec_insol :: Bool -- True <=> we are reporting insoluble errors only
81 -- Main effect: don't say "Cannot deduce..."
82 -- when reporting equality errors; see misMatchOrCND
85 reportTidyImplic :: ReportErrCtxt -> Implication -> TcM ()
86 reportTidyImplic ctxt implic
87 | BracketSkol <- ctLocOrigin (ic_loc implic)
88 , not insoluble -- For Template Haskell brackets report only
89 = return () -- definite errors. The whole thing will be re-checked
90 -- later when we plug it in, and meanwhile there may
91 -- certainly be un-satisfied constraints
94 = reportTidyWanteds ctxt' (ic_wanted implic)
96 insoluble = ic_insol implic
97 ctxt' = ctxt { cec_encl = implic : cec_encl ctxt
98 , cec_insol = insoluble }
100 reportTidyWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
101 reportTidyWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = implics })
102 | cec_insol ctxt -- If there are any insolubles, report only them
103 -- because they are unconditionally wrong
104 -- Moreover, if any of the insolubles are givens, stop right there
105 -- ignoring nested errors, because the code is inaccessible
106 = do { let (given, other) = partitionBag (isGiven . evVarX) insols
107 insol_implics = filterBag ic_insol implics
108 ; if isEmptyBag given
109 then do { mapBagM_ (reportInsoluble ctxt) other
110 ; mapBagM_ (reportTidyImplic ctxt) insol_implics }
111 else mapBagM_ (reportInsoluble ctxt) given }
113 | otherwise -- No insoluble ones
114 = ASSERT( isEmptyBag insols )
115 do { let (ambigs, non_ambigs) = partition is_ambiguous (bagToList flats)
116 (tv_eqs, others) = partition is_tv_eq non_ambigs
118 ; groupErrs (reportEqErrs ctxt) tv_eqs
119 ; when (null tv_eqs) $ groupErrs (reportFlat ctxt) others
120 ; mapBagM_ (reportTidyImplic ctxt) implics
122 -- Only report ambiguity if no other errors (at all) happened
123 -- See Note [Avoiding spurious errors] in TcSimplify
124 ; ifErrsM (return ()) $ reportAmbigErrs ctxt skols ambigs }
126 skols = foldr (unionVarSet . ic_skols) emptyVarSet (cec_encl ctxt)
128 -- Report equalities of form (a~ty) first. They are usually
129 -- skolem-equalities, and they cause confusing knock-on
130 -- effects in other errors; see test T4093b.
131 is_tv_eq c | EqPred ty1 ty2 <- evVarOfPred c
132 = tcIsTyVarTy ty1 || tcIsTyVarTy ty2
135 -- Treat it as "ambiguous" if
136 -- (a) it is a class constraint
137 -- (b) it constrains only type variables
138 -- (else we'd prefer to report it as "no instance for...")
139 -- (c) it mentions type variables that are not skolems
140 is_ambiguous d = isTyVarClassPred pred
141 && not (tyVarsOfPred pred `subVarSet` skols)
145 reportInsoluble :: ReportErrCtxt -> FlavoredEvVar -> TcM ()
146 reportInsoluble ctxt (EvVarX ev flav)
147 | EqPred ty1 ty2 <- evVarPred ev
148 = setCtFlavorLoc flav $
149 do { let ctxt2 = ctxt { cec_extra = cec_extra ctxt $$ inaccessible_msg }
150 ; reportEqErr ctxt2 ty1 ty2 }
152 = pprPanic "reportInsoluble" (pprEvVarWithType ev)
154 inaccessible_msg | Given loc <- flav
155 = hang (ptext (sLit "Inaccessible code in"))
156 2 (ppr (ctLocOrigin loc))
159 reportFlat :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
160 -- The [PredType] are already tidied
161 reportFlat ctxt flats origin
162 = do { unless (null dicts) $ reportDictErrs ctxt dicts origin
163 ; unless (null eqs) $ reportEqErrs ctxt eqs origin
164 ; unless (null ips) $ reportIPErrs ctxt ips origin
165 ; ASSERT( null others ) return () }
167 (dicts, non_dicts) = partition isClassPred flats
168 (eqs, non_eqs) = partition isEqPred non_dicts
169 (ips, others) = partition isIPPred non_eqs
171 --------------------------------------------
173 --------------------------------------------
175 groupErrs :: ([PredType] -> CtOrigin -> TcM ()) -- Deal with one group
176 -> [WantedEvVar] -- Unsolved wanteds
178 -- Group together insts with the same origin
179 -- We want to report them together in error messages
183 groupErrs report_err (wanted : wanteds)
184 = do { setCtLoc the_loc $
185 report_err the_vars (ctLocOrigin the_loc)
186 ; groupErrs report_err others }
188 the_loc = evVarX wanted
189 the_key = mk_key the_loc
190 the_vars = map evVarOfPred (wanted:friends)
191 (friends, others) = partition is_friend wanteds
192 is_friend friend = mk_key (evVarX friend) `same_key` the_key
194 mk_key :: WantedLoc -> (SrcSpan, CtOrigin)
195 mk_key loc = (ctLocSpan loc, ctLocOrigin loc)
197 same_key (s1, o1) (s2, o2) = s1==s2 && o1 `same_orig` o2
198 same_orig (OccurrenceOf n1) (OccurrenceOf n2) = n1==n2
199 same_orig ScOrigin ScOrigin = True
200 same_orig DerivOrigin DerivOrigin = True
201 same_orig DefaultOrigin DefaultOrigin = True
202 same_orig _ _ = False
205 -- Add the "arising from..." part to a message about bunch of dicts
206 addArising :: CtOrigin -> SDoc -> SDoc
207 addArising orig msg = msg $$ nest 2 (pprArising orig)
209 pprWithArising :: [WantedEvVar] -> (WantedLoc, SDoc)
210 -- Print something like
211 -- (Eq a) arising from a use of x at y
212 -- (Show a) arising from a use of p at q
213 -- Also return a location for the error message
215 = panic "pprWithArising"
216 pprWithArising [EvVarX ev loc]
217 = (loc, pprEvVarTheta [ev] <+> pprArising (ctLocOrigin loc))
218 pprWithArising ev_vars
219 = (first_loc, vcat (map ppr_one ev_vars))
221 first_loc = evVarX (head ev_vars)
222 ppr_one (EvVarX v loc)
223 = parens (pprPredTy (evVarPred v)) <+> pprArisingAt loc
225 addErrorReport :: ReportErrCtxt -> SDoc -> TcM ()
226 addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt)
228 pprErrCtxtLoc :: ReportErrCtxt -> SDoc
230 = case map (ctLocOrigin . ic_loc) (cec_encl ctxt) of
231 [] -> ptext (sLit "the top level") -- Should not happen
232 (orig:origs) -> ppr_skol orig $$
233 vcat [ ptext (sLit "or") <+> ppr_skol orig | orig <- origs ]
235 ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc)
236 ppr_skol skol_info = ppr skol_info
238 getUserGivens :: ReportErrCtxt -> [([EvVar], GivenLoc)]
239 -- One item for each enclosing implication
240 getUserGivens (CEC {cec_encl = ctxt})
242 [ (givens', loc) | Implic {ic_given = givens, ic_loc = loc} <- ctxt
243 , let givens' = get_user_givens givens
244 , not (null givens') ]
246 get_user_givens givens | opt_PprStyle_Debug = givens
247 | otherwise = filterOut isSilentEvVar givens
248 -- In user mode, don't show the "silent" givens, used for
249 -- the "self" dictionary and silent superclass arguments for dfuns
254 %************************************************************************
256 Implicit parameter errors
258 %************************************************************************
261 reportIPErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
262 reportIPErrs ctxt ips orig
263 = addErrorReport ctxt msg
265 givens = getUserGivens ctxt
268 sep [ ptext (sLit "Unbound implicit parameter") <> plural ips
269 , nest 2 (pprTheta ips) ]
271 = couldNotDeduce givens (ips, orig)
275 %************************************************************************
279 %************************************************************************
282 reportEqErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
283 -- The [PredType] are already tidied
284 reportEqErrs ctxt eqs orig
285 = do { orig' <- zonkTidyOrigin ctxt orig
286 ; mapM_ (report_one orig') eqs }
288 report_one orig (EqPred ty1 ty2)
289 = do { let extra = getWantedEqExtra orig ty1 ty2
290 ctxt' = ctxt { cec_extra = extra $$ cec_extra ctxt }
291 ; reportEqErr ctxt' ty1 ty2 }
293 = pprPanic "reportEqErrs" (ppr pred)
295 getWantedEqExtra :: CtOrigin -> TcType -> TcType -> SDoc
296 getWantedEqExtra (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp }))
298 -- If the types in the error message are the same as the types we are unifying,
299 -- don't add the extra expected/actual message
300 | act `eqType` ty1 && exp `eqType` ty2 = empty
301 | exp `eqType` ty1 && act `eqType` ty2 = empty
302 | otherwise = mkExpectedActualMsg act exp
304 getWantedEqExtra orig _ _ = pprArising orig
306 reportEqErr :: ReportErrCtxt -> TcType -> TcType -> TcM ()
307 -- ty1 and ty2 are already tidied
308 reportEqErr ctxt ty1 ty2
309 | Just tv1 <- tcGetTyVar_maybe ty1 = reportTyVarEqErr ctxt tv1 ty2
310 | Just tv2 <- tcGetTyVar_maybe ty2 = reportTyVarEqErr ctxt tv2 ty1
312 | otherwise -- Neither side is a type variable
313 -- Since the unsolved constraint is canonical,
314 -- it must therefore be of form (F tys ~ ty)
315 = addErrorReport ctxt (misMatchOrCND ctxt ty1 ty2 $$ mkTyFunInfoMsg ty1 ty2)
318 reportTyVarEqErr :: ReportErrCtxt -> TcTyVar -> TcType -> TcM ()
319 -- tv1 and ty2 are already tidied
320 reportTyVarEqErr ctxt tv1 ty2
322 , Just tv2 <- tcGetTyVar_maybe ty2
324 = -- sk ~ alpha: swap
325 reportTyVarEqErr ctxt tv2 ty1
328 = -- sk ~ ty, where ty isn't a meta-tyvar: mis-match
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) }
377 | otherwise -- This can happen, by a recursive decomposition of frozen
378 -- occurs check constraints
379 -- Example: alpha ~ T Int alpha has frozen.
380 -- Then alpha gets unified to T beta gamma
381 -- So now we have T beta gamma ~ T Int (T beta gamma)
382 -- Decompose to (beta ~ Int, gamma ~ T beta gamma)
383 -- The (gamma ~ T beta gamma) is the occurs check, but
384 -- the (beta ~ Int) isn't an error at all. So return ()
388 is_meta1 = isMetaTyVar tv1
393 mkTyFunInfoMsg :: TcType -> TcType -> SDoc
394 -- See Note [Non-injective type functions]
395 mkTyFunInfoMsg ty1 ty2
396 | Just (tc1,_) <- tcSplitTyConApp_maybe ty1
397 , Just (tc2,_) <- tcSplitTyConApp_maybe ty2
398 , tc1 == tc2, isSynFamilyTyCon tc1
399 = ptext (sLit "NB:") <+> quotes (ppr tc1)
400 <+> ptext (sLit "is a type function") <> (pp_inj tc1)
403 pp_inj tc | isInjectiveTyCon tc = empty
404 | otherwise = ptext (sLit (", and may not be injective"))
406 misMatchOrCND :: ReportErrCtxt -> TcType -> TcType -> SDoc
407 misMatchOrCND ctxt ty1 ty2
408 | cec_insol ctxt = misMatchMsg ty1 ty2 -- If the equality is unconditionally
409 -- insoluble, don't report the context
410 | null givens = misMatchMsg ty1 ty2
411 | otherwise = couldNotDeduce givens ([EqPred ty1 ty2], orig)
413 givens = getUserGivens ctxt
414 orig = TypeEqOrigin (UnifyOrigin ty1 ty2)
416 couldNotDeduce :: [([EvVar], GivenLoc)] -> (ThetaType, CtOrigin) -> SDoc
417 couldNotDeduce givens (wanteds, orig)
418 = vcat [ hang (ptext (sLit "Could not deduce") <+> pprTheta wanteds)
425 (g:gs) -> ppr_given (ptext (sLit "from the context")) g
426 : map (ppr_given (ptext (sLit "or from"))) gs
428 ppr_given herald (gs,loc)
429 = hang (herald <+> pprEvVarTheta gs)
430 2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin loc)
431 , ptext (sLit "at") <+> ppr (ctLocSpan loc)])
433 addExtraInfo :: ReportErrCtxt -> TcType -> TcType -> ReportErrCtxt
434 -- Add on extra info about the types themselves
435 -- NB: The types themselves are already tidied
436 addExtraInfo ctxt ty1 ty2
437 = ctxt { cec_extra = nest 2 (extra1 $$ extra2) $$ cec_extra ctxt }
439 extra1 = typeExtraInfoMsg (cec_encl ctxt) ty1
440 extra2 = typeExtraInfoMsg (cec_encl ctxt) ty2
442 misMatchMsg :: TcType -> TcType -> SDoc -- Types are already tidy
443 misMatchMsg ty1 ty2 = sep [ ptext (sLit "Couldn't match type") <+> quotes (ppr ty1)
444 , nest 15 $ ptext (sLit "with") <+> quotes (ppr ty2)]
446 kindErrorMsg :: TcType -> TcType -> SDoc -- Types are already tidy
448 = vcat [ ptext (sLit "Kind incompatibility when matching types:")
449 , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1
450 , ppr ty2 <+> dcolon <+> ppr k2 ]) ]
455 typeExtraInfoMsg :: [Implication] -> Type -> SDoc
456 -- Shows a bit of extra info about skolem constants
457 typeExtraInfoMsg implics ty
458 | Just tv <- tcGetTyVar_maybe ty
461 = pprSkolTvBinding implics tv
463 typeExtraInfoMsg _ _ = empty -- Normal case
466 unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc)
467 unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env
468 = do { (env1, act_ty') <- zonkTidyTcType tidy_env act_ty
469 ; (env2, exp_ty') <- zonkTidyTcType env1 exp_ty
470 ; return (env2, mkExpectedActualMsg act_ty' exp_ty') }
472 mkExpectedActualMsg :: Type -> Type -> SDoc
473 mkExpectedActualMsg act_ty exp_ty
474 = vcat [ text "Expected type" <> colon <+> ppr exp_ty
475 , text " Actual type" <> colon <+> ppr act_ty ]
478 Note [Non-injective type functions]
479 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
480 It's very confusing to get a message like
481 Couldn't match expected type `Depend s'
482 against inferred type `Depend s1'
483 so mkTyFunInfoMsg adds:
484 NB: `Depend' is type function, and hence may not be injective
486 Warn of loopy local equalities that were dropped.
489 %************************************************************************
493 %************************************************************************
496 reportDictErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
497 reportDictErrs ctxt wanteds orig
498 = do { inst_envs <- tcGetInstEnvs
499 ; non_overlaps <- mapMaybeM (reportOverlap ctxt inst_envs orig) wanteds
500 ; unless (null non_overlaps) $
501 addErrorReport ctxt (mk_no_inst_err non_overlaps) }
503 mk_no_inst_err :: [PredType] -> SDoc
504 mk_no_inst_err wanteds
505 | null givens -- Top level
506 = vcat [ addArising orig $
507 ptext (sLit "No instance") <> plural min_wanteds
508 <+> ptext (sLit "for") <+> pprTheta min_wanteds
509 , show_fixes (fixes2 ++ fixes3) ]
512 = vcat [ couldNotDeduce givens (min_wanteds, orig)
513 , show_fixes (fix1 : (fixes2 ++ fixes3)) ]
515 givens = getUserGivens ctxt
516 min_wanteds = mkMinimalBySCs wanteds
517 fix1 = sep [ ptext (sLit "add") <+> pprTheta min_wanteds
518 <+> ptext (sLit "to the context of")
519 , nest 2 $ pprErrCtxtLoc ctxt ]
521 fixes2 = case instance_dicts of
523 [_] -> [sep [ptext (sLit "add an instance declaration for"),
524 pprTheta instance_dicts]]
525 _ -> [sep [ptext (sLit "add instance declarations for"),
526 pprTheta instance_dicts]]
527 fixes3 = case orig of
528 DerivOrigin -> [drv_fix]
531 instance_dicts = filterOut isTyVarClassPred min_wanteds
532 -- Insts for which it is worth suggesting an adding an
533 -- instance declaration. Exclude tyvar dicts.
535 drv_fix = vcat [ptext (sLit "use a standalone 'deriving instance' declaration,"),
536 nest 2 $ ptext (sLit "so you can specify the instance context yourself")]
538 show_fixes :: [SDoc] -> SDoc
539 show_fixes [] = empty
540 show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"),
541 nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
543 reportOverlap :: ReportErrCtxt -> (InstEnv,InstEnv) -> CtOrigin
544 -> PredType -> TcM (Maybe PredType)
545 -- Report an overlap error if this class constraint results
546 -- from an overlap (returning Nothing), otherwise return (Just pred)
547 reportOverlap ctxt inst_envs orig pred@(ClassP clas tys)
548 = do { tys_flat <- mapM quickFlattenTy tys
549 -- Note [Flattening in error message generation]
551 ; case lookupInstEnv inst_envs clas tys_flat of
552 ([], _) -> return (Just pred) -- No match
553 -- The case of exactly one match and no unifiers means a
554 -- successful lookup. That can't happen here, because dicts
555 -- only end up here if they didn't match in Inst.lookupInst
557 | debugIsOn -> pprPanic "check_overlap" (ppr pred)
558 res -> do { addErrorReport ctxt (mk_overlap_msg res)
561 mk_overlap_msg (matches, unifiers)
562 = ASSERT( not (null matches) )
563 vcat [ addArising orig (ptext (sLit "Overlapping instances for")
565 , sep [ptext (sLit "Matching instances") <> colon,
566 nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
567 , if not (isSingleton matches)
568 then -- Two or more matches
570 else -- One match, plus some unifiers
571 ASSERT( not (null unifiers) )
572 parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
573 quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
574 ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
575 ptext (sLit "when compiling the other instance declarations")])]
577 ispecs = [ispec | (ispec, _) <- matches]
579 reportOverlap _ _ _ _ = panic "reportOverlap" -- Not a ClassP
581 ----------------------
582 quickFlattenTy :: TcType -> TcM TcType
583 -- See Note [Flattening in error message generation]
584 quickFlattenTy ty | Just ty' <- tcView ty = quickFlattenTy ty'
585 quickFlattenTy ty@(TyVarTy {}) = return ty
586 quickFlattenTy ty@(ForAllTy {}) = return ty -- See
587 quickFlattenTy ty@(PredTy {}) = return ty -- Note [Quick-flatten polytypes]
588 -- Don't flatten because of the danger or removing a bound variable
589 quickFlattenTy (AppTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
590 ; fy2 <- quickFlattenTy ty2
591 ; return (AppTy fy1 fy2) }
592 quickFlattenTy (FunTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
593 ; fy2 <- quickFlattenTy ty2
594 ; return (FunTy fy1 fy2) }
595 quickFlattenTy (TyConApp tc tys)
596 | not (isSynFamilyTyCon tc)
597 = do { fys <- mapM quickFlattenTy tys
598 ; return (TyConApp tc fys) }
600 = do { let (funtys,resttys) = splitAt (tyConArity tc) tys
601 -- Ignore the arguments of the type family funtys
602 ; v <- newMetaTyVar TauTv (typeKind (TyConApp tc funtys))
603 ; flat_resttys <- mapM quickFlattenTy resttys
604 ; return (foldl AppTy (mkTyVarTy v) flat_resttys) }
607 Note [Flattening in error message generation]
608 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
609 Consider (C (Maybe (F x))), where F is a type function, and we have
611 C (Maybe Int) and C (Maybe a)
612 Since (F x) might turn into Int, this is an overlap situation, and
613 indeed (because of flattening) the main solver will have refrained
614 from solving. But by the time we get to error message generation, we've
615 un-flattened the constraint. So we must *re*-flatten it before looking
616 up in the instance environment, lest we only report one matching
617 instance when in fact there are two.
619 Re-flattening is pretty easy, because we don't need to keep track of
620 evidence. We don't re-use the code in TcCanonical because that's in
621 the TcS monad, and we are in TcM here.
623 Note [Quick-flatten polytypes]
624 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
625 If we see C (Ix a => blah) or C (forall a. blah) we simply refrain from
626 flattening any further. After all, there can be no instance declarations
627 that match such things. And flattening under a for-all is problematic
628 anyway; consider C (forall a. F a)
631 reportAmbigErrs :: ReportErrCtxt -> TcTyVarSet -> [WantedEvVar] -> TcM ()
632 reportAmbigErrs ctxt skols ambigs
633 -- Divide into groups that share a common set of ambiguous tyvars
634 = mapM_ report (equivClasses cmp ambigs_w_tvs)
636 ambigs_w_tvs = [ (d, varSetElems (tyVarsOfEvVarX d `minusVarSet` skols))
638 cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
640 report :: [(WantedEvVar, [TcTyVar])] -> TcM ()
643 do { let main_msg = sep [ text "Ambiguous type variable" <> plural tvs
644 <+> pprQuotedList tvs
645 <+> text "in the constraint" <> plural pairs <> colon
646 , nest 2 pp_wanteds ]
647 ; (tidy_env, mono_msg) <- mkMonomorphismMsg ctxt tvs
648 ; addErrTcM (tidy_env, main_msg $$ mono_msg) }
651 (loc, pp_wanteds) = pprWithArising (map fst pairs)
653 mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc)
654 -- There's an error with these Insts; if they have free type variables
655 -- it's probably caused by the monomorphism restriction.
656 -- Try to identify the offending variable
657 -- ASSUMPTION: the Insts are fully zonked
658 mkMonomorphismMsg ctxt inst_tvs
659 = do { dflags <- getDOpts
660 ; traceTc "Mono" (vcat (map (pprSkolTvBinding (cec_encl ctxt)) inst_tvs))
661 ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
662 ; return (tidy_env, mk_msg dflags docs) }
664 mk_msg _ _ | any isRuntimeUnkSkol inst_tvs -- See Note [Runtime skolems]
665 = vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
666 (pprWithCommas ppr inst_tvs),
667 ptext (sLit "Use :print or :force to determine these types")]
668 mk_msg _ [] = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)")
669 -- This happens in things like
670 -- f x = show (read "foo")
671 -- where monomorphism doesn't play any role
673 = vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"),
675 monomorphism_fix dflags]
677 monomorphism_fix :: DynFlags -> SDoc
678 monomorphism_fix dflags
679 = ptext (sLit "Probable fix:") <+> vcat
680 [ptext (sLit "give these definition(s) an explicit type signature"),
681 if xopt Opt_MonomorphismRestriction dflags
682 then ptext (sLit "or use -XNoMonomorphismRestriction")
683 else empty] -- Only suggest adding "-XNoMonomorphismRestriction"
684 -- if it is not already set!
687 pprSkolTvBinding :: [Implication] -> TcTyVar -> SDoc
688 -- Print info about the binding of a skolem tyvar,
689 -- or nothing if we don't have anything useful to say
690 pprSkolTvBinding implics tv
691 | isTcTyVar tv = quotes (ppr tv) <+> ppr_details (tcTyVarDetails tv)
692 | otherwise = quotes (ppr tv) <+> ppr_skol (getSkolemInfo implics tv)
694 ppr_details (SkolemTv {}) = ppr_skol (getSkolemInfo implics tv)
695 ppr_details (FlatSkol {}) = ptext (sLit "is a flattening type variable")
696 ppr_details (RuntimeUnk {}) = ptext (sLit "is an interactive-debugger skolem")
697 ppr_details (MetaTv (SigTv n) _) = ptext (sLit "is bound by the type signature for")
699 ppr_details (MetaTv _ _) = ptext (sLit "is a meta type variable")
702 ppr_skol UnkSkol = ptext (sLit "is an unknown type variable") -- Unhelpful
703 ppr_skol RuntimeUnkSkol = ptext (sLit "is an unknown runtime type")
704 ppr_skol info = sep [ptext (sLit "is a rigid type variable bound by"),
706 ptext (sLit "at") <+> ppr (getSrcLoc tv)]]
708 getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo
710 = WARN( True, ptext (sLit "No skolem info:") <+> ppr tv )
712 getSkolemInfo (implic:implics) tv
713 | tv `elemVarSet` ic_skols implic = ctLocOrigin (ic_loc implic)
714 | otherwise = getSkolemInfo implics tv
716 -----------------------
717 -- findGlobals looks at the value environment and finds values whose
718 -- types mention any of the offending type variables. It has to be
719 -- careful to zonk the Id's type first, so it has to be in the monad.
720 -- We must be careful to pass it a zonked type variable, too.
722 mkEnvSigMsg :: SDoc -> [SDoc] -> SDoc
723 mkEnvSigMsg what env_sigs
724 | null env_sigs = empty
725 | otherwise = vcat [ ptext (sLit "The following variables have types that mention") <+> what
726 , nest 2 (vcat env_sigs) ]
728 findGlobals :: ReportErrCtxt
730 -> TcM (TidyEnv, [SDoc])
733 = do { lcl_ty_env <- case cec_encl ctxt of
735 (i:_) -> return (ic_env i)
736 ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) }
738 go tidy_env acc [] = return (tidy_env, acc)
739 go tidy_env acc (thing : things) = do
740 (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing
742 Just d -> go tidy_env1 (d:acc) things
743 Nothing -> go tidy_env1 acc things
745 ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
747 -----------------------
748 find_thing :: TidyEnv -> (TcType -> Bool)
749 -> TcTyThing -> TcM (TidyEnv, Maybe SDoc)
750 find_thing tidy_env ignore_it (ATcId { tct_id = id })
751 = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id)
752 ; if ignore_it tidy_ty then
753 return (tidy_env, Nothing)
755 { let msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty
756 , nest 2 (parens (ptext (sLit "bound at") <+>
757 ppr (getSrcLoc id)))]
758 ; return (tidy_env', Just msg) } }
760 find_thing tidy_env ignore_it (ATyVar tv ty)
761 = do { (tidy_env1, tidy_ty) <- zonkTidyTcType tidy_env ty
762 ; if ignore_it tidy_ty then
763 return (tidy_env, Nothing)
765 { let -- The name tv is scoped, so we don't need to tidy it
766 msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff
769 eq_stuff | Just tv' <- tcGetTyVar_maybe tidy_ty
770 , getOccName tv == getOccName tv' = empty
771 | otherwise = equals <+> ppr tidy_ty
772 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
773 bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
775 ; return (tidy_env1, Just msg) } }
777 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
779 warnDefaulting :: [FlavoredEvVar] -> Type -> TcM ()
780 warnDefaulting wanteds default_ty
781 = do { warn_default <- doptM Opt_WarnTypeDefaults
782 ; env0 <- tcInitTidyEnv
783 ; let wanted_bag = listToBag wanteds
784 tidy_env = tidyFreeTyVars env0 $
785 tyVarsOfEvVarXs wanted_bag
786 tidy_wanteds = mapBag (tidyFlavoredEvVar tidy_env) wanted_bag
787 (loc, ppr_wanteds) = pprWithArising (map get_wev (bagToList tidy_wanteds))
788 warn_msg = hang (ptext (sLit "Defaulting the following constraint(s) to type")
789 <+> quotes (ppr default_ty))
791 ; setCtLoc loc $ warnTc warn_default warn_msg }
793 get_wev (EvVarX ev (Wanted loc)) = EvVarX ev loc -- Yuk
794 get_wev ev = pprPanic "warnDefaulting" (ppr ev)
797 Note [Runtime skolems]
798 ~~~~~~~~~~~~~~~~~~~~~~
799 We want to give a reasonably helpful error message for ambiguity
800 arising from *runtime* skolems in the debugger. These
801 are created by in RtClosureInspect.zonkRTTIType.
803 %************************************************************************
805 Error from the canonicaliser
806 These ones are called *during* constraint simplification
808 %************************************************************************
811 solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a
812 solverDepthErrorTcS depth stack
813 | null stack -- Shouldn't happen unless you say -fcontext-stack=0
814 = wrapErrTcS $ failWith msg
817 setCtFlavorLoc (cc_flavor top_item) $
818 do { ev_vars <- mapM (zonkEvVar . cc_id) stack
819 ; env0 <- tcInitTidyEnv
820 ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfEvVars ev_vars)
821 tidy_ev_vars = map (tidyEvVar tidy_env) ev_vars
822 ; failWithTcM (tidy_env, hang msg 2 (pprEvVars tidy_ev_vars)) }
824 top_item = head stack
825 msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
826 , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
828 flattenForAllErrorTcS :: CtFlavor -> TcType -> Bag CanonicalCt -> TcS a
829 flattenForAllErrorTcS fl ty _bad_eqs
832 do { env0 <- tcInitTidyEnv
833 ; let (env1, ty') = tidyOpenType env0 ty
834 msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:")
836 ; failWithTcM (env1, msg) }
839 %************************************************************************
843 %************************************************************************
846 setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
847 setCtFlavorLoc (Wanted loc) thing = setCtLoc loc thing
848 setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing
849 setCtFlavorLoc (Given loc) thing = setCtLoc loc thing
852 %************************************************************************
856 %************************************************************************
859 zonkTidyTcType :: TidyEnv -> TcType -> TcM (TidyEnv, TcType)
860 zonkTidyTcType env ty = do { ty' <- zonkTcType ty
861 ; return (tidyOpenType env ty') }
863 zonkTidyOrigin :: ReportErrCtxt -> CtOrigin -> TcM CtOrigin
864 zonkTidyOrigin ctxt (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp }))
865 = do { (env1, act') <- zonkTidyTcType (cec_tidy ctxt) act
866 ; (_env2, exp') <- zonkTidyTcType env1 exp
867 ; return (TypeEqOrigin (UnifyOrigin { uo_actual = act', uo_expected = exp' })) }
868 -- Drop the returned env on the floor; we may conceivably thereby get
869 -- inconsistent naming between uses of this function
870 zonkTidyOrigin _ orig = return orig