11 #include "HsVersions.h"
31 import ListSetOps( equivClasses )
36 import StaticFlags( opt_PprStyle_Debug )
37 import Data.List( partition )
38 import Control.Monad( when, unless )
41 %************************************************************************
43 \section{Errors and contexts}
45 %************************************************************************
47 ToDo: for these error messages, should we note the location as coming
48 from the insts, or just whatever seems to be around in the monad just
52 reportUnsolved :: WantedConstraints -> TcM ()
57 = do { -- Zonk to un-flatten any flatten-skols
58 ; wanted <- zonkWC wanted
60 ; env0 <- tcInitTidyEnv
61 ; let tidy_env = tidyFreeTyVars env0 free_tvs
62 free_tvs = tyVarsOfWC wanted
63 err_ctxt = CEC { cec_encl = []
64 , cec_insol = insolubleWC wanted
66 , cec_tidy = tidy_env }
67 tidy_wanted = tidyWC tidy_env wanted
69 ; traceTc "reportUnsolved" (ppr tidy_wanted)
71 ; reportTidyWanteds err_ctxt tidy_wanted }
73 --------------------------------------------
75 --------------------------------------------
78 = CEC { cec_encl :: [Implication] -- Enclosing implications
81 , cec_extra :: SDoc -- Add this to each error message
82 , cec_insol :: Bool -- True <=> we are reporting insoluble errors only
83 -- Main effect: don't say "Cannot deduce..."
84 -- when reporting equality errors; see misMatchOrCND
87 reportTidyImplic :: ReportErrCtxt -> Implication -> TcM ()
88 reportTidyImplic ctxt implic
89 | BracketSkol <- ctLocOrigin (ic_loc implic)
90 , not insoluble -- For Template Haskell brackets report only
91 = return () -- definite errors. The whole thing will be re-checked
92 -- later when we plug it in, and meanwhile there may
93 -- certainly be un-satisfied constraints
96 = reportTidyWanteds ctxt' (ic_wanted implic)
98 insoluble = ic_insol implic
99 ctxt' = ctxt { cec_encl = implic : cec_encl ctxt
100 , cec_insol = insoluble }
102 reportTidyWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
103 reportTidyWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = implics })
104 | cec_insol ctxt -- If there are any insolubles, report only them
105 -- because they are unconditionally wrong
106 -- Moreover, if any of the insolubles are givens, stop right there
107 -- ignoring nested errors, because the code is inaccessible
108 = do { let (given, other) = partitionBag (isGiven . evVarX) insols
109 insol_implics = filterBag ic_insol implics
110 ; if isEmptyBag given
111 then do { mapBagM_ (reportInsoluble ctxt) other
112 ; mapBagM_ (reportTidyImplic ctxt) insol_implics }
113 else mapBagM_ (reportInsoluble ctxt) given }
115 | otherwise -- No insoluble ones
116 = ASSERT( isEmptyBag insols )
117 do { let (ambigs, non_ambigs) = partition is_ambiguous (bagToList flats)
118 (tv_eqs, others) = partition is_tv_eq non_ambigs
120 ; groupErrs (reportEqErrs ctxt) tv_eqs
121 ; when (null tv_eqs) $ groupErrs (reportFlat ctxt) others
122 ; mapBagM_ (reportTidyImplic ctxt) implics
124 -- Only report ambiguity if no other errors (at all) happened
125 -- See Note [Avoiding spurious errors] in TcSimplify
126 ; ifErrsM (return ()) $ reportAmbigErrs ctxt skols ambigs }
128 skols = foldr (unionVarSet . ic_skols) emptyVarSet (cec_encl ctxt)
130 -- Report equalities of form (a~ty) first. They are usually
131 -- skolem-equalities, and they cause confusing knock-on
132 -- effects in other errors; see test T4093b.
133 is_tv_eq c | EqPred ty1 ty2 <- evVarOfPred c
134 = tcIsTyVarTy ty1 || tcIsTyVarTy ty2
137 -- Treat it as "ambiguous" if
138 -- (a) it is a class constraint
139 -- (b) it constrains only type variables
140 -- (else we'd prefer to report it as "no instance for...")
141 -- (c) it mentions type variables that are not skolems
142 is_ambiguous d = isTyVarClassPred pred
143 && not (tyVarsOfPred pred `subVarSet` skols)
147 reportInsoluble :: ReportErrCtxt -> FlavoredEvVar -> TcM ()
148 reportInsoluble ctxt (EvVarX ev flav)
149 | EqPred ty1 ty2 <- evVarPred ev
150 = setCtFlavorLoc flav $
151 do { let ctxt2 = ctxt { cec_extra = cec_extra ctxt $$ inaccessible_msg }
152 ; reportEqErr ctxt2 ty1 ty2 }
154 = pprPanic "reportInsoluble" (pprEvVarWithType ev)
156 inaccessible_msg | Given loc <- flav
157 = hang (ptext (sLit "Inaccessible code in"))
158 2 (ppr (ctLocOrigin loc))
161 reportFlat :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
162 -- The [PredType] are already tidied
163 reportFlat ctxt flats origin
164 = do { unless (null dicts) $ reportDictErrs ctxt dicts origin
165 ; unless (null eqs) $ reportEqErrs ctxt eqs origin
166 ; unless (null ips) $ reportIPErrs ctxt ips origin
167 ; ASSERT( null others ) return () }
169 (dicts, non_dicts) = partition isClassPred flats
170 (eqs, non_eqs) = partition isEqPred non_dicts
171 (ips, others) = partition isIPPred non_eqs
173 --------------------------------------------
175 --------------------------------------------
177 groupErrs :: ([PredType] -> CtOrigin -> TcM ()) -- Deal with one group
178 -> [WantedEvVar] -- Unsolved wanteds
180 -- Group together insts with the same origin
181 -- We want to report them together in error messages
185 groupErrs report_err (wanted : wanteds)
186 = do { setCtLoc the_loc $
187 report_err the_vars (ctLocOrigin the_loc)
188 ; groupErrs report_err others }
190 the_loc = evVarX wanted
191 the_key = mk_key the_loc
192 the_vars = map evVarOfPred (wanted:friends)
193 (friends, others) = partition is_friend wanteds
194 is_friend friend = mk_key (evVarX friend) `same_key` the_key
196 mk_key :: WantedLoc -> (SrcSpan, CtOrigin)
197 mk_key loc = (ctLocSpan loc, ctLocOrigin loc)
199 same_key (s1, o1) (s2, o2) = s1==s2 && o1 `same_orig` o2
200 same_orig (OccurrenceOf n1) (OccurrenceOf n2) = n1==n2
201 same_orig ScOrigin ScOrigin = True
202 same_orig DerivOrigin DerivOrigin = True
203 same_orig DefaultOrigin DefaultOrigin = True
204 same_orig _ _ = False
207 -- Add the "arising from..." part to a message about bunch of dicts
208 addArising :: CtOrigin -> SDoc -> SDoc
209 addArising orig msg = msg $$ nest 2 (pprArising orig)
211 pprWithArising :: [WantedEvVar] -> (WantedLoc, SDoc)
212 -- Print something like
213 -- (Eq a) arising from a use of x at y
214 -- (Show a) arising from a use of p at q
215 -- Also return a location for the error message
217 = panic "pprWithArising"
218 pprWithArising [EvVarX ev loc]
219 = (loc, pprEvVarTheta [ev] <+> pprArising (ctLocOrigin loc))
220 pprWithArising ev_vars
221 = (first_loc, vcat (map ppr_one ev_vars))
223 first_loc = evVarX (head ev_vars)
224 ppr_one (EvVarX v loc)
225 = parens (pprPred (evVarPred v)) <+> pprArisingAt loc
227 addErrorReport :: ReportErrCtxt -> SDoc -> TcM ()
228 addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt)
230 pprErrCtxtLoc :: ReportErrCtxt -> SDoc
232 = case map (ctLocOrigin . ic_loc) (cec_encl ctxt) of
233 [] -> ptext (sLit "the top level") -- Should not happen
234 (orig:origs) -> ppr_skol orig $$
235 vcat [ ptext (sLit "or") <+> ppr_skol orig | orig <- origs ]
237 ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc)
238 ppr_skol skol_info = ppr skol_info
240 getUserGivens :: ReportErrCtxt -> [([EvVar], GivenLoc)]
241 -- One item for each enclosing implication
242 getUserGivens (CEC {cec_encl = ctxt})
244 [ (givens', loc) | Implic {ic_given = givens, ic_loc = loc} <- ctxt
245 , let givens' = get_user_givens givens
246 , not (null givens') ]
248 get_user_givens givens | opt_PprStyle_Debug = givens
249 | otherwise = filterOut isSilentEvVar givens
250 -- In user mode, don't show the "silent" givens, used for
251 -- the "self" dictionary and silent superclass arguments for dfuns
256 %************************************************************************
258 Implicit parameter errors
260 %************************************************************************
263 reportIPErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
264 reportIPErrs ctxt ips orig
265 = addErrorReport ctxt msg
267 givens = getUserGivens ctxt
270 sep [ ptext (sLit "Unbound implicit parameter") <> plural ips
271 , nest 2 (pprTheta ips) ]
273 = couldNotDeduce givens (ips, orig)
277 %************************************************************************
281 %************************************************************************
284 reportEqErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
285 -- The [PredType] are already tidied
286 reportEqErrs ctxt eqs orig
287 = do { orig' <- zonkTidyOrigin ctxt orig
288 ; mapM_ (report_one orig') eqs }
290 report_one orig (EqPred ty1 ty2)
291 = do { let extra = getWantedEqExtra orig ty1 ty2
292 ctxt' = ctxt { cec_extra = extra $$ cec_extra ctxt }
293 ; reportEqErr ctxt' ty1 ty2 }
295 = pprPanic "reportEqErrs" (ppr pred)
297 getWantedEqExtra :: CtOrigin -> TcType -> TcType -> SDoc
298 getWantedEqExtra (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp }))
300 -- If the types in the error message are the same as the types we are unifying,
301 -- don't add the extra expected/actual message
302 | act `tcEqType` ty1 && exp `tcEqType` ty2 = empty
303 | exp `tcEqType` ty1 && act `tcEqType` ty2 = empty
304 | otherwise = mkExpectedActualMsg act exp
306 getWantedEqExtra orig _ _ = pprArising orig
308 reportEqErr :: ReportErrCtxt -> TcType -> TcType -> TcM ()
309 -- ty1 and ty2 are already tidied
310 reportEqErr ctxt ty1 ty2
311 | Just tv1 <- tcGetTyVar_maybe ty1 = reportTyVarEqErr ctxt tv1 ty2
312 | Just tv2 <- tcGetTyVar_maybe ty2 = reportTyVarEqErr ctxt tv2 ty1
314 | otherwise -- Neither side is a type variable
315 -- Since the unsolved constraint is canonical,
316 -- it must therefore be of form (F tys ~ ty)
317 = addErrorReport ctxt (misMatchOrCND ctxt ty1 ty2 $$ mkTyFunInfoMsg ty1 ty2)
320 reportTyVarEqErr :: ReportErrCtxt -> TcTyVar -> TcType -> TcM ()
321 -- tv1 and ty2 are already tidied
322 reportTyVarEqErr ctxt tv1 ty2
324 , Just tv2 <- tcGetTyVar_maybe ty2
326 = -- sk ~ alpha: swap
327 reportTyVarEqErr ctxt tv2 ty1
330 = -- sk ~ ty, where ty isn't a meta-tyvar: mis-match
331 addErrorReport (addExtraInfo ctxt ty1 ty2)
332 (misMatchOrCND ctxt ty1 ty2)
334 -- So tv is a meta tyvar, and presumably it is
335 -- an *untouchable* meta tyvar, else it'd have been unified
336 | not (k2 `isSubKind` k1) -- Kind error
337 = addErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2)
340 | tv1 `elemVarSet` tyVarsOfType ty2
341 = let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:") 2
342 (sep [ppr ty1, char '=', ppr ty2])
343 in addErrorReport ctxt occCheckMsg
345 -- Check for skolem escape
346 | (implic:_) <- cec_encl ctxt -- Get the innermost context
347 , let esc_skols = varSetElems (tyVarsOfType ty2 `intersectVarSet` ic_skols implic)
348 implic_loc = ic_loc implic
349 , not (null esc_skols)
350 = setCtLoc implic_loc $ -- Override the error message location from the
351 -- place the equality arose to the implication site
352 do { (env1, env_sigs) <- findGlobals ctxt (unitVarSet tv1)
353 ; let msg = misMatchMsg ty1 ty2
354 esc_doc = sep [ ptext (sLit "because type variable") <> plural esc_skols
355 <+> pprQuotedList esc_skols
356 , ptext (sLit "would escape") <+>
357 if isSingleton esc_skols then ptext (sLit "its scope")
358 else ptext (sLit "their scope") ]
359 extra1 = vcat [ nest 2 $ esc_doc
360 , sep [ (if isSingleton esc_skols
361 then ptext (sLit "This (rigid, skolem) type variable is")
362 else ptext (sLit "These (rigid, skolem) type variables are"))
363 <+> ptext (sLit "bound by")
364 , nest 2 $ ppr (ctLocOrigin implic_loc) ] ]
365 ; addErrTcM (env1, msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) }
367 -- Nastiest case: attempt to unify an untouchable variable
368 | (implic:_) <- cec_encl ctxt -- Get the innermost context
369 , let implic_loc = ic_loc implic
370 given = ic_given implic
371 = setCtLoc (ic_loc implic) $
372 do { let msg = misMatchMsg ty1 ty2
373 extra = quotes (ppr tv1)
374 <+> sep [ ptext (sLit "is untouchable")
375 , ptext (sLit "inside the constraints") <+> pprEvVarTheta given
376 , ptext (sLit "bound at") <+> ppr (ctLocOrigin implic_loc)]
377 ; addErrorReport (addExtraInfo ctxt ty1 ty2) (msg $$ nest 2 extra) }
379 | otherwise -- This can happen, by a recursive decomposition of frozen
380 -- occurs check constraints
381 -- Example: alpha ~ T Int alpha has frozen.
382 -- Then alpha gets unified to T beta gamma
383 -- So now we have T beta gamma ~ T Int (T beta gamma)
384 -- Decompose to (beta ~ Int, gamma ~ T beta gamma)
385 -- The (gamma ~ T beta gamma) is the occurs check, but
386 -- the (beta ~ Int) isn't an error at all. So return ()
390 is_meta1 = isMetaTyVar tv1
395 mkTyFunInfoMsg :: TcType -> TcType -> SDoc
396 -- See Note [Non-injective type functions]
397 mkTyFunInfoMsg ty1 ty2
398 | Just (tc1,_) <- tcSplitTyConApp_maybe ty1
399 , Just (tc2,_) <- tcSplitTyConApp_maybe ty2
400 , tc1 == tc2, isSynFamilyTyCon tc1
401 = ptext (sLit "NB:") <+> quotes (ppr tc1)
402 <+> ptext (sLit "is a type function") <> (pp_inj tc1)
405 pp_inj tc | isInjectiveTyCon tc = empty
406 | otherwise = ptext (sLit (", and may not be injective"))
408 misMatchOrCND :: ReportErrCtxt -> TcType -> TcType -> SDoc
409 misMatchOrCND ctxt ty1 ty2
410 | cec_insol ctxt = misMatchMsg ty1 ty2 -- If the equality is unconditionally
411 -- insoluble, don't report the context
412 | null givens = misMatchMsg ty1 ty2
413 | otherwise = couldNotDeduce givens ([EqPred ty1 ty2], orig)
415 givens = getUserGivens ctxt
416 orig = TypeEqOrigin (UnifyOrigin ty1 ty2)
418 couldNotDeduce :: [([EvVar], GivenLoc)] -> (ThetaType, CtOrigin) -> SDoc
419 couldNotDeduce givens (wanteds, orig)
420 = vcat [ hang (ptext (sLit "Could not deduce") <+> pprTheta wanteds)
427 (g:gs) -> ppr_given (ptext (sLit "from the context")) g
428 : map (ppr_given (ptext (sLit "or from"))) gs
430 ppr_given herald (gs,loc)
431 = hang (herald <+> pprEvVarTheta gs)
432 2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin loc)
433 , ptext (sLit "at") <+> ppr (ctLocSpan loc)])
435 addExtraInfo :: ReportErrCtxt -> TcType -> TcType -> ReportErrCtxt
436 -- Add on extra info about the types themselves
437 -- NB: The types themselves are already tidied
438 addExtraInfo ctxt ty1 ty2
439 = ctxt { cec_extra = nest 2 (extra1 $$ extra2) $$ cec_extra ctxt }
441 extra1 = typeExtraInfoMsg (cec_encl ctxt) ty1
442 extra2 = typeExtraInfoMsg (cec_encl ctxt) ty2
444 misMatchMsg :: TcType -> TcType -> SDoc -- Types are already tidy
445 misMatchMsg ty1 ty2 = sep [ ptext (sLit "Couldn't match type") <+> quotes (ppr ty1)
446 , nest 15 $ ptext (sLit "with") <+> quotes (ppr ty2)]
448 kindErrorMsg :: TcType -> TcType -> SDoc -- Types are already tidy
450 = vcat [ ptext (sLit "Kind incompatibility when matching types:")
451 , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1
452 , ppr ty2 <+> dcolon <+> ppr k2 ]) ]
457 typeExtraInfoMsg :: [Implication] -> Type -> SDoc
458 -- Shows a bit of extra info about skolem constants
459 typeExtraInfoMsg implics ty
460 | Just tv <- tcGetTyVar_maybe ty
463 = pprSkolTvBinding implics tv
465 typeExtraInfoMsg _ _ = empty -- Normal case
468 unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc)
469 unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env
470 = do { (env1, act_ty') <- zonkTidyTcType tidy_env act_ty
471 ; (env2, exp_ty') <- zonkTidyTcType env1 exp_ty
472 ; return (env2, mkExpectedActualMsg act_ty' exp_ty') }
474 mkExpectedActualMsg :: Type -> Type -> SDoc
475 mkExpectedActualMsg act_ty exp_ty
476 = vcat [ text "Expected type" <> colon <+> ppr exp_ty
477 , text " Actual type" <> colon <+> ppr act_ty ]
480 Note [Non-injective type functions]
481 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
482 It's very confusing to get a message like
483 Couldn't match expected type `Depend s'
484 against inferred type `Depend s1'
485 so mkTyFunInfoMsg adds:
486 NB: `Depend' is type function, and hence may not be injective
488 Warn of loopy local equalities that were dropped.
491 %************************************************************************
495 %************************************************************************
498 reportDictErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
499 reportDictErrs ctxt wanteds orig
500 = do { inst_envs <- tcGetInstEnvs
501 ; non_overlaps <- mapMaybeM (reportOverlap ctxt inst_envs orig) wanteds
502 ; unless (null non_overlaps) $
503 addErrorReport ctxt (mk_no_inst_err non_overlaps) }
505 mk_no_inst_err :: [PredType] -> SDoc
506 mk_no_inst_err wanteds
507 | null givens -- Top level
508 = vcat [ addArising orig $
509 ptext (sLit "No instance") <> plural min_wanteds
510 <+> ptext (sLit "for") <+> pprTheta min_wanteds
511 , show_fixes (fixes2 ++ fixes3) ]
514 = vcat [ couldNotDeduce givens (min_wanteds, orig)
515 , show_fixes (fix1 : (fixes2 ++ fixes3)) ]
517 givens = getUserGivens ctxt
518 min_wanteds = mkMinimalBySCs wanteds
519 fix1 = sep [ ptext (sLit "add") <+> pprTheta min_wanteds
520 <+> ptext (sLit "to the context of")
521 , nest 2 $ pprErrCtxtLoc ctxt ]
523 fixes2 = case instance_dicts of
525 [_] -> [sep [ptext (sLit "add an instance declaration for"),
526 pprTheta instance_dicts]]
527 _ -> [sep [ptext (sLit "add instance declarations for"),
528 pprTheta instance_dicts]]
529 fixes3 = case orig of
530 DerivOrigin -> [drv_fix]
533 instance_dicts = filterOut isTyVarClassPred min_wanteds
534 -- Insts for which it is worth suggesting an adding an
535 -- instance declaration. Exclude tyvar dicts.
537 drv_fix = vcat [ptext (sLit "use a standalone 'deriving instance' declaration,"),
538 nest 2 $ ptext (sLit "so you can specify the instance context yourself")]
540 show_fixes :: [SDoc] -> SDoc
541 show_fixes [] = empty
542 show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"),
543 nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
545 reportOverlap :: ReportErrCtxt -> (InstEnv,InstEnv) -> CtOrigin
546 -> PredType -> TcM (Maybe PredType)
547 -- Report an overlap error if this class constraint results
548 -- from an overlap (returning Nothing), otherwise return (Just pred)
549 reportOverlap ctxt inst_envs orig pred@(ClassP clas tys)
550 = do { tys_flat <- mapM quickFlattenTy tys
551 -- Note [Flattening in error message generation]
553 ; case lookupInstEnv inst_envs clas tys_flat of
554 ([], _) -> return (Just pred) -- No match
555 -- The case of exactly one match and no unifiers means a
556 -- successful lookup. That can't happen here, because dicts
557 -- only end up here if they didn't match in Inst.lookupInst
559 | debugIsOn -> pprPanic "check_overlap" (ppr pred)
560 res -> do { addErrorReport ctxt (mk_overlap_msg res)
563 mk_overlap_msg (matches, unifiers)
564 = ASSERT( not (null matches) )
565 vcat [ addArising orig (ptext (sLit "Overlapping instances for")
567 , sep [ptext (sLit "Matching instances") <> colon,
568 nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
569 , if not (isSingleton matches)
570 then -- Two or more matches
572 else -- One match, plus some unifiers
573 ASSERT( not (null unifiers) )
574 parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
575 quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
576 ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
577 ptext (sLit "when compiling the other instance declarations")])]
579 ispecs = [ispec | (ispec, _) <- matches]
581 reportOverlap _ _ _ _ = panic "reportOverlap" -- Not a ClassP
583 ----------------------
584 quickFlattenTy :: TcType -> TcM TcType
585 -- See Note [Flattening in error message generation]
586 quickFlattenTy ty | Just ty' <- tcView ty = quickFlattenTy ty'
587 quickFlattenTy ty@(TyVarTy {}) = return ty
588 quickFlattenTy ty@(ForAllTy {}) = return ty -- See
589 quickFlattenTy ty@(PredTy {}) = return ty -- Note [Quick-flatten polytypes]
590 -- Don't flatten because of the danger or removing a bound variable
591 quickFlattenTy (AppTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
592 ; fy2 <- quickFlattenTy ty2
593 ; return (AppTy fy1 fy2) }
594 quickFlattenTy (FunTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
595 ; fy2 <- quickFlattenTy ty2
596 ; return (FunTy fy1 fy2) }
597 quickFlattenTy (TyConApp tc tys)
598 | not (isSynFamilyTyCon tc)
599 = do { fys <- mapM quickFlattenTy tys
600 ; return (TyConApp tc fys) }
602 = do { let (funtys,resttys) = splitAt (tyConArity tc) tys
603 -- Ignore the arguments of the type family funtys
604 ; v <- newMetaTyVar TauTv (typeKind (TyConApp tc funtys))
605 ; flat_resttys <- mapM quickFlattenTy resttys
606 ; return (foldl AppTy (mkTyVarTy v) flat_resttys) }
609 Note [Flattening in error message generation]
610 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
611 Consider (C (Maybe (F x))), where F is a type function, and we have
613 C (Maybe Int) and C (Maybe a)
614 Since (F x) might turn into Int, this is an overlap situation, and
615 indeed (because of flattening) the main solver will have refrained
616 from solving. But by the time we get to error message generation, we've
617 un-flattened the constraint. So we must *re*-flatten it before looking
618 up in the instance environment, lest we only report one matching
619 instance when in fact there are two.
621 Re-flattening is pretty easy, because we don't need to keep track of
622 evidence. We don't re-use the code in TcCanonical because that's in
623 the TcS monad, and we are in TcM here.
625 Note [Quick-flatten polytypes]
626 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
627 If we see C (Ix a => blah) or C (forall a. blah) we simply refrain from
628 flattening any further. After all, there can be no instance declarations
629 that match such things. And flattening under a for-all is problematic
630 anyway; consider C (forall a. F a)
633 reportAmbigErrs :: ReportErrCtxt -> TcTyVarSet -> [WantedEvVar] -> TcM ()
634 reportAmbigErrs ctxt skols ambigs
635 -- Divide into groups that share a common set of ambiguous tyvars
636 = mapM_ report (equivClasses cmp ambigs_w_tvs)
638 ambigs_w_tvs = [ (d, varSetElems (tyVarsOfEvVarX d `minusVarSet` skols))
640 cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
642 report :: [(WantedEvVar, [TcTyVar])] -> TcM ()
645 do { let main_msg = sep [ text "Ambiguous type variable" <> plural tvs
646 <+> pprQuotedList tvs
647 <+> text "in the constraint" <> plural pairs <> colon
648 , nest 2 pp_wanteds ]
649 ; (tidy_env, mono_msg) <- mkMonomorphismMsg ctxt tvs
650 ; addErrTcM (tidy_env, main_msg $$ mono_msg) }
653 (loc, pp_wanteds) = pprWithArising (map fst pairs)
655 mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc)
656 -- There's an error with these Insts; if they have free type variables
657 -- it's probably caused by the monomorphism restriction.
658 -- Try to identify the offending variable
659 -- ASSUMPTION: the Insts are fully zonked
660 mkMonomorphismMsg ctxt inst_tvs
661 = do { dflags <- getDOpts
662 ; traceTc "Mono" (vcat (map (pprSkolTvBinding (cec_encl ctxt)) inst_tvs))
663 ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
664 ; return (tidy_env, mk_msg dflags docs) }
666 mk_msg _ _ | any isRuntimeUnkSkol inst_tvs -- See Note [Runtime skolems]
667 = vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
668 (pprWithCommas ppr inst_tvs),
669 ptext (sLit "Use :print or :force to determine these types")]
670 mk_msg _ [] = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)")
671 -- This happens in things like
672 -- f x = show (read "foo")
673 -- where monomorphism doesn't play any role
675 = vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"),
677 monomorphism_fix dflags]
679 monomorphism_fix :: DynFlags -> SDoc
680 monomorphism_fix dflags
681 = ptext (sLit "Probable fix:") <+> vcat
682 [ptext (sLit "give these definition(s) an explicit type signature"),
683 if xopt Opt_MonomorphismRestriction dflags
684 then ptext (sLit "or use -XNoMonomorphismRestriction")
685 else empty] -- Only suggest adding "-XNoMonomorphismRestriction"
686 -- if it is not already set!
689 pprSkolTvBinding :: [Implication] -> TcTyVar -> SDoc
690 -- Print info about the binding of a skolem tyvar,
691 -- or nothing if we don't have anything useful to say
692 pprSkolTvBinding implics tv
693 | isTcTyVar tv = quotes (ppr tv) <+> ppr_details (tcTyVarDetails tv)
694 | otherwise = quotes (ppr tv) <+> ppr_skol (getSkolemInfo implics tv)
696 ppr_details (SkolemTv {}) = ppr_skol (getSkolemInfo implics tv)
697 ppr_details (FlatSkol {}) = ptext (sLit "is a flattening type variable")
698 ppr_details (RuntimeUnk {}) = ptext (sLit "is an interactive-debugger skolem")
699 ppr_details (MetaTv (SigTv n) _) = ptext (sLit "is bound by the type signature for")
701 ppr_details (MetaTv _ _) = ptext (sLit "is a meta type variable")
704 ppr_skol UnkSkol = ptext (sLit "is an unknown type variable") -- Unhelpful
705 ppr_skol RuntimeUnkSkol = ptext (sLit "is an unknown runtime type")
706 ppr_skol info = sep [ptext (sLit "is a rigid type variable bound by"),
708 ptext (sLit "at") <+> ppr (getSrcLoc tv)]]
710 getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo
712 = WARN( True, ptext (sLit "No skolem info:") <+> ppr tv )
714 getSkolemInfo (implic:implics) tv
715 | tv `elemVarSet` ic_skols implic = ctLocOrigin (ic_loc implic)
716 | otherwise = getSkolemInfo implics tv
718 -----------------------
719 -- findGlobals looks at the value environment and finds values whose
720 -- types mention any of the offending type variables. It has to be
721 -- careful to zonk the Id's type first, so it has to be in the monad.
722 -- We must be careful to pass it a zonked type variable, too.
724 mkEnvSigMsg :: SDoc -> [SDoc] -> SDoc
725 mkEnvSigMsg what env_sigs
726 | null env_sigs = empty
727 | otherwise = vcat [ ptext (sLit "The following variables have types that mention") <+> what
728 , nest 2 (vcat env_sigs) ]
730 findGlobals :: ReportErrCtxt
732 -> TcM (TidyEnv, [SDoc])
735 = do { lcl_ty_env <- case cec_encl ctxt of
737 (i:_) -> return (ic_env i)
738 ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) }
740 go tidy_env acc [] = return (tidy_env, acc)
741 go tidy_env acc (thing : things) = do
742 (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing
744 Just d -> go tidy_env1 (d:acc) things
745 Nothing -> go tidy_env1 acc things
747 ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
749 -----------------------
750 find_thing :: TidyEnv -> (TcType -> Bool)
751 -> TcTyThing -> TcM (TidyEnv, Maybe SDoc)
752 find_thing tidy_env ignore_it (ATcId { tct_id = id })
753 = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id)
754 ; if ignore_it tidy_ty then
755 return (tidy_env, Nothing)
757 { let msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty
758 , nest 2 (parens (ptext (sLit "bound at") <+>
759 ppr (getSrcLoc id)))]
760 ; return (tidy_env', Just msg) } }
762 find_thing tidy_env ignore_it (ATyVar tv ty)
763 = do { (tidy_env1, tidy_ty) <- zonkTidyTcType tidy_env ty
764 ; if ignore_it tidy_ty then
765 return (tidy_env, Nothing)
767 { let -- The name tv is scoped, so we don't need to tidy it
768 msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff
771 eq_stuff | Just tv' <- tcGetTyVar_maybe tidy_ty
772 , getOccName tv == getOccName tv' = empty
773 | otherwise = equals <+> ppr tidy_ty
774 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
775 bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
777 ; return (tidy_env1, Just msg) } }
779 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
781 warnDefaulting :: [FlavoredEvVar] -> Type -> TcM ()
782 warnDefaulting wanteds default_ty
783 = do { warn_default <- doptM Opt_WarnTypeDefaults
784 ; env0 <- tcInitTidyEnv
785 ; let wanted_bag = listToBag wanteds
786 tidy_env = tidyFreeTyVars env0 $
787 tyVarsOfEvVarXs wanted_bag
788 tidy_wanteds = mapBag (tidyFlavoredEvVar tidy_env) wanted_bag
789 (loc, ppr_wanteds) = pprWithArising (map get_wev (bagToList tidy_wanteds))
790 warn_msg = hang (ptext (sLit "Defaulting the following constraint(s) to type")
791 <+> quotes (ppr default_ty))
793 ; setCtLoc loc $ warnTc warn_default warn_msg }
795 get_wev (EvVarX ev (Wanted loc)) = EvVarX ev loc -- Yuk
796 get_wev ev = pprPanic "warnDefaulting" (ppr ev)
799 Note [Runtime skolems]
800 ~~~~~~~~~~~~~~~~~~~~~~
801 We want to give a reasonably helpful error message for ambiguity
802 arising from *runtime* skolems in the debugger. These
803 are created by in RtClosureInspect.zonkRTTIType.
805 %************************************************************************
807 Error from the canonicaliser
808 These ones are called *during* constraint simplification
810 %************************************************************************
813 solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a
814 solverDepthErrorTcS depth stack
815 | null stack -- Shouldn't happen unless you say -fcontext-stack=0
816 = wrapErrTcS $ failWith msg
819 setCtFlavorLoc (cc_flavor top_item) $
820 do { ev_vars <- mapM (zonkEvVar . cc_id) stack
821 ; env0 <- tcInitTidyEnv
822 ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfEvVars ev_vars)
823 tidy_ev_vars = map (tidyEvVar tidy_env) ev_vars
824 ; failWithTcM (tidy_env, hang msg 2 (pprEvVars tidy_ev_vars)) }
826 top_item = head stack
827 msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
828 , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
830 flattenForAllErrorTcS :: CtFlavor -> TcType -> Bag CanonicalCt -> TcS a
831 flattenForAllErrorTcS fl ty _bad_eqs
834 do { env0 <- tcInitTidyEnv
835 ; let (env1, ty') = tidyOpenType env0 ty
836 msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:")
838 ; failWithTcM (env1, msg) }
841 %************************************************************************
845 %************************************************************************
848 setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
849 setCtFlavorLoc (Wanted loc) thing = setCtLoc loc thing
850 setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing
851 setCtFlavorLoc (Given loc) thing = setCtLoc loc thing
854 %************************************************************************
858 %************************************************************************
861 zonkTidyTcType :: TidyEnv -> TcType -> TcM (TidyEnv, TcType)
862 zonkTidyTcType env ty = do { ty' <- zonkTcType ty
863 ; return (tidyOpenType env ty') }
865 zonkTidyOrigin :: ReportErrCtxt -> CtOrigin -> TcM CtOrigin
866 zonkTidyOrigin ctxt (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp }))
867 = do { (env1, act') <- zonkTidyTcType (cec_tidy ctxt) act
868 ; (_env2, exp') <- zonkTidyTcType env1 exp
869 ; return (TypeEqOrigin (UnifyOrigin { uo_actual = act', uo_expected = exp' })) }
870 -- Drop the returned env on the floor; we may conceivably thereby get
871 -- inconsistent naming between uses of this function
872 zonkTidyOrigin _ orig = return orig