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 isSilentEvVar givens
347 -- In user mode, don't show the "silent" givens, used for
348 -- the "self" dictionary and silent superclass arguments for dfuns
352 %************************************************************************
354 Implicit parameter errors
356 %************************************************************************
359 reportIPErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
360 reportIPErrs ctxt ips orig
361 = addErrorReport ctxt $ addArising orig msg
363 msg | Just givens <- getUserGivens ctxt
364 = couldNotDeduce givens ips
366 = sep [ ptext (sLit "Unbound implicit parameter") <> plural ips
367 , nest 2 (pprTheta ips) ]
371 %************************************************************************
375 %************************************************************************
378 reportEqErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
379 -- The [PredType] are already tidied
380 reportEqErrs ctxt eqs orig
381 = mapM_ report_one eqs
384 report_one (EqPred ty1 ty2)
385 = do { (env1, extra) <- getWantedEqExtra emptyTvSubst env0 orig ty1 ty2
386 ; let ctxt' = ctxt { cec_tidy = env1
387 , cec_extra = extra $$ cec_extra ctxt }
388 ; reportEqErr ctxt' ty1 ty2 }
390 = pprPanic "reportEqErrs" (ppr pred)
392 reportEqErr :: ReportErrCtxt -> TcType -> TcType -> TcM ()
393 -- ty1 and ty2 are already tidied
394 reportEqErr ctxt ty1 ty2
395 | Just tv1 <- tcGetTyVar_maybe ty1 = reportTyVarEqErr ctxt tv1 ty2
396 | Just tv2 <- tcGetTyVar_maybe ty2 = reportTyVarEqErr ctxt tv2 ty1
398 | otherwise -- Neither side is a type variable
399 -- Since the unsolved constraint is canonical,
400 -- it must therefore be of form (F tys ~ ty)
401 = addErrorReport ctxt (misMatchOrCND ctxt ty1 ty2 $$ mkTyFunInfoMsg ty1 ty2)
404 reportTyVarEqErr :: ReportErrCtxt -> TcTyVar -> TcType -> TcM ()
405 -- tv1 and ty2 are already tidied
406 reportTyVarEqErr ctxt tv1 ty2
408 , Just tv2 <- tcGetTyVar_maybe ty2
410 = -- sk ~ alpha: swap
411 reportTyVarEqErr ctxt tv2 ty1
414 = -- sk ~ ty, where ty isn't a meta-tyvar: mis-match
415 addErrorReport (addExtraInfo ctxt ty1 ty2)
416 (misMatchOrCND ctxt ty1 ty2)
418 -- So tv is a meta tyvar, and presumably it is
419 -- an *untouchable* meta tyvar, else it'd have been unified
420 | not (k2 `isSubKind` k1) -- Kind error
421 = addErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2)
424 | tv1 `elemVarSet` tyVarsOfType ty2
425 = let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:") 2
426 (sep [ppr ty1, char '=', ppr ty2])
427 in addErrorReport ctxt occCheckMsg
429 -- Check for skolem escape
430 | (implic:_) <- cec_encl ctxt -- Get the innermost context
431 , let esc_skols = varSetElems (tyVarsOfType ty2 `intersectVarSet` ic_skols implic)
432 implic_loc = ic_loc implic
433 , not (null esc_skols)
434 = setCtLoc implic_loc $ -- Override the error message location from the
435 -- place the equality arose to the implication site
436 do { (env1, env_sigs) <- findGlobals ctxt (unitVarSet tv1)
437 ; let msg = misMatchMsg ty1 ty2
438 esc_doc = sep [ ptext (sLit "because type variable") <> plural esc_skols
439 <+> pprQuotedList esc_skols
440 , ptext (sLit "would escape") <+>
441 if isSingleton esc_skols then ptext (sLit "its scope")
442 else ptext (sLit "their scope") ]
443 extra1 = vcat [ nest 2 $ esc_doc
444 , sep [ (if isSingleton esc_skols
445 then ptext (sLit "This (rigid, skolem) type variable is")
446 else ptext (sLit "These (rigid, skolem) type variables are"))
447 <+> ptext (sLit "bound by")
448 , nest 2 $ pprSkolInfo (ctLocOrigin implic_loc) ] ]
449 ; addErrTcM (env1, msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) }
451 -- Nastiest case: attempt to unify an untouchable variable
452 | (implic:_) <- cec_encl ctxt -- Get the innermost context
453 , let implic_loc = ic_loc implic
454 given = ic_given implic
455 = setCtLoc (ic_loc implic) $
456 do { let msg = misMatchMsg ty1 ty2
457 extra = quotes (ppr tv1)
458 <+> sep [ ptext (sLit "is untouchable")
459 , ptext (sLit "inside the constraints") <+> pprEvVarTheta given
460 , ptext (sLit "bound at") <+> pprSkolInfo (ctLocOrigin implic_loc)]
461 ; addErrorReport (addExtraInfo ctxt ty1 ty2) (msg $$ nest 2 extra) }
463 | otherwise -- This can happen, by a recursive decomposition of frozen
464 -- occurs check constraints
465 -- Example: alpha ~ T Int alpha has frozen.
466 -- Then alpha gets unified to T beta gamma
467 -- So now we have T beta gamma ~ T Int (T beta gamma)
468 -- Decompose to (beta ~ Int, gamma ~ T beta gamma)
469 -- The (gamma ~ T beta gamma) is the occurs check, but
470 -- the (beta ~ Int) isn't an error at all. So return ()
474 is_meta1 = isMetaTyVar tv1
479 mkTyFunInfoMsg :: TcType -> TcType -> SDoc
480 -- See Note [Non-injective type functions]
481 mkTyFunInfoMsg ty1 ty2
482 | Just (tc1,_) <- tcSplitTyConApp_maybe ty1
483 , Just (tc2,_) <- tcSplitTyConApp_maybe ty2
484 , tc1 == tc2, isSynFamilyTyCon tc1
485 = ptext (sLit "NB:") <+> quotes (ppr tc1)
486 <+> ptext (sLit "is a type function") <> (pp_inj tc1)
489 pp_inj tc | isInjectiveTyCon tc = empty
490 | otherwise = ptext (sLit (", and may not be injective"))
492 misMatchOrCND :: ReportErrCtxt -> TcType -> TcType -> SDoc
493 misMatchOrCND ctxt ty1 ty2
494 = case getUserGivens ctxt of
495 Just givens -> couldNotDeduce givens [EqPred ty1 ty2]
496 Nothing -> misMatchMsg ty1 ty2
498 couldNotDeduce :: [EvVar] -> [PredType] -> SDoc
499 couldNotDeduce givens wanteds
500 = sep [ ptext (sLit "Could not deduce") <+> pprTheta wanteds
501 , nest 2 $ ptext (sLit "from the context")
502 <+> pprEvVarTheta givens]
504 addExtraInfo :: ReportErrCtxt -> TcType -> TcType -> ReportErrCtxt
505 -- Add on extra info about the types themselves
506 -- NB: The types themselves are already tidied
507 addExtraInfo ctxt ty1 ty2
508 = ctxt { cec_tidy = env2
509 , cec_extra = nest 2 (extra1 $$ extra2) $$ cec_extra ctxt }
511 (env1, extra1) = typeExtraInfoMsg (cec_tidy ctxt) ty1
512 (env2, extra2) = typeExtraInfoMsg env1 ty2
514 misMatchMsg :: TcType -> TcType -> SDoc -- Types are already tidy
515 misMatchMsg ty1 ty2 = sep [ ptext (sLit "Couldn't match type") <+> quotes (ppr ty1)
516 , nest 15 $ ptext (sLit "with") <+> quotes (ppr ty2)]
518 kindErrorMsg :: TcType -> TcType -> SDoc -- Types are already tidy
520 = vcat [ ptext (sLit "Kind incompatibility when matching types:")
521 , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1
522 , ppr ty2 <+> dcolon <+> ppr k2 ]) ]
527 typeExtraInfoMsg :: TidyEnv -> Type -> (TidyEnv, SDoc)
528 -- Shows a bit of extra info about skolem constants
529 typeExtraInfoMsg env ty
530 | Just tv <- tcGetTyVar_maybe ty
532 , isSkolemTyVar tv || isSigTyVar tv
534 , let (env1, tv1) = tidySkolemTyVar env tv
535 = (env1, pprSkolTvBinding tv1)
537 typeExtraInfoMsg env _ty = (env, empty) -- Normal case
540 unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc)
541 unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env
542 = do { act_ty' <- zonkTcType act_ty
543 ; exp_ty' <- zonkTcType exp_ty
544 ; let (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
545 (env2, act_ty'') = tidyOpenType env1 act_ty'
546 ; return (env2, mkExpectedActualMsg act_ty'' exp_ty'') }
548 mkExpectedActualMsg :: Type -> Type -> SDoc
549 mkExpectedActualMsg act_ty exp_ty
550 = vcat [ text "Expected type" <> colon <+> ppr exp_ty
551 , text " Actual type" <> colon <+> ppr act_ty ]
554 Note [Non-injective type functions]
555 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
556 It's very confusing to get a message like
557 Couldn't match expected type `Depend s'
558 against inferred type `Depend s1'
559 so mkTyFunInfoMsg adds:
560 NB: `Depend' is type function, and hence may not be injective
562 Warn of loopy local equalities that were dropped.
565 %************************************************************************
569 %************************************************************************
572 reportDictErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
573 reportDictErrs ctxt wanteds orig
574 = do { inst_envs <- tcGetInstEnvs
575 ; non_overlaps <- mapMaybeM (reportOverlap ctxt inst_envs orig) wanteds
576 ; unless (null non_overlaps) $
577 addErrorReport ctxt (mk_no_inst_err non_overlaps) }
579 mk_no_inst_err :: [PredType] -> SDoc
580 mk_no_inst_err wanteds
581 | Just givens <- getUserGivens ctxt
582 = vcat [ addArising orig $ couldNotDeduce givens wanteds
583 , show_fixes (fix1 : fixes2) ]
585 | otherwise -- Top level
586 = vcat [ addArising orig $
587 ptext (sLit "No instance") <> plural wanteds
588 <+> ptext (sLit "for") <+> pprTheta wanteds
589 , show_fixes fixes2 ]
592 fix1 = sep [ ptext (sLit "add") <+> pprTheta wanteds
593 <+> ptext (sLit "to the context of")
594 , nest 2 $ pprErrCtxtLoc ctxt ]
596 fixes2 = case instance_dicts of
598 [_] -> [sep [ptext (sLit "add an instance declaration for"),
599 pprTheta instance_dicts]]
600 _ -> [sep [ptext (sLit "add instance declarations for"),
601 pprTheta instance_dicts]]
602 instance_dicts = filterOut isTyVarClassPred wanteds
603 -- Insts for which it is worth suggesting an adding an
604 -- instance declaration. Exclude tyvar dicts.
606 show_fixes :: [SDoc] -> SDoc
607 show_fixes [] = empty
608 show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"),
609 nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
611 reportOverlap :: ReportErrCtxt -> (InstEnv,InstEnv) -> CtOrigin
612 -> PredType -> TcM (Maybe PredType)
613 -- Report an overlap error if this class constraint results
614 -- from an overlap (returning Nothing), otherwise return (Just pred)
615 reportOverlap ctxt inst_envs orig pred@(ClassP clas tys)
616 = do { tys_flat <- mapM quickFlattenTy tys
617 -- Note [Flattening in error message generation]
619 ; case lookupInstEnv inst_envs clas tys_flat of
620 ([], _) -> return (Just pred) -- No match
621 -- The case of exactly one match and no unifiers means a
622 -- successful lookup. That can't happen here, because dicts
623 -- only end up here if they didn't match in Inst.lookupInst
625 | debugIsOn -> pprPanic "check_overlap" (ppr pred)
626 res -> do { addErrorReport ctxt (mk_overlap_msg res)
629 mk_overlap_msg (matches, unifiers)
630 = ASSERT( not (null matches) )
631 vcat [ addArising orig (ptext (sLit "Overlapping instances for")
633 , sep [ptext (sLit "Matching instances") <> colon,
634 nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
635 , if not (isSingleton matches)
636 then -- Two or more matches
638 else -- One match, plus some unifiers
639 ASSERT( not (null unifiers) )
640 parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
641 quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
642 ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
643 ptext (sLit "when compiling the other instance declarations")])]
645 ispecs = [ispec | (ispec, _) <- matches]
647 reportOverlap _ _ _ _ = panic "reportOverlap" -- Not a ClassP
649 ----------------------
650 quickFlattenTy :: TcType -> TcM TcType
651 -- See Note [Flattening in error message generation]
652 quickFlattenTy ty | Just ty' <- tcView ty = quickFlattenTy ty'
653 quickFlattenTy ty@(TyVarTy {}) = return ty
654 quickFlattenTy ty@(ForAllTy {}) = return ty -- See
655 quickFlattenTy ty@(PredTy {}) = return ty -- Note [Quick-flatten polytypes]
656 -- Don't flatten because of the danger or removing a bound variable
657 quickFlattenTy (AppTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
658 ; fy2 <- quickFlattenTy ty2
659 ; return (AppTy fy1 fy2) }
660 quickFlattenTy (FunTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
661 ; fy2 <- quickFlattenTy ty2
662 ; return (FunTy fy1 fy2) }
663 quickFlattenTy (TyConApp tc tys)
664 | not (isSynFamilyTyCon tc)
665 = do { fys <- mapM quickFlattenTy tys
666 ; return (TyConApp tc fys) }
668 = do { let (funtys,resttys) = splitAt (tyConArity tc) tys
669 -- Ignore the arguments of the type family funtys
670 ; v <- newMetaTyVar TauTv (typeKind (TyConApp tc funtys))
671 ; flat_resttys <- mapM quickFlattenTy resttys
672 ; return (foldl AppTy (mkTyVarTy v) flat_resttys) }
675 Note [Flattening in error message generation]
676 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
677 Consider (C (Maybe (F x))), where F is a type function, and we have
679 C (Maybe Int) and C (Maybe a)
680 Since (F x) might turn into Int, this is an overlap situation, and
681 indeed (because of flattening) the main solver will have refrained
682 from solving. But by the time we get to error message generation, we've
683 un-flattened the constraint. So we must *re*-flatten it before looking
684 up in the instance environment, lest we only report one matching
685 instance when in fact there are two.
687 Re-flattening is pretty easy, because we don't need to keep track of
688 evidence. We don't re-use the code in TcCanonical because that's in
689 the TcS monad, and we are in TcM here.
691 Note [Quick-flatten polytypes]
692 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
693 If we see C (Ix a => blah) or C (forall a. blah) we simply refrain from
694 flattening any further. After all, there can be no instance declarations
695 that match such things. And flattening under a for-all is problematic
696 anyway; consider C (forall a. F a)
699 reportAmbigErrs :: ReportErrCtxt -> TcTyVarSet -> [WantedEvVar] -> TcM ()
700 reportAmbigErrs ctxt skols ambigs
701 -- Divide into groups that share a common set of ambiguous tyvars
702 = mapM_ report (equivClasses cmp ambigs_w_tvs)
704 ambigs_w_tvs = [ (d, varSetElems (tyVarsOfWantedEvVar d `minusVarSet` skols))
706 cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
708 report :: [(WantedEvVar, [TcTyVar])] -> TcM ()
711 do { let main_msg = sep [ text "Ambiguous type variable" <> plural tvs
712 <+> pprQuotedList tvs
713 <+> text "in the constraint" <> plural pairs <> colon
714 , nest 2 pp_wanteds ]
715 ; (tidy_env, mono_msg) <- mkMonomorphismMsg ctxt tvs
716 ; addErrTcM (tidy_env, main_msg $$ mono_msg) }
719 (loc, pp_wanteds) = pprWithArising (map fst pairs)
721 mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc)
722 -- There's an error with these Insts; if they have free type variables
723 -- it's probably caused by the monomorphism restriction.
724 -- Try to identify the offending variable
725 -- ASSUMPTION: the Insts are fully zonked
726 mkMonomorphismMsg ctxt inst_tvs
727 = do { dflags <- getDOpts
728 ; traceTc "Mono" (vcat (map pprSkolTvBinding inst_tvs))
729 ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
730 ; return (tidy_env, mk_msg dflags docs) }
732 mk_msg _ _ | any isRuntimeUnkSkol inst_tvs -- See Note [Runtime skolems]
733 = vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
734 (pprWithCommas ppr inst_tvs),
735 ptext (sLit "Use :print or :force to determine these types")]
736 mk_msg _ [] = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)")
737 -- This happens in things like
738 -- f x = show (read "foo")
739 -- where monomorphism doesn't play any role
741 = vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"),
743 monomorphism_fix dflags]
745 monomorphism_fix :: DynFlags -> SDoc
746 monomorphism_fix dflags
747 = ptext (sLit "Probable fix:") <+> vcat
748 [ptext (sLit "give these definition(s) an explicit type signature"),
749 if xopt Opt_MonomorphismRestriction dflags
750 then ptext (sLit "or use -XNoMonomorphismRestriction")
751 else empty] -- Only suggest adding "-XNoMonomorphismRestriction"
752 -- if it is not already set!
755 -----------------------
756 -- findGlobals looks at the value environment and finds values whose
757 -- types mention any of the offending type variables. It has to be
758 -- careful to zonk the Id's type first, so it has to be in the monad.
759 -- We must be careful to pass it a zonked type variable, too.
761 mkEnvSigMsg :: SDoc -> [SDoc] -> SDoc
762 mkEnvSigMsg what env_sigs
763 | null env_sigs = empty
764 | otherwise = vcat [ ptext (sLit "The following variables have types that mention") <+> what
765 , nest 2 (vcat env_sigs) ]
767 findGlobals :: ReportErrCtxt
769 -> TcM (TidyEnv, [SDoc])
772 = do { lcl_ty_env <- case cec_encl ctxt of
774 (i:_) -> return (ic_env i)
775 ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) }
777 go tidy_env acc [] = return (tidy_env, acc)
778 go tidy_env acc (thing : things) = do
779 (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing
781 Just d -> go tidy_env1 (d:acc) things
782 Nothing -> go tidy_env1 acc things
784 ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
786 -----------------------
787 find_thing :: TidyEnv -> (TcType -> Bool)
788 -> TcTyThing -> TcM (TidyEnv, Maybe SDoc)
789 find_thing tidy_env ignore_it (ATcId { tct_id = id })
790 = do { id_ty <- zonkTcType (idType id)
791 ; if ignore_it id_ty then
792 return (tidy_env, Nothing)
794 { let (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
795 msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty
796 , nest 2 (parens (ptext (sLit "bound at") <+>
797 ppr (getSrcLoc id)))]
798 ; return (tidy_env', Just msg) } }
800 find_thing tidy_env ignore_it (ATyVar tv ty)
801 = do { tv_ty <- zonkTcType ty
802 ; if ignore_it tv_ty then
803 return (tidy_env, Nothing)
805 { let -- The name tv is scoped, so we don't need to tidy it
806 (tidy_env1, tidy_ty) = tidyOpenType tidy_env tv_ty
807 msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff
810 eq_stuff | Just tv' <- tcGetTyVar_maybe tv_ty
811 , getOccName tv == getOccName tv' = empty
812 | otherwise = equals <+> ppr tidy_ty
813 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
814 bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
816 ; return (tidy_env1, Just msg) } }
818 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
820 warnDefaulting :: [WantedEvVar] -> Type -> TcM ()
821 warnDefaulting wanteds default_ty
822 = do { warn_default <- doptM Opt_WarnTypeDefaults
823 ; setCtLoc loc $ warnTc warn_default warn_msg }
826 warn_msg = vcat [ ptext (sLit "Defaulting the following constraint(s) to type") <+>
827 quotes (ppr default_ty),
829 (loc, ppr_wanteds) = pprWithArising wanteds
832 Note [Runtime skolems]
833 ~~~~~~~~~~~~~~~~~~~~~~
834 We want to give a reasonably helpful error message for ambiguity
835 arising from *runtime* skolems in the debugger. These
836 are created by in RtClosureInspect.zonkRTTIType.
838 %************************************************************************
840 Error from the canonicaliser
841 These ones are called *during* constraint simplification
843 %************************************************************************
847 solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a
848 solverDepthErrorTcS depth stack
849 | null stack -- Shouldn't happen unless you say -fcontext-stack=0
850 = wrapErrTcS $ failWith msg
853 setCtFlavorLoc (cc_flavor top_item) $
854 do { env0 <- tcInitTidyEnv
855 ; let ev_vars = map cc_id stack
856 env1 = tidyFreeTyVars env0 free_tvs
857 free_tvs = foldr (unionVarSet . tyVarsOfEvVar) emptyVarSet ev_vars
858 extra = pprEvVars (map (tidyEvVar env1) ev_vars)
859 ; failWithTcM (env1, hang msg 2 extra) }
861 top_item = head stack
862 msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
863 , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
865 flattenForAllErrorTcS :: CtFlavor -> TcType -> Bag CanonicalCt -> TcS a
866 flattenForAllErrorTcS fl ty _bad_eqs
869 do { env0 <- tcInitTidyEnv
870 ; let (env1, ty') = tidyOpenType env0 ty
871 msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:")
873 ; failWithTcM (env1, msg) }
876 %************************************************************************
880 %************************************************************************
883 setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
884 setCtFlavorLoc (Wanted loc) thing = setCtLoc loc thing
885 setCtFlavorLoc (Derived loc _) thing = setCtLoc loc thing
886 setCtFlavorLoc (Given loc) thing = setCtLoc loc thing
888 getWantedEqExtra :: TvSubst -> TidyEnv -> CtOrigin -> TcType -> TcType
889 -> TcM (TidyEnv, SDoc)
890 getWantedEqExtra subst env0 (TypeEqOrigin item) ty1 ty2
891 -- If the types in the error message are the same
892 -- as the types we are unifying (remember to zonk the latter)
893 -- don't add the extra expected/actual message
895 -- The complication is that the types in the TypeEqOrigin must
897 -- (b) have any TcS-monad pending equalities applied to them
898 -- (hence the passed-in substitution)
899 = do { (env1, act) <- zonkSubstTidy env0 subst (uo_actual item)
900 ; (env2, exp) <- zonkSubstTidy env1 subst (uo_expected item)
901 ; if (act `tcEqType` ty1 && exp `tcEqType` ty2)
902 || (exp `tcEqType` ty1 && act `tcEqType` ty2)
906 return (env2, mkExpectedActualMsg act exp) }
908 getWantedEqExtra _ env0 orig _ _
909 = return (env0, pprArising orig)
911 zonkSubstTidy :: TidyEnv -> TvSubst -> TcType -> TcM (TidyEnv, TcType)
912 -- In general, becore printing a type, we want to
913 -- a) Zonk it. Even during constraint simplification this is
914 -- is important, to un-flatten the flatten skolems in a type
915 -- b) Substitute any solved unification variables. This is
916 -- only important *during* solving, becuase after solving
917 -- the substitution is expressed in the mutable type variables
918 -- But during solving there may be constraint (F xi ~ ty)
919 -- where the substitution has not been applied to the RHS
920 zonkSubstTidy env subst ty
921 = do { ty' <- zonkTcTypeAndSubst subst ty
922 ; return (tidyOpenType env ty') }