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 = sep [ ptext (sLit "because type variable") <> plural esc_skols
441 <+> pprQuotedList esc_skols
442 , ptext (sLit "would escape") <+>
443 if isSingleton esc_skols then ptext (sLit "its scope")
444 else ptext (sLit "their scope") ]
445 extra1 = vcat [ nest 2 $ esc_doc
446 , sep [ (if isSingleton esc_skols
447 then ptext (sLit "This (rigid, skolem) type variable is")
448 else ptext (sLit "These (rigid, skolem) type variables are"))
449 <+> ptext (sLit "bound by")
450 , nest 2 $ pprSkolInfo (ctLocOrigin implic_loc) ] ]
451 ; addErrTcM (env1, msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) }
453 -- Nastiest case: attempt to unify an untouchable variable
454 | (implic:_) <- cec_encl ctxt -- Get the innermost context
455 , let implic_loc = ic_loc implic
456 given = ic_given implic
457 = setCtLoc (ic_loc implic) $
458 do { let msg = misMatchMsg ty1 ty2
459 extra = quotes (ppr tv1)
460 <+> sep [ ptext (sLit "is untouchable")
461 , ptext (sLit "inside the constraints") <+> pprEvVarTheta given
462 , ptext (sLit "bound at") <+> pprSkolInfo (ctLocOrigin implic_loc)]
463 ; addErrorReport (addExtraInfo ctxt ty1 ty2) (msg $$ nest 2 extra) }
465 | otherwise -- This can happen, by a recursive decomposition of frozen
466 -- occurs check constraints
467 -- Example: alpha ~ T Int alpha has frozen.
468 -- Then alpha gets unified to T beta gamma
469 -- So now we have T beta gamma ~ T Int (T beta gamma)
470 -- Decompose to (beta ~ Int, gamma ~ T beta gamma)
471 -- The (gamma ~ T beta gamma) is the occurs check, but
472 -- the (beta ~ Int) isn't an error at all. So return ()
476 is_meta1 = isMetaTyVar tv1
481 mkTyFunInfoMsg :: TcType -> TcType -> SDoc
482 -- See Note [Non-injective type functions]
483 mkTyFunInfoMsg ty1 ty2
484 | Just (tc1,_) <- tcSplitTyConApp_maybe ty1
485 , Just (tc2,_) <- tcSplitTyConApp_maybe ty2
486 , tc1 == tc2, isSynFamilyTyCon tc1
487 = ptext (sLit "NB:") <+> quotes (ppr tc1)
488 <+> ptext (sLit "is a type function") <> (pp_inj tc1)
491 pp_inj tc | isInjectiveTyCon tc = empty
492 | otherwise = ptext (sLit (", and may not be injective"))
494 misMatchOrCND :: ReportErrCtxt -> TcType -> TcType -> SDoc
495 misMatchOrCND ctxt ty1 ty2
496 = case getUserGivens ctxt of
497 Just givens -> couldNotDeduce givens [EqPred ty1 ty2]
498 Nothing -> misMatchMsg ty1 ty2
500 couldNotDeduce :: [EvVar] -> [PredType] -> SDoc
501 couldNotDeduce givens wanteds
502 = sep [ ptext (sLit "Could not deduce") <+> pprTheta wanteds
503 , nest 2 $ ptext (sLit "from the context")
504 <+> pprEvVarTheta givens]
506 addExtraInfo :: ReportErrCtxt -> TcType -> TcType -> ReportErrCtxt
507 -- Add on extra info about the types themselves
508 -- NB: The types themselves are already tidied
509 addExtraInfo ctxt ty1 ty2
510 = ctxt { cec_tidy = env2
511 , cec_extra = nest 2 (extra1 $$ extra2) $$ cec_extra ctxt }
513 (env1, extra1) = typeExtraInfoMsg (cec_tidy ctxt) ty1
514 (env2, extra2) = typeExtraInfoMsg env1 ty2
516 misMatchMsg :: TcType -> TcType -> SDoc -- Types are already tidy
517 misMatchMsg ty1 ty2 = sep [ ptext (sLit "Couldn't match type") <+> quotes (ppr ty1)
518 , nest 15 $ ptext (sLit "with") <+> quotes (ppr ty2)]
520 kindErrorMsg :: TcType -> TcType -> SDoc -- Types are already tidy
522 = vcat [ ptext (sLit "Kind incompatibility when matching types:")
523 , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1
524 , ppr ty2 <+> dcolon <+> ppr k2 ]) ]
529 typeExtraInfoMsg :: TidyEnv -> Type -> (TidyEnv, SDoc)
530 -- Shows a bit of extra info about skolem constants
531 typeExtraInfoMsg env ty
532 | Just tv <- tcGetTyVar_maybe ty
534 , isSkolemTyVar tv || isSigTyVar tv
536 , let (env1, tv1) = tidySkolemTyVar env tv
537 = (env1, pprSkolTvBinding tv1)
539 typeExtraInfoMsg env _ty = (env, empty) -- Normal case
542 unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc)
543 unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env
544 = do { act_ty' <- zonkTcType act_ty
545 ; exp_ty' <- zonkTcType exp_ty
546 ; let (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
547 (env2, act_ty'') = tidyOpenType env1 act_ty'
548 ; return (env2, mkExpectedActualMsg act_ty'' exp_ty'') }
550 mkExpectedActualMsg :: Type -> Type -> SDoc
551 mkExpectedActualMsg act_ty exp_ty
552 = vcat [ text "Expected type" <> colon <+> ppr exp_ty
553 , text " Actual type" <> colon <+> ppr act_ty ]
556 Note [Non-injective type functions]
557 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
558 It's very confusing to get a message like
559 Couldn't match expected type `Depend s'
560 against inferred type `Depend s1'
561 so mkTyFunInfoMsg adds:
562 NB: `Depend' is type function, and hence may not be injective
564 Warn of loopy local equalities that were dropped.
567 %************************************************************************
571 %************************************************************************
574 reportDictErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
575 reportDictErrs ctxt wanteds orig
576 = do { inst_envs <- tcGetInstEnvs
577 ; non_overlaps <- mapMaybeM (reportOverlap ctxt inst_envs orig) wanteds
578 ; unless (null non_overlaps) $
579 addErrorReport ctxt (mk_no_inst_err non_overlaps) }
581 mk_no_inst_err :: [PredType] -> SDoc
582 mk_no_inst_err wanteds
583 | Just givens <- getUserGivens ctxt
584 = vcat [ addArising orig $ couldNotDeduce givens wanteds
585 , show_fixes (fix1 : fixes2) ]
587 | otherwise -- Top level
588 = vcat [ addArising orig $
589 ptext (sLit "No instance") <> plural wanteds
590 <+> ptext (sLit "for") <+> pprTheta wanteds
591 , show_fixes fixes2 ]
594 fix1 = sep [ ptext (sLit "add") <+> pprTheta wanteds
595 <+> ptext (sLit "to the context of")
596 , nest 2 $ pprErrCtxtLoc ctxt ]
598 fixes2 | null instance_dicts = []
599 | otherwise = [sep [ptext (sLit "add an instance declaration for"),
600 pprTheta instance_dicts]]
601 instance_dicts = filterOut isTyVarClassPred wanteds
602 -- Insts for which it is worth suggesting an adding an
603 -- instance declaration. Exclude tyvar dicts.
605 show_fixes :: [SDoc] -> SDoc
606 show_fixes [] = empty
607 show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"),
608 nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
610 reportOverlap :: ReportErrCtxt -> (InstEnv,InstEnv) -> CtOrigin
611 -> PredType -> TcM (Maybe PredType)
612 -- Report an overlap error if this class constraint results
613 -- from an overlap (returning Nothing), otherwise return (Just pred)
614 reportOverlap ctxt inst_envs orig pred@(ClassP clas tys)
615 = do { tys_flat <- mapM quickFlattenTy tys
616 -- Note [Flattening in error message generation]
618 ; case lookupInstEnv inst_envs clas tys_flat of
619 ([], _) -> return (Just pred) -- No match
620 -- The case of exactly one match and no unifiers means a
621 -- successful lookup. That can't happen here, because dicts
622 -- only end up here if they didn't match in Inst.lookupInst
624 | debugIsOn -> pprPanic "check_overlap" (ppr pred)
625 res -> do { addErrorReport ctxt (mk_overlap_msg res)
628 mk_overlap_msg (matches, unifiers)
629 = ASSERT( not (null matches) )
630 vcat [ addArising orig (ptext (sLit "Overlapping instances for")
632 , sep [ptext (sLit "Matching instances") <> colon,
633 nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
634 , if not (isSingleton matches)
635 then -- Two or more matches
637 else -- One match, plus some unifiers
638 ASSERT( not (null unifiers) )
639 parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
640 quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
641 ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
642 ptext (sLit "when compiling the other instance declarations")])]
644 ispecs = [ispec | (ispec, _) <- matches]
646 reportOverlap _ _ _ _ = panic "reportOverlap" -- Not a ClassP
648 ----------------------
649 quickFlattenTy :: TcType -> TcM TcType
650 -- See Note [Flattening in error message generation]
651 quickFlattenTy ty | Just ty' <- tcView ty = quickFlattenTy ty'
652 quickFlattenTy ty@(TyVarTy {}) = return ty
653 quickFlattenTy ty@(ForAllTy {}) = return ty -- See
654 quickFlattenTy ty@(PredTy {}) = return ty -- Note [Quick-flatten polytypes]
655 -- Don't flatten because of the danger or removing a bound variable
656 quickFlattenTy (AppTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
657 ; fy2 <- quickFlattenTy ty2
658 ; return (AppTy fy1 fy2) }
659 quickFlattenTy (FunTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
660 ; fy2 <- quickFlattenTy ty2
661 ; return (FunTy fy1 fy2) }
662 quickFlattenTy (TyConApp tc tys)
663 | not (isSynFamilyTyCon tc)
664 = do { fys <- mapM quickFlattenTy tys
665 ; return (TyConApp tc fys) }
667 = do { let (funtys,resttys) = splitAt (tyConArity tc) tys
668 -- Ignore the arguments of the type family funtys
669 ; v <- newMetaTyVar TauTv (typeKind (TyConApp tc funtys))
670 ; flat_resttys <- mapM quickFlattenTy resttys
671 ; return (foldl AppTy (mkTyVarTy v) flat_resttys) }
674 Note [Flattening in error message generation]
675 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
676 Consider (C (Maybe (F x))), where F is a type function, and we have
678 C (Maybe Int) and C (Maybe a)
679 Since (F x) might turn into Int, this is an overlap situation, and
680 indeed (because of flattening) the main solver will have refrained
681 from solving. But by the time we get to error message generation, we've
682 un-flattened the constraint. So we must *re*-flatten it before looking
683 up in the instance environment, lest we only report one matching
684 instance when in fact there are two.
686 Re-flattening is pretty easy, because we don't need to keep track of
687 evidence. We don't re-use the code in TcCanonical because that's in
688 the TcS monad, and we are in TcM here.
690 Note [Quick-flatten polytypes]
691 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
692 If we see C (Ix a => blah) or C (forall a. blah) we simply refrain from
693 flattening any further. After all, there can be no instance declarations
694 that match such things. And flattening under a for-all is problematic
695 anyway; consider C (forall a. F a)
698 reportAmbigErrs :: ReportErrCtxt -> TcTyVarSet -> [WantedEvVar] -> TcM ()
699 reportAmbigErrs ctxt skols ambigs
700 -- Divide into groups that share a common set of ambiguous tyvars
701 = mapM_ report (equivClasses cmp ambigs_w_tvs)
703 ambigs_w_tvs = [ (d, varSetElems (tyVarsOfWantedEvVar d `minusVarSet` skols))
705 cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
707 report :: [(WantedEvVar, [TcTyVar])] -> TcM ()
710 do { let main_msg = sep [ text "Ambiguous type variable" <> plural tvs
711 <+> pprQuotedList tvs
712 <+> text "in the constraint" <> plural pairs <> colon
713 , nest 2 pp_wanteds ]
714 ; (tidy_env, mono_msg) <- mkMonomorphismMsg ctxt tvs
715 ; addErrTcM (tidy_env, main_msg $$ mono_msg) }
718 (loc, pp_wanteds) = pprWithArising (map fst pairs)
720 mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc)
721 -- There's an error with these Insts; if they have free type variables
722 -- it's probably caused by the monomorphism restriction.
723 -- Try to identify the offending variable
724 -- ASSUMPTION: the Insts are fully zonked
725 mkMonomorphismMsg ctxt inst_tvs
726 = do { dflags <- getDOpts
727 ; traceTc "Mono" (vcat (map pprSkolTvBinding inst_tvs))
728 ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
729 ; return (tidy_env, mk_msg dflags docs) }
731 mk_msg _ _ | any isRuntimeUnkSkol inst_tvs -- See Note [Runtime skolems]
732 = vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
733 (pprWithCommas ppr inst_tvs),
734 ptext (sLit "Use :print or :force to determine these types")]
735 mk_msg _ [] = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)")
736 -- This happens in things like
737 -- f x = show (read "foo")
738 -- where monomorphism doesn't play any role
740 = vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"),
742 monomorphism_fix dflags]
744 monomorphism_fix :: DynFlags -> SDoc
745 monomorphism_fix dflags
746 = ptext (sLit "Probable fix:") <+> vcat
747 [ptext (sLit "give these definition(s) an explicit type signature"),
748 if xopt Opt_MonomorphismRestriction dflags
749 then ptext (sLit "or use -XNoMonomorphismRestriction")
750 else empty] -- Only suggest adding "-XNoMonomorphismRestriction"
751 -- if it is not already set!
754 -----------------------
755 -- findGlobals looks at the value environment and finds values whose
756 -- types mention any of the offending type variables. It has to be
757 -- careful to zonk the Id's type first, so it has to be in the monad.
758 -- We must be careful to pass it a zonked type variable, too.
760 mkEnvSigMsg :: SDoc -> [SDoc] -> SDoc
761 mkEnvSigMsg what env_sigs
762 | null env_sigs = empty
763 | otherwise = vcat [ ptext (sLit "The following variables have types that mention") <+> what
764 , nest 2 (vcat env_sigs) ]
766 findGlobals :: ReportErrCtxt
768 -> TcM (TidyEnv, [SDoc])
771 = do { lcl_ty_env <- case cec_encl ctxt of
773 (i:_) -> return (ic_env i)
774 ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) }
776 go tidy_env acc [] = return (tidy_env, acc)
777 go tidy_env acc (thing : things) = do
778 (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing
780 Just d -> go tidy_env1 (d:acc) things
781 Nothing -> go tidy_env1 acc things
783 ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
785 -----------------------
786 find_thing :: TidyEnv -> (TcType -> Bool)
787 -> TcTyThing -> TcM (TidyEnv, Maybe SDoc)
788 find_thing tidy_env ignore_it (ATcId { tct_id = id })
789 = do { id_ty <- zonkTcType (idType id)
790 ; if ignore_it id_ty then
791 return (tidy_env, Nothing)
793 { let (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
794 msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty
795 , nest 2 (parens (ptext (sLit "bound at") <+>
796 ppr (getSrcLoc id)))]
797 ; return (tidy_env', Just msg) } }
799 find_thing tidy_env ignore_it (ATyVar tv ty)
800 = do { tv_ty <- zonkTcType ty
801 ; if ignore_it tv_ty then
802 return (tidy_env, Nothing)
804 { let -- The name tv is scoped, so we don't need to tidy it
805 (tidy_env1, tidy_ty) = tidyOpenType tidy_env tv_ty
806 msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff
809 eq_stuff | Just tv' <- tcGetTyVar_maybe tv_ty
810 , getOccName tv == getOccName tv' = empty
811 | otherwise = equals <+> ppr tidy_ty
812 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
813 bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
815 ; return (tidy_env1, Just msg) } }
817 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
819 warnDefaulting :: [WantedEvVar] -> Type -> TcM ()
820 warnDefaulting wanteds default_ty
821 = do { warn_default <- doptM Opt_WarnTypeDefaults
822 ; setCtLoc loc $ warnTc warn_default warn_msg }
825 warn_msg = vcat [ ptext (sLit "Defaulting the following constraint(s) to type") <+>
826 quotes (ppr default_ty),
828 (loc, ppr_wanteds) = pprWithArising wanteds
831 Note [Runtime skolems]
832 ~~~~~~~~~~~~~~~~~~~~~~
833 We want to give a reasonably helpful error message for ambiguity
834 arising from *runtime* skolems in the debugger. These
835 are created by in RtClosureInspect.zonkRTTIType.
837 %************************************************************************
839 Error from the canonicaliser
840 These ones are called *during* constraint simplification
842 %************************************************************************
846 solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a
847 solverDepthErrorTcS depth stack
848 | null stack -- Shouldn't happen unless you say -fcontext-stack=0
849 = wrapErrTcS $ failWith msg
852 setCtFlavorLoc (cc_flavor top_item) $
853 do { env0 <- tcInitTidyEnv
854 ; let ev_vars = map cc_id stack
855 env1 = tidyFreeTyVars env0 free_tvs
856 free_tvs = foldr (unionVarSet . tyVarsOfEvVar) emptyVarSet ev_vars
857 extra = pprEvVars (map (tidyEvVar env1) ev_vars)
858 ; failWithTcM (env1, hang msg 2 extra) }
860 top_item = head stack
861 msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
862 , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
864 flattenForAllErrorTcS :: CtFlavor -> TcType -> Bag CanonicalCt -> TcS a
865 flattenForAllErrorTcS fl ty _bad_eqs
868 do { env0 <- tcInitTidyEnv
869 ; let (env1, ty') = tidyOpenType env0 ty
870 msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:")
872 ; failWithTcM (env1, msg) }
875 %************************************************************************
879 %************************************************************************
882 setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
883 setCtFlavorLoc (Wanted loc) thing = setCtLoc loc thing
884 setCtFlavorLoc (Derived loc _) thing = setCtLoc loc thing
885 setCtFlavorLoc (Given loc) thing = setCtLoc loc thing
887 getWantedEqExtra :: TvSubst -> TidyEnv -> CtOrigin -> TcType -> TcType
888 -> TcM (TidyEnv, SDoc)
889 getWantedEqExtra subst env0 (TypeEqOrigin item) ty1 ty2
890 -- If the types in the error message are the same
891 -- as the types we are unifying (remember to zonk the latter)
892 -- don't add the extra expected/actual message
894 -- The complication is that the types in the TypeEqOrigin must
896 -- (b) have any TcS-monad pending equalities applied to them
897 -- (hence the passed-in substitution)
898 = do { (env1, act) <- zonkSubstTidy env0 subst (uo_actual item)
899 ; (env2, exp) <- zonkSubstTidy env1 subst (uo_expected item)
900 ; if (act `tcEqType` ty1 && exp `tcEqType` ty2)
901 || (exp `tcEqType` ty1 && act `tcEqType` ty2)
905 return (env2, mkExpectedActualMsg act exp) }
907 getWantedEqExtra _ env0 orig _ _
908 = return (env0, pprArising orig)
910 zonkSubstTidy :: TidyEnv -> TvSubst -> TcType -> TcM (TidyEnv, TcType)
911 -- In general, becore printing a type, we want to
912 -- a) Zonk it. Even during constraint simplification this is
913 -- is important, to un-flatten the flatten skolems in a type
914 -- b) Substitute any solved unification variables. This is
915 -- only important *during* solving, becuase after solving
916 -- the substitution is expressed in the mutable type variables
917 -- But during solving there may be constraint (F xi ~ ty)
918 -- where the substitution has not been applied to the RHS
919 zonkSubstTidy env subst ty
920 = do { ty' <- zonkTcTypeAndSubst subst ty
921 ; return (tidyOpenType env ty') }