3 reportUnsolved, reportUnsolvedDeriv,
4 reportUnsolvedWantedEvVars, warnDefaulting,
5 unifyCtxt, typeExtraInfoMsg,
11 #include "HsVersions.h"
26 import HsExpr ( pprMatchContext )
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 :: (Bag WantedEvVar, Bag Implication) -> Bag FrozenError -> TcM ()
54 reportUnsolved (unsolved_flats, unsolved_implics) frozen_errors
55 | isEmptyBag unsolved && isEmptyBag frozen_errors
58 = do { frozen_errors_zonked <- mapBagM zonk_frozen frozen_errors
59 ; let frozen_tvs = tyVarsOfFrozen frozen_errors_zonked
61 ; unsolved <- mapBagM zonkWanted unsolved
62 -- Zonk to un-flatten any flatten-skols
63 ; env0 <- tcInitTidyEnv
64 ; let tidy_env = tidyFreeTyVars env0 $
65 tyVarsOfWanteds unsolved `unionVarSet` frozen_tvs
67 tidy_unsolved = tidyWanteds tidy_env unsolved
68 err_ctxt = CEC { cec_encl = []
73 ; traceTc "reportUnsolved" (vcat [
74 text "Unsolved constraints =" <+> ppr unsolved,
75 text "Frozen errors =" <+> ppr frozen_errors_zonked ])
77 ; let tidy_frozen_errors_zonked = tidyFrozen tidy_env frozen_errors_zonked
79 ; reportTidyFrozens tidy_env tidy_frozen_errors_zonked
80 ; reportTidyWanteds err_ctxt tidy_unsolved }
82 unsolved = Bag.mapBag WcEvVar unsolved_flats `unionBags`
83 Bag.mapBag WcImplic unsolved_implics
85 zonk_frozen (FrozenError frknd fl ty1 ty2)
86 = do { ty1z <- zonkTcType ty1
87 ; ty2z <- zonkTcType ty2
88 ; return (FrozenError frknd fl ty1z ty2z) }
91 = unionVarSets $ bagToList (mapBag tvs_of_frozen fr)
92 tvs_of_frozen (FrozenError _ _ ty1 ty2) = tyVarsOfTypes [ty1,ty2]
94 tidyFrozen env fr = mapBag (tidy_frozen env) fr
95 tidy_frozen env (FrozenError frknd fl ty1 ty2)
96 = FrozenError frknd fl (tidyType env ty1) (tidyType env ty2)
98 reportTidyFrozens :: TidyEnv -> Bag FrozenError -> TcM ()
99 reportTidyFrozens tidy_env fr = mapBagM_ (reportTidyFrozen tidy_env) fr
101 reportTidyFrozen :: TidyEnv -> FrozenError -> TcM ()
102 reportTidyFrozen tidy_env err@(FrozenError _ fl _ty1 _ty2)
103 = do { let dec_errs = decompFrozenError err
104 init_err_ctxt = CEC { cec_encl = []
106 , cec_tidy = tidy_env }
107 ; mapM_ (report_dec_err init_err_ctxt) dec_errs }
109 report_dec_err err_ctxt (ty1,ty2)
110 -- The only annoying thing here is that in the given case,
111 -- the ``Inaccessible code'' message will be printed once for
112 -- each decomposed equality.
113 = do { (tidy_env2,extra2)
115 then return (cec_tidy err_ctxt, inaccessible_msg)
116 else getWantedEqExtra emptyTvSubst (cec_tidy err_ctxt) loc_orig ty1 ty2
117 ; let err_ctxt2 = err_ctxt { cec_tidy = tidy_env2
118 , cec_extra = cec_extra err_ctxt $$ extra2 }
119 ; setCtFlavorLoc fl $
120 reportEqErr err_ctxt2 ty1 ty2
123 loc_orig | Wanted loc <- fl = ctLocOrigin loc
124 | Derived loc _ <- fl = ctLocOrigin loc
125 | otherwise = pprPanic "loc_orig" empty
129 = hang (ptext (sLit "Inaccessible code in")) 2 (mk_what loc)
130 | otherwise = pprPanic "inaccessible_msg" empty
133 = case ctLocOrigin loc of
134 PatSkol dc mc -> sep [ ptext (sLit "a pattern with constructor")
135 <+> quotes (ppr dc) <> comma
136 , ptext (sLit "in") <+> pprMatchContext mc ]
137 other_skol -> pprSkolInfo other_skol
140 decompFrozenError :: FrozenError -> [(TcType,TcType)]
141 -- Postcondition: will always return a non-empty list
142 decompFrozenError (FrozenError errk _fl ty1 ty2)
143 | OccCheckError <- errk
144 = dec_occ_check ty1 ty2
147 where dec_occ_check :: TcType -> TcType -> [(TcType,TcType)]
148 -- This error arises from an original:
150 -- But by now the a has been substituted away, eg:
152 -- Maybe b ~ Maybe (Maybe b)
153 dec_occ_check ty1 ty2
154 | tcEqType ty1 ty2 = []
155 dec_occ_check ty1@(TyVarTy {}) ty2 = [(ty1,ty2)]
156 dec_occ_check (FunTy s1 t1) (FunTy s2 t2)
157 = let errs1 = dec_occ_check s1 s2
158 errs2 = dec_occ_check t1 t2
160 dec_occ_check ty1@(TyConApp fn1 tys1) ty2@(TyConApp fn2 tys2)
161 | fn1 == fn2 && length tys1 == length tys2
162 , not (isSynFamilyTyCon fn1)
163 = concatMap (\(t1,t2) -> dec_occ_check t1 t2) (zip tys1 tys2)
166 dec_occ_check ty1 ty2
167 | Just (s1,t1) <- tcSplitAppTy_maybe ty1
168 , Just (s2,t2) <- tcSplitAppTy_maybe ty2
169 = let errs1 = dec_occ_check s1 s2
170 errs2 = dec_occ_check t1 t2
172 dec_occ_check ty1 ty2 = [(ty1,ty2)]
174 reportUnsolvedWantedEvVars :: Bag WantedEvVar -> TcM ()
175 reportUnsolvedWantedEvVars wanteds
179 = do { wanteds <- mapBagM zonkWantedEvVar wanteds
180 ; env0 <- tcInitTidyEnv
181 ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfWantedEvVars wanteds)
182 tidy_unsolved = tidyWantedEvVars tidy_env wanteds
183 err_ctxt = CEC { cec_encl = []
185 , cec_tidy = tidy_env }
186 ; groupErrs (reportFlat err_ctxt) (bagToList tidy_unsolved) }
188 reportUnsolvedDeriv :: [PredType] -> WantedLoc -> TcM ()
189 reportUnsolvedDeriv unsolved loc
194 do { unsolved <- zonkTcThetaType unsolved
195 ; env0 <- tcInitTidyEnv
196 ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfTheta unsolved)
197 tidy_unsolved = map (tidyPred tidy_env) unsolved
198 err_ctxt = CEC { cec_encl = []
199 , cec_extra = alt_fix
200 , cec_tidy = tidy_env }
201 ; reportFlat err_ctxt tidy_unsolved (ctLocOrigin loc) }
203 alt_fix = vcat [ptext (sLit "Alternatively, use a standalone 'deriving instance' declaration,"),
204 nest 2 $ ptext (sLit "so you can specify the instance context yourself")]
206 --------------------------------------------
207 -- Internal functions
208 --------------------------------------------
211 = CEC { cec_encl :: [Implication] -- Enclosing implications
213 , cec_tidy :: TidyEnv
214 , cec_extra :: SDoc -- Add this to each error message
217 reportTidyImplic :: ReportErrCtxt -> Implication -> TcM ()
218 reportTidyImplic ctxt implic
219 = reportTidyWanteds ctxt' (ic_wanted implic)
221 ctxt' = ctxt { cec_encl = implic : cec_encl ctxt }
223 reportTidyWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
224 reportTidyWanteds ctxt unsolved
225 = do { let (flats, implics) = splitWanteds unsolved
226 (ambigs, non_ambigs) = partition is_ambiguous (bagToList flats)
227 (tv_eqs, others) = partition is_tv_eq non_ambigs
229 ; groupErrs (reportEqErrs ctxt) tv_eqs
230 ; when (null tv_eqs) $ groupErrs (reportFlat ctxt) others
231 ; traceTc "rtw" (vcat [
232 text "unsolved =" <+> ppr unsolved,
233 text "tveqs =" <+> ppr tv_eqs,
234 text "others =" <+> ppr others,
235 text "ambigs =" <+> ppr ambigs ,
236 text "implics =" <+> ppr implics])
238 ; when (null tv_eqs) $ mapBagM_ (reportTidyImplic ctxt) implics
240 -- Only report ambiguity if no other errors (at all) happened
241 -- See Note [Avoiding spurious errors] in TcSimplify
242 ; ifErrsM (return ()) $ reportAmbigErrs ctxt skols ambigs }
244 skols = foldr (unionVarSet . ic_skols) emptyVarSet (cec_encl ctxt)
246 -- Report equalities of form (a~ty) first. They are usually
247 -- skolem-equalities, and they cause confusing knock-on
248 -- effects in other errors; see test T4093b.
249 is_tv_eq c | EqPred ty1 ty2 <- wantedEvVarPred c
250 = tcIsTyVarTy ty1 || tcIsTyVarTy ty2
253 -- Treat it as "ambiguous" if
254 -- (a) it is a class constraint
255 -- (b) it constrains only type variables
256 -- (else we'd prefer to report it as "no instance for...")
257 -- (c) it mentions type variables that are not skolems
258 is_ambiguous d = isTyVarClassPred pred
259 && not (tyVarsOfPred pred `subVarSet` skols)
261 pred = wantedEvVarPred d
263 reportFlat :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
264 -- The [PredType] are already tidied
265 reportFlat ctxt flats origin
266 = do { unless (null dicts) $ reportDictErrs ctxt dicts origin
267 ; unless (null eqs) $ reportEqErrs ctxt eqs origin
268 ; unless (null ips) $ reportIPErrs ctxt ips origin
269 ; ASSERT( null others ) return () }
271 (dicts, non_dicts) = partition isClassPred flats
272 (eqs, non_eqs) = partition isEqPred non_dicts
273 (ips, others) = partition isIPPred non_eqs
275 --------------------------------------------
277 --------------------------------------------
279 groupErrs :: ([PredType] -> CtOrigin -> TcM ()) -- Deal with one group
280 -> [WantedEvVar] -- Unsolved wanteds
282 -- Group together insts with the same origin
283 -- We want to report them together in error messages
287 groupErrs report_err (wanted : wanteds)
288 = do { setCtLoc the_loc $
289 report_err the_vars (ctLocOrigin the_loc)
290 ; groupErrs report_err others }
292 the_loc = wantedEvVarLoc wanted
293 the_key = mk_key the_loc
294 the_vars = map wantedEvVarPred (wanted:friends)
295 (friends, others) = partition is_friend wanteds
296 is_friend friend = mk_key (wantedEvVarLoc friend) == the_key
298 mk_key :: WantedLoc -> (SrcSpan, String)
299 mk_key loc = (ctLocSpan loc, showSDoc (ppr (ctLocOrigin loc)))
300 -- It may seem crude to compare the error messages,
301 -- but it makes sure that we combine just what the user sees,
302 -- and it avoids need equality on InstLocs.
304 -- Add the "arising from..." part to a message about bunch of dicts
305 addArising :: CtOrigin -> SDoc -> SDoc
306 addArising orig msg = msg $$ nest 2 (pprArising orig)
308 pprWithArising :: [WantedEvVar] -> (WantedLoc, SDoc)
309 -- Print something like
310 -- (Eq a) arising from a use of x at y
311 -- (Show a) arising froma use of p at q
312 -- Also return a location for the erroe message
314 = panic "pprWithArising"
315 pprWithArising [WantedEvVar ev loc]
316 = (loc, pprEvVarTheta [ev] <+> pprArising (ctLocOrigin loc))
317 pprWithArising ev_vars
318 = (first_loc, vcat (map ppr_one ev_vars))
320 first_loc = wantedEvVarLoc (head ev_vars)
321 ppr_one (WantedEvVar v loc)
322 = parens (pprPred (evVarPred v)) <+> pprArisingAt loc
324 addErrorReport :: ReportErrCtxt -> SDoc -> TcM ()
325 addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt)
327 pprErrCtxtLoc :: ReportErrCtxt -> SDoc
329 = case map (ctLocOrigin . ic_loc) (cec_encl ctxt) of
330 [] -> ptext (sLit "the top level") -- Should not happen
331 (orig:origs) -> ppr_skol orig $$
332 vcat [ ptext (sLit "or") <+> ppr_skol orig | orig <- origs ]
334 ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc)
335 ppr_skol skol_info = pprSkolInfo skol_info
337 getUserGivens :: ReportErrCtxt -> Maybe [EvVar]
338 -- Just gs => Say "could not deduce ... from gs"
339 -- Nothing => No interesting givens, say something else
340 getUserGivens (CEC {cec_encl = ctxt})
341 | null user_givens = Nothing
342 | otherwise = Just user_givens
344 givens = foldl (\gs ic -> ic_given ic ++ gs) [] ctxt
345 user_givens | opt_PprStyle_Debug = givens
346 | otherwise = filterOut isSelfDict givens
347 -- In user mode, don't show the "self-dict" given
348 -- which is only added to do co-inductive solving
349 -- Rather an awkward hack, but there we are
350 -- This is the only use of isSelfDict, so it's not in an inner loop
354 %************************************************************************
356 Implicit parameter errors
358 %************************************************************************
361 reportIPErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
362 reportIPErrs ctxt ips orig
363 = addErrorReport ctxt $ addArising orig msg
365 msg | Just givens <- getUserGivens ctxt
366 = couldNotDeduce givens ips
368 = sep [ ptext (sLit "Unbound implicit parameter") <> plural ips
369 , nest 2 (pprTheta ips) ]
373 %************************************************************************
377 %************************************************************************
380 reportEqErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
381 -- The [PredType] are already tidied
382 reportEqErrs ctxt eqs orig
383 = mapM_ report_one eqs
386 report_one (EqPred ty1 ty2)
387 = do { (env1, extra) <- getWantedEqExtra emptyTvSubst env0 orig ty1 ty2
388 ; let ctxt' = ctxt { cec_tidy = env1
389 , cec_extra = extra $$ cec_extra ctxt }
390 ; reportEqErr ctxt' ty1 ty2 }
392 = pprPanic "reportEqErrs" (ppr pred)
394 reportEqErr :: ReportErrCtxt -> TcType -> TcType -> TcM ()
395 -- ty1 and ty2 are already tidied
396 reportEqErr ctxt ty1 ty2
397 | Just tv1 <- tcGetTyVar_maybe ty1 = reportTyVarEqErr ctxt tv1 ty2
398 | Just tv2 <- tcGetTyVar_maybe ty2 = reportTyVarEqErr ctxt tv2 ty1
400 | otherwise -- Neither side is a type variable
401 -- Since the unsolved constraint is canonical,
402 -- it must therefore be of form (F tys ~ ty)
403 = addErrorReport ctxt (misMatchOrCND ctxt ty1 ty2 $$ mkTyFunInfoMsg ty1 ty2)
406 reportTyVarEqErr :: ReportErrCtxt -> TcTyVar -> TcType -> TcM ()
407 -- tv1 and ty2 are already tidied
408 reportTyVarEqErr ctxt tv1 ty2
410 , Just tv2 <- tcGetTyVar_maybe ty2
412 = -- sk ~ alpha: swap
413 reportTyVarEqErr ctxt tv2 ty1
416 = -- sk ~ ty, where ty isn't a meta-tyvar: mis-match
417 addErrorReport (addExtraInfo ctxt ty1 ty2)
418 (misMatchOrCND ctxt ty1 ty2)
420 -- So tv is a meta tyvar, and presumably it is
421 -- an *untouchable* meta tyvar, else it'd have been unified
422 | not (k2 `isSubKind` k1) -- Kind error
423 = addErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2)
426 | tv1 `elemVarSet` tyVarsOfType ty2
427 = let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:") 2
428 (sep [ppr ty1, char '=', ppr ty2])
429 in addErrorReport ctxt occCheckMsg
431 -- Check for skolem escape
432 | (implic:_) <- cec_encl ctxt -- Get the innermost context
433 , let esc_skols = varSetElems (tyVarsOfType ty2 `intersectVarSet` ic_skols implic)
434 implic_loc = ic_loc implic
435 , not (null esc_skols)
436 = setCtLoc implic_loc $ -- Override the error message location from the
437 -- place the equality arose to the implication site
438 do { (env1, env_sigs) <- findGlobals ctxt (unitVarSet tv1)
439 ; let msg = misMatchMsg ty1 ty2
440 esc_doc | isSingleton esc_skols
441 = ptext (sLit "because this skolem type variable would escape:")
443 = ptext (sLit "because these skolem type variables would escape:")
444 extra1 = vcat [ nest 2 $ esc_doc <+> pprQuotedList esc_skols
445 , sep [ (if isSingleton esc_skols
446 then ptext (sLit "This skolem is")
447 else ptext (sLit "These skolems are"))
448 <+> ptext (sLit "bound by")
449 , nest 2 $ pprSkolInfo (ctLocOrigin implic_loc) ] ]
450 ; addErrTcM (env1, msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) }
452 -- Nastiest case: attempt to unify an untouchable variable
453 | (implic:_) <- cec_encl ctxt -- Get the innermost context
454 , let implic_loc = ic_loc implic
455 given = ic_given implic
456 = setCtLoc (ic_loc implic) $
457 do { let msg = misMatchMsg ty1 ty2
458 extra = quotes (ppr tv1)
459 <+> sep [ ptext (sLit "is untouchable")
460 , ptext (sLit "inside the constraints") <+> pprEvVarTheta given
461 , ptext (sLit "bound at") <+> pprSkolInfo (ctLocOrigin implic_loc)]
462 ; addErrorReport (addExtraInfo ctxt ty1 ty2) (msg $$ nest 2 extra) }
464 | otherwise -- This can happen, by a recursive decomposition of frozen
465 -- occurs check constraints
466 -- Example: alpha ~ T Int alpha has frozen.
467 -- Then alpha gets unified to T beta gamma
468 -- So now we have T beta gamma ~ T Int (T beta gamma)
469 -- Decompose to (beta ~ Int, gamma ~ T beta gamma)
470 -- The (gamma ~ T beta gamma) is the occurs check, but
471 -- the (beta ~ Int) isn't an error at all. So return ()
475 is_meta1 = isMetaTyVar tv1
480 mkTyFunInfoMsg :: TcType -> TcType -> SDoc
481 -- See Note [Non-injective type functions]
482 mkTyFunInfoMsg ty1 ty2
483 | Just (tc1,_) <- tcSplitTyConApp_maybe ty1
484 , Just (tc2,_) <- tcSplitTyConApp_maybe ty2
485 , tc1 == tc2, isSynFamilyTyCon tc1
486 = ptext (sLit "NB:") <+> quotes (ppr tc1)
487 <+> ptext (sLit "is a type function") <> (pp_inj tc1)
490 pp_inj tc | isInjectiveTyCon tc = empty
491 | otherwise = ptext (sLit (", and may not be injective"))
493 misMatchOrCND :: ReportErrCtxt -> TcType -> TcType -> SDoc
494 misMatchOrCND ctxt ty1 ty2
495 = case getUserGivens ctxt of
496 Just givens -> couldNotDeduce givens [EqPred ty1 ty2]
497 Nothing -> misMatchMsg ty1 ty2
499 couldNotDeduce :: [EvVar] -> [PredType] -> SDoc
500 couldNotDeduce givens wanteds
501 = sep [ ptext (sLit "Could not deduce") <+> pprTheta wanteds
502 , nest 2 $ ptext (sLit "from the context")
503 <+> pprEvVarTheta givens]
505 addExtraInfo :: ReportErrCtxt -> TcType -> TcType -> ReportErrCtxt
506 -- Add on extra info about the types themselves
507 -- NB: The types themselves are already tidied
508 addExtraInfo ctxt ty1 ty2
509 = ctxt { cec_tidy = env2
510 , cec_extra = nest 2 (extra1 $$ extra2) $$ cec_extra ctxt }
512 (env1, extra1) = typeExtraInfoMsg (cec_tidy ctxt) ty1
513 (env2, extra2) = typeExtraInfoMsg env1 ty2
515 misMatchMsg :: TcType -> TcType -> SDoc -- Types are already tidy
516 misMatchMsg ty1 ty2 = sep [ ptext (sLit "Couldn't match type") <+> quotes (ppr ty1)
517 , nest 15 $ ptext (sLit "with") <+> quotes (ppr ty2)]
519 kindErrorMsg :: TcType -> TcType -> SDoc -- Types are already tidy
521 = vcat [ ptext (sLit "Kind incompatibility when matching types:")
522 , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1
523 , ppr ty2 <+> dcolon <+> ppr k2 ]) ]
528 typeExtraInfoMsg :: TidyEnv -> Type -> (TidyEnv, SDoc)
529 -- Shows a bit of extra info about skolem constants
530 typeExtraInfoMsg env ty
531 | Just tv <- tcGetTyVar_maybe ty
533 , isSkolemTyVar tv || isSigTyVar tv
535 , let (env1, tv1) = tidySkolemTyVar env tv
536 = (env1, pprSkolTvBinding tv1)
538 typeExtraInfoMsg env _ty = (env, empty) -- Normal case
541 unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc)
542 unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env
543 = do { act_ty' <- zonkTcType act_ty
544 ; exp_ty' <- zonkTcType exp_ty
545 ; let (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
546 (env2, act_ty'') = tidyOpenType env1 act_ty'
547 ; return (env2, mkExpectedActualMsg act_ty'' exp_ty'') }
549 mkExpectedActualMsg :: Type -> Type -> SDoc
550 mkExpectedActualMsg act_ty exp_ty
551 = vcat [ text "Expected type" <> colon <+> ppr exp_ty
552 , text " Actual type" <> colon <+> ppr act_ty ]
555 Note [Non-injective type functions]
556 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
557 It's very confusing to get a message like
558 Couldn't match expected type `Depend s'
559 against inferred type `Depend s1'
560 so mkTyFunInfoMsg adds:
561 NB: `Depend' is type function, and hence may not be injective
563 Warn of loopy local equalities that were dropped.
566 %************************************************************************
570 %************************************************************************
573 reportDictErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
574 reportDictErrs ctxt wanteds orig
575 = do { inst_envs <- tcGetInstEnvs
576 ; let (others, overlaps) = partitionWith (check_overlap inst_envs) wanteds
577 ; unless (null others) $
578 addErrorReport ctxt (mk_no_inst_err others)
579 ; mapM_ (addErrorReport ctxt) overlaps }
581 check_overlap :: (InstEnv,InstEnv) -> PredType -> Either PredType SDoc
582 -- Right msg => overlap message
583 -- Left inst => no instance
584 check_overlap inst_envs pred@(ClassP clas tys)
585 = case lookupInstEnv inst_envs clas tys of
586 ([], _) -> Left pred -- No match
587 -- The case of exactly one match and no unifiers means a
588 -- successful lookup. That can't happen here, because dicts
589 -- only end up here if they didn't match in Inst.lookupInst
591 | debugIsOn -> pprPanic "check_overlap" (ppr pred)
592 res -> Right (mk_overlap_msg pred res)
593 check_overlap _ _ = panic "check_overlap"
595 mk_overlap_msg pred (matches, unifiers)
596 = ASSERT( not (null matches) )
597 vcat [ addArising orig (ptext (sLit "Overlapping instances for")
599 , sep [ptext (sLit "Matching instances") <> colon,
600 nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
601 , if not (isSingleton matches)
602 then -- Two or more matches
604 else -- One match, plus some unifiers
605 ASSERT( not (null unifiers) )
606 parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
607 quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
608 ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
609 ptext (sLit "when compiling the other instance declarations")])]
611 ispecs = [ispec | (ispec, _) <- matches]
613 mk_no_inst_err :: [PredType] -> SDoc
614 mk_no_inst_err wanteds
615 | Just givens <- getUserGivens ctxt
616 = vcat [ addArising orig $ couldNotDeduce givens wanteds
617 , show_fixes (fix1 : fixes2) ]
619 | otherwise -- Top level
620 = vcat [ addArising orig $
621 ptext (sLit "No instance") <> plural wanteds
622 <+> ptext (sLit "for") <+> pprTheta wanteds
623 , show_fixes fixes2 ]
626 fix1 = sep [ ptext (sLit "add") <+> pprTheta wanteds
627 <+> ptext (sLit "to the context of")
628 , nest 2 $ pprErrCtxtLoc ctxt ]
630 fixes2 | null instance_dicts = []
631 | otherwise = [sep [ptext (sLit "add an instance declaration for"),
632 pprTheta instance_dicts]]
633 instance_dicts = filterOut isTyVarClassPred wanteds
634 -- Insts for which it is worth suggesting an adding an
635 -- instance declaration. Exclude tyvar dicts.
637 show_fixes :: [SDoc] -> SDoc
638 show_fixes [] = empty
639 show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"),
640 nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
642 reportAmbigErrs :: ReportErrCtxt -> TcTyVarSet -> [WantedEvVar] -> TcM ()
643 reportAmbigErrs ctxt skols ambigs
644 -- Divide into groups that share a common set of ambiguous tyvars
645 = mapM_ report (equivClasses cmp ambigs_w_tvs)
647 ambigs_w_tvs = [ (d, varSetElems (tyVarsOfWantedEvVar d `minusVarSet` skols))
649 cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
651 report :: [(WantedEvVar, [TcTyVar])] -> TcM ()
654 do { let main_msg = sep [ text "Ambiguous type variable" <> plural tvs
655 <+> pprQuotedList tvs
656 <+> text "in the constraint" <> plural pairs <> colon
657 , nest 2 pp_wanteds ]
658 ; (tidy_env, mono_msg) <- mkMonomorphismMsg ctxt tvs
659 ; addErrTcM (tidy_env, main_msg $$ mono_msg) }
662 (loc, pp_wanteds) = pprWithArising (map fst pairs)
664 mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc)
665 -- There's an error with these Insts; if they have free type variables
666 -- it's probably caused by the monomorphism restriction.
667 -- Try to identify the offending variable
668 -- ASSUMPTION: the Insts are fully zonked
669 mkMonomorphismMsg ctxt inst_tvs
670 = do { dflags <- getDOpts
671 ; traceTc "Mono" (vcat (map pprSkolTvBinding inst_tvs))
672 ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
673 ; return (tidy_env, mk_msg dflags docs) }
675 mk_msg _ _ | any isRuntimeUnkSkol inst_tvs -- See Note [Runtime skolems]
676 = vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
677 (pprWithCommas ppr inst_tvs),
678 ptext (sLit "Use :print or :force to determine these types")]
679 mk_msg _ [] = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)")
680 -- This happens in things like
681 -- f x = show (read "foo")
682 -- where monomorphism doesn't play any role
684 = vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"),
686 monomorphism_fix dflags]
688 monomorphism_fix :: DynFlags -> SDoc
689 monomorphism_fix dflags
690 = ptext (sLit "Probable fix:") <+> vcat
691 [ptext (sLit "give these definition(s) an explicit type signature"),
692 if xopt Opt_MonomorphismRestriction dflags
693 then ptext (sLit "or use -XNoMonomorphismRestriction")
694 else empty] -- Only suggest adding "-XNoMonomorphismRestriction"
695 -- if it is not already set!
698 -----------------------
699 -- findGlobals looks at the value environment and finds values whose
700 -- types mention any of the offending type variables. It has to be
701 -- careful to zonk the Id's type first, so it has to be in the monad.
702 -- We must be careful to pass it a zonked type variable, too.
704 mkEnvSigMsg :: SDoc -> [SDoc] -> SDoc
705 mkEnvSigMsg what env_sigs
706 | null env_sigs = empty
707 | otherwise = vcat [ ptext (sLit "The following variables have types that mention") <+> what
708 , nest 2 (vcat env_sigs) ]
710 findGlobals :: ReportErrCtxt
712 -> TcM (TidyEnv, [SDoc])
715 = do { lcl_ty_env <- case cec_encl ctxt of
717 (i:_) -> return (ic_env i)
718 ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) }
720 go tidy_env acc [] = return (tidy_env, acc)
721 go tidy_env acc (thing : things) = do
722 (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing
724 Just d -> go tidy_env1 (d:acc) things
725 Nothing -> go tidy_env1 acc things
727 ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
729 -----------------------
730 find_thing :: TidyEnv -> (TcType -> Bool)
731 -> TcTyThing -> TcM (TidyEnv, Maybe SDoc)
732 find_thing tidy_env ignore_it (ATcId { tct_id = id })
733 = do { id_ty <- zonkTcType (idType id)
734 ; if ignore_it id_ty then
735 return (tidy_env, Nothing)
737 { let (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
738 msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty
739 , nest 2 (parens (ptext (sLit "bound at") <+>
740 ppr (getSrcLoc id)))]
741 ; return (tidy_env', Just msg) } }
743 find_thing tidy_env ignore_it (ATyVar tv ty)
744 = do { tv_ty <- zonkTcType ty
745 ; if ignore_it tv_ty then
746 return (tidy_env, Nothing)
748 { let -- The name tv is scoped, so we don't need to tidy it
749 (tidy_env1, tidy_ty) = tidyOpenType tidy_env tv_ty
750 msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff
753 eq_stuff | Just tv' <- tcGetTyVar_maybe tv_ty
754 , getOccName tv == getOccName tv' = empty
755 | otherwise = equals <+> ppr tidy_ty
756 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
757 bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
759 ; return (tidy_env1, Just msg) } }
761 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
763 warnDefaulting :: [WantedEvVar] -> Type -> TcM ()
764 warnDefaulting wanteds default_ty
765 = do { warn_default <- doptM Opt_WarnTypeDefaults
766 ; setCtLoc loc $ warnTc warn_default warn_msg }
769 warn_msg = vcat [ ptext (sLit "Defaulting the following constraint(s) to type") <+>
770 quotes (ppr default_ty),
772 (loc, ppr_wanteds) = pprWithArising wanteds
775 Note [Runtime skolems]
776 ~~~~~~~~~~~~~~~~~~~~~~
777 We want to give a reasonably helpful error message for ambiguity
778 arising from *runtime* skolems in the debugger. These
779 are created by in RtClosureInspect.zonkRTTIType.
782 %************************************************************************
784 Error from the canonicaliser
785 These ones are called *during* constraint simplification
787 %************************************************************************
791 solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a
792 solverDepthErrorTcS depth stack
793 | null stack -- Shouldn't happen unless you say -fcontext-stack=0
794 = wrapErrTcS $ failWith msg
797 setCtFlavorLoc (cc_flavor top_item) $
798 do { env0 <- tcInitTidyEnv
799 ; let ev_vars = map cc_id stack
800 env1 = tidyFreeTyVars env0 free_tvs
801 free_tvs = foldr (unionVarSet . tyVarsOfEvVar) emptyVarSet ev_vars
802 extra = pprEvVars (map (tidyEvVar env1) ev_vars)
803 ; failWithTcM (env1, hang msg 2 extra) }
805 top_item = head stack
806 msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
807 , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
809 flattenForAllErrorTcS :: CtFlavor -> TcType -> Bag CanonicalCt -> TcS a
810 flattenForAllErrorTcS fl ty _bad_eqs
813 do { env0 <- tcInitTidyEnv
814 ; let (env1, ty') = tidyOpenType env0 ty
815 msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:")
817 ; failWithTcM (env1, msg) }
820 %************************************************************************
824 %************************************************************************
827 setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
828 setCtFlavorLoc (Wanted loc) thing = setCtLoc loc thing
829 setCtFlavorLoc (Derived loc _) thing = setCtLoc loc thing
830 setCtFlavorLoc (Given loc) thing = setCtLoc loc thing
832 getWantedEqExtra :: TvSubst -> TidyEnv -> CtOrigin -> TcType -> TcType
833 -> TcM (TidyEnv, SDoc)
834 getWantedEqExtra subst env0 (TypeEqOrigin item) ty1 ty2
835 -- If the types in the error message are the same
836 -- as the types we are unifying (remember to zonk the latter)
837 -- don't add the extra expected/actual message
839 -- The complication is that the types in the TypeEqOrigin must
841 -- (b) have any TcS-monad pending equalities applied to them
842 -- (hence the passed-in substitution)
843 = do { (env1, act) <- zonkSubstTidy env0 subst (uo_actual item)
844 ; (env2, exp) <- zonkSubstTidy env1 subst (uo_expected item)
845 ; if (act `tcEqType` ty1 && exp `tcEqType` ty2)
846 || (exp `tcEqType` ty1 && act `tcEqType` ty2)
850 return (env2, mkExpectedActualMsg act exp) }
852 getWantedEqExtra _ env0 orig _ _
853 = return (env0, pprArising orig)
855 zonkSubstTidy :: TidyEnv -> TvSubst -> TcType -> TcM (TidyEnv, TcType)
856 -- In general, becore printing a type, we want to
857 -- a) Zonk it. Even during constraint simplification this is
858 -- is important, to un-flatten the flatten skolems in a type
859 -- b) Substitute any solved unification variables. This is
860 -- only important *during* solving, becuase after solving
861 -- the substitution is expressed in the mutable type variables
862 -- But during solving there may be constraint (F xi ~ ty)
863 -- where the substitution has not been applied to the RHS
864 zonkSubstTidy env subst ty
865 = do { ty' <- zonkTcTypeAndSubst subst ty
866 ; return (tidyOpenType env ty') }