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 ; non_overlaps <- mapMaybeM (reportOverlap ctxt inst_envs orig) wanteds
577 ; unless (null non_overlaps) $
578 addErrorReport ctxt (mk_no_inst_err non_overlaps) }
580 mk_no_inst_err :: [PredType] -> SDoc
581 mk_no_inst_err wanteds
582 | Just givens <- getUserGivens ctxt
583 = vcat [ addArising orig $ couldNotDeduce givens wanteds
584 , show_fixes (fix1 : fixes2) ]
586 | otherwise -- Top level
587 = vcat [ addArising orig $
588 ptext (sLit "No instance") <> plural wanteds
589 <+> ptext (sLit "for") <+> pprTheta wanteds
590 , show_fixes fixes2 ]
593 fix1 = sep [ ptext (sLit "add") <+> pprTheta wanteds
594 <+> ptext (sLit "to the context of")
595 , nest 2 $ pprErrCtxtLoc ctxt ]
597 fixes2 | null instance_dicts = []
598 | otherwise = [sep [ptext (sLit "add an instance declaration for"),
599 pprTheta instance_dicts]]
600 instance_dicts = filterOut isTyVarClassPred wanteds
601 -- Insts for which it is worth suggesting an adding an
602 -- instance declaration. Exclude tyvar dicts.
604 show_fixes :: [SDoc] -> SDoc
605 show_fixes [] = empty
606 show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"),
607 nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
609 reportOverlap :: ReportErrCtxt -> (InstEnv,InstEnv) -> CtOrigin
610 -> PredType -> TcM (Maybe PredType)
611 -- Report an overlap error if this class constraint results
612 -- from an overlap (returning Nothing), otherwise return (Just pred)
613 reportOverlap ctxt inst_envs orig pred@(ClassP clas tys)
614 = do { tys_flat <- mapM quickFlattenTy tys
615 -- Note [Flattening in error message generation]
617 ; case lookupInstEnv inst_envs clas tys_flat of
618 ([], _) -> return (Just pred) -- No match
619 -- The case of exactly one match and no unifiers means a
620 -- successful lookup. That can't happen here, because dicts
621 -- only end up here if they didn't match in Inst.lookupInst
623 | debugIsOn -> pprPanic "check_overlap" (ppr pred)
624 res -> do { addErrorReport ctxt (mk_overlap_msg res)
627 mk_overlap_msg (matches, unifiers)
628 = ASSERT( not (null matches) )
629 vcat [ addArising orig (ptext (sLit "Overlapping instances for")
631 , sep [ptext (sLit "Matching instances") <> colon,
632 nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
633 , if not (isSingleton matches)
634 then -- Two or more matches
636 else -- One match, plus some unifiers
637 ASSERT( not (null unifiers) )
638 parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
639 quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
640 ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
641 ptext (sLit "when compiling the other instance declarations")])]
643 ispecs = [ispec | (ispec, _) <- matches]
645 reportOverlap _ _ _ _ = panic "reportOverlap" -- Not a ClassP
647 ----------------------
648 quickFlattenTy :: TcType -> TcM TcType
649 -- See Note [Flattening in error message generation]
650 quickFlattenTy ty | Just ty' <- tcView ty = quickFlattenTy ty'
651 quickFlattenTy ty@(TyVarTy {}) = return ty
652 quickFlattenTy ty@(ForAllTy {}) = return ty -- See
653 quickFlattenTy ty@(PredTy {}) = return ty -- Note [Quick-flatten polytypes]
654 -- Don't flatten because of the danger or removing a bound variable
655 quickFlattenTy (AppTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
656 ; fy2 <- quickFlattenTy ty2
657 ; return (AppTy fy1 fy2) }
658 quickFlattenTy (FunTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
659 ; fy2 <- quickFlattenTy ty2
660 ; return (FunTy fy1 fy2) }
661 quickFlattenTy (TyConApp tc tys)
662 | not (isSynFamilyTyCon tc)
663 = do { fys <- mapM quickFlattenTy tys
664 ; return (TyConApp tc fys) }
666 = do { let (funtys,resttys) = splitAt (tyConArity tc) tys
667 -- Ignore the arguments of the type family funtys
668 ; v <- newMetaTyVar TauTv (typeKind (TyConApp tc funtys))
669 ; flat_resttys <- mapM quickFlattenTy resttys
670 ; return (foldl AppTy (mkTyVarTy v) flat_resttys) }
673 Note [Flattening in error message generation]
674 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
675 Consider (C (Maybe (F x))), where F is a type function, and we have
677 C (Maybe Int) and C (Maybe a)
678 Since (F x) might turn into Int, this is an overlap situation, and
679 indeed (because of flattening) the main solver will have refrained
680 from solving. But by the time we get to error message generation, we've
681 un-flattened the constraint. So we must *re*-flatten it before looking
682 up in the instance environment, lest we only report one matching
683 instance when in fact there are two.
685 Re-flattening is pretty easy, because we don't need to keep track of
686 evidence. We don't re-use the code in TcCanonical because that's in
687 the TcS monad, and we are in TcM here.
689 Note [Quick-flatten polytypes]
690 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
691 If we see C (Ix a => blah) or C (forall a. blah) we simply refrain from
692 flattening any further. After all, there can be no instance declarations
693 that match such things. And flattening under a for-all is problematic
694 anyway; consider C (forall a. F a)
697 reportAmbigErrs :: ReportErrCtxt -> TcTyVarSet -> [WantedEvVar] -> TcM ()
698 reportAmbigErrs ctxt skols ambigs
699 -- Divide into groups that share a common set of ambiguous tyvars
700 = mapM_ report (equivClasses cmp ambigs_w_tvs)
702 ambigs_w_tvs = [ (d, varSetElems (tyVarsOfWantedEvVar d `minusVarSet` skols))
704 cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
706 report :: [(WantedEvVar, [TcTyVar])] -> TcM ()
709 do { let main_msg = sep [ text "Ambiguous type variable" <> plural tvs
710 <+> pprQuotedList tvs
711 <+> text "in the constraint" <> plural pairs <> colon
712 , nest 2 pp_wanteds ]
713 ; (tidy_env, mono_msg) <- mkMonomorphismMsg ctxt tvs
714 ; addErrTcM (tidy_env, main_msg $$ mono_msg) }
717 (loc, pp_wanteds) = pprWithArising (map fst pairs)
719 mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc)
720 -- There's an error with these Insts; if they have free type variables
721 -- it's probably caused by the monomorphism restriction.
722 -- Try to identify the offending variable
723 -- ASSUMPTION: the Insts are fully zonked
724 mkMonomorphismMsg ctxt inst_tvs
725 = do { dflags <- getDOpts
726 ; traceTc "Mono" (vcat (map pprSkolTvBinding inst_tvs))
727 ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
728 ; return (tidy_env, mk_msg dflags docs) }
730 mk_msg _ _ | any isRuntimeUnkSkol inst_tvs -- See Note [Runtime skolems]
731 = vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
732 (pprWithCommas ppr inst_tvs),
733 ptext (sLit "Use :print or :force to determine these types")]
734 mk_msg _ [] = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)")
735 -- This happens in things like
736 -- f x = show (read "foo")
737 -- where monomorphism doesn't play any role
739 = vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"),
741 monomorphism_fix dflags]
743 monomorphism_fix :: DynFlags -> SDoc
744 monomorphism_fix dflags
745 = ptext (sLit "Probable fix:") <+> vcat
746 [ptext (sLit "give these definition(s) an explicit type signature"),
747 if xopt Opt_MonomorphismRestriction dflags
748 then ptext (sLit "or use -XNoMonomorphismRestriction")
749 else empty] -- Only suggest adding "-XNoMonomorphismRestriction"
750 -- if it is not already set!
753 -----------------------
754 -- findGlobals looks at the value environment and finds values whose
755 -- types mention any of the offending type variables. It has to be
756 -- careful to zonk the Id's type first, so it has to be in the monad.
757 -- We must be careful to pass it a zonked type variable, too.
759 mkEnvSigMsg :: SDoc -> [SDoc] -> SDoc
760 mkEnvSigMsg what env_sigs
761 | null env_sigs = empty
762 | otherwise = vcat [ ptext (sLit "The following variables have types that mention") <+> what
763 , nest 2 (vcat env_sigs) ]
765 findGlobals :: ReportErrCtxt
767 -> TcM (TidyEnv, [SDoc])
770 = do { lcl_ty_env <- case cec_encl ctxt of
772 (i:_) -> return (ic_env i)
773 ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) }
775 go tidy_env acc [] = return (tidy_env, acc)
776 go tidy_env acc (thing : things) = do
777 (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing
779 Just d -> go tidy_env1 (d:acc) things
780 Nothing -> go tidy_env1 acc things
782 ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
784 -----------------------
785 find_thing :: TidyEnv -> (TcType -> Bool)
786 -> TcTyThing -> TcM (TidyEnv, Maybe SDoc)
787 find_thing tidy_env ignore_it (ATcId { tct_id = id })
788 = do { id_ty <- zonkTcType (idType id)
789 ; if ignore_it id_ty then
790 return (tidy_env, Nothing)
792 { let (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
793 msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty
794 , nest 2 (parens (ptext (sLit "bound at") <+>
795 ppr (getSrcLoc id)))]
796 ; return (tidy_env', Just msg) } }
798 find_thing tidy_env ignore_it (ATyVar tv ty)
799 = do { tv_ty <- zonkTcType ty
800 ; if ignore_it tv_ty then
801 return (tidy_env, Nothing)
803 { let -- The name tv is scoped, so we don't need to tidy it
804 (tidy_env1, tidy_ty) = tidyOpenType tidy_env tv_ty
805 msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff
808 eq_stuff | Just tv' <- tcGetTyVar_maybe tv_ty
809 , getOccName tv == getOccName tv' = empty
810 | otherwise = equals <+> ppr tidy_ty
811 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
812 bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
814 ; return (tidy_env1, Just msg) } }
816 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
818 warnDefaulting :: [WantedEvVar] -> Type -> TcM ()
819 warnDefaulting wanteds default_ty
820 = do { warn_default <- doptM Opt_WarnTypeDefaults
821 ; setCtLoc loc $ warnTc warn_default warn_msg }
824 warn_msg = vcat [ ptext (sLit "Defaulting the following constraint(s) to type") <+>
825 quotes (ppr default_ty),
827 (loc, ppr_wanteds) = pprWithArising wanteds
830 Note [Runtime skolems]
831 ~~~~~~~~~~~~~~~~~~~~~~
832 We want to give a reasonably helpful error message for ambiguity
833 arising from *runtime* skolems in the debugger. These
834 are created by in RtClosureInspect.zonkRTTIType.
836 %************************************************************************
838 Error from the canonicaliser
839 These ones are called *during* constraint simplification
841 %************************************************************************
845 solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a
846 solverDepthErrorTcS depth stack
847 | null stack -- Shouldn't happen unless you say -fcontext-stack=0
848 = wrapErrTcS $ failWith msg
851 setCtFlavorLoc (cc_flavor top_item) $
852 do { env0 <- tcInitTidyEnv
853 ; let ev_vars = map cc_id stack
854 env1 = tidyFreeTyVars env0 free_tvs
855 free_tvs = foldr (unionVarSet . tyVarsOfEvVar) emptyVarSet ev_vars
856 extra = pprEvVars (map (tidyEvVar env1) ev_vars)
857 ; failWithTcM (env1, hang msg 2 extra) }
859 top_item = head stack
860 msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
861 , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
863 flattenForAllErrorTcS :: CtFlavor -> TcType -> Bag CanonicalCt -> TcS a
864 flattenForAllErrorTcS fl ty _bad_eqs
867 do { env0 <- tcInitTidyEnv
868 ; let (env1, ty') = tidyOpenType env0 ty
869 msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:")
871 ; failWithTcM (env1, msg) }
874 %************************************************************************
878 %************************************************************************
881 setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
882 setCtFlavorLoc (Wanted loc) thing = setCtLoc loc thing
883 setCtFlavorLoc (Derived loc _) thing = setCtLoc loc thing
884 setCtFlavorLoc (Given loc) thing = setCtLoc loc thing
886 getWantedEqExtra :: TvSubst -> TidyEnv -> CtOrigin -> TcType -> TcType
887 -> TcM (TidyEnv, SDoc)
888 getWantedEqExtra subst env0 (TypeEqOrigin item) ty1 ty2
889 -- If the types in the error message are the same
890 -- as the types we are unifying (remember to zonk the latter)
891 -- don't add the extra expected/actual message
893 -- The complication is that the types in the TypeEqOrigin must
895 -- (b) have any TcS-monad pending equalities applied to them
896 -- (hence the passed-in substitution)
897 = do { (env1, act) <- zonkSubstTidy env0 subst (uo_actual item)
898 ; (env2, exp) <- zonkSubstTidy env1 subst (uo_expected item)
899 ; if (act `tcEqType` ty1 && exp `tcEqType` ty2)
900 || (exp `tcEqType` ty1 && act `tcEqType` ty2)
904 return (env2, mkExpectedActualMsg act exp) }
906 getWantedEqExtra _ env0 orig _ _
907 = return (env0, pprArising orig)
909 zonkSubstTidy :: TidyEnv -> TvSubst -> TcType -> TcM (TidyEnv, TcType)
910 -- In general, becore printing a type, we want to
911 -- a) Zonk it. Even during constraint simplification this is
912 -- is important, to un-flatten the flatten skolems in a type
913 -- b) Substitute any solved unification variables. This is
914 -- only important *during* solving, becuase after solving
915 -- the substitution is expressed in the mutable type variables
916 -- But during solving there may be constraint (F xi ~ ty)
917 -- where the substitution has not been applied to the RHS
918 zonkSubstTidy env subst ty
919 = do { ty' <- zonkTcTypeAndSubst subst ty
920 ; return (tidyOpenType env ty') }