3 reportUnsolved, reportUnsolvedDeriv,
4 reportUnsolvedWantedEvVars, warnDefaulting,
5 unifyCtxt, typeExtraInfoMsg,
6 kindErrorTcS, misMatchErrorTcS, flattenForAllErrorTcS,
7 occursCheckErrorTcS, solverDepthErrorTcS
10 #include "HsVersions.h"
23 import HsExpr ( pprMatchContext )
29 import ListSetOps( equivClasses )
34 import StaticFlags( opt_PprStyle_Debug )
35 import Data.List( partition )
36 import Control.Monad( unless )
39 %************************************************************************
41 \section{Errors and contexts}
43 %************************************************************************
45 ToDo: for these error messages, should we note the location as coming
46 from the insts, or just whatever seems to be around in the monad just
50 reportUnsolved :: (CanonicalCts, Bag Implication) -> TcM ()
51 reportUnsolved (unsolved_flats, unsolved_implics)
55 = do { unsolved <- mapBagM zonkWanted unsolved
56 -- Zonk to un-flatten any flatten-skols
57 ; env0 <- tcInitTidyEnv
58 ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfWanteds unsolved)
59 tidy_unsolved = tidyWanteds tidy_env unsolved
60 err_ctxt = CEC { cec_encl = []
62 , cec_tidy = tidy_env }
63 ; traceTc "reportUnsolved" (ppr unsolved)
64 ; reportTidyWanteds err_ctxt tidy_unsolved }
66 unsolved = mkWantedConstraints unsolved_flats unsolved_implics
69 reportUnsolvedWantedEvVars :: Bag WantedEvVar -> TcM ()
70 reportUnsolvedWantedEvVars wanteds
74 = do { wanteds <- mapBagM zonkWantedEvVar wanteds
75 ; env0 <- tcInitTidyEnv
76 ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfWantedEvVars wanteds)
77 tidy_unsolved = tidyWantedEvVars tidy_env wanteds
78 err_ctxt = CEC { cec_encl = []
80 , cec_tidy = tidy_env }
81 ; groupErrs (reportFlat err_ctxt) (bagToList tidy_unsolved) }
83 reportUnsolvedDeriv :: [PredType] -> WantedLoc -> TcM ()
84 reportUnsolvedDeriv unsolved loc
89 do { unsolved <- zonkTcThetaType unsolved
90 ; env0 <- tcInitTidyEnv
91 ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfTheta unsolved)
92 tidy_unsolved = map (tidyPred tidy_env) unsolved
93 err_ctxt = CEC { cec_encl = []
95 , cec_tidy = tidy_env }
96 ; reportFlat err_ctxt tidy_unsolved (ctLocOrigin loc) }
98 alt_fix = vcat [ptext (sLit "Alternatively, use a standalone 'deriving instance' declaration,"),
99 nest 2 $ ptext (sLit "so you can specify the instance context yourself")]
101 --------------------------------------------
102 -- Internal functions
103 --------------------------------------------
106 = CEC { cec_encl :: [Implication] -- Enclosing implications
108 , cec_tidy :: TidyEnv
109 , cec_extra :: SDoc -- Add this to each error message
112 reportTidyImplic :: ReportErrCtxt -> Implication -> TcM ()
113 reportTidyImplic ctxt implic
114 = reportTidyWanteds ctxt' (ic_wanted implic)
116 ctxt' = ctxt { cec_encl = implic : cec_encl ctxt }
118 reportTidyWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
119 reportTidyWanteds ctxt unsolved
120 = do { let (flats, implics) = splitWanteds unsolved
121 (ambigs, others) = partition is_ambiguous (bagToList flats)
122 ; groupErrs (reportFlat ctxt) others
123 ; mapBagM_ (reportTidyImplic ctxt) implics
124 ; ifErrsM (return ()) $
125 -- Only report ambiguity if no other errors happened
126 -- See Note [Avoiding spurious errors]
127 reportAmbigErrs ctxt skols ambigs }
129 skols = foldr (unionVarSet . ic_skols) emptyVarSet (cec_encl ctxt)
131 -- Treat it as "ambiguous" if
132 -- (a) it is a class constraint
133 -- (b) it constrains only type variables
134 -- (else we'd prefer to report it as "no instance for...")
135 -- (c) it mentions type variables that are not skolems
136 is_ambiguous d = isTyVarClassPred pred
137 && not (tyVarsOfPred pred `subVarSet` skols)
139 pred = wantedEvVarPred d
141 reportFlat :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
142 reportFlat ctxt flats origin
143 = do { unless (null dicts) $ reportDictErrs ctxt dicts origin
144 ; unless (null eqs) $ reportEqErrs ctxt eqs origin
145 ; unless (null ips) $ reportIPErrs ctxt ips origin
146 ; ASSERT( null others ) return () }
148 (dicts, non_dicts) = partition isClassPred flats
149 (eqs, non_eqs) = partition isEqPred non_dicts
150 (ips, others) = partition isIPPred non_eqs
152 --------------------------------------------
154 --------------------------------------------
156 groupErrs :: ([PredType] -> CtOrigin -> TcM ()) -- Deal with one group
157 -> [WantedEvVar] -- Unsolved wanteds
159 -- Group together insts with the same origin
160 -- We want to report them together in error messages
164 groupErrs report_err (wanted : wanteds)
165 = do { setCtLoc the_loc $
166 report_err the_vars (ctLocOrigin the_loc)
167 ; groupErrs report_err others }
169 the_loc = wantedEvVarLoc wanted
170 the_key = mk_key the_loc
171 the_vars = map wantedEvVarPred (wanted:friends)
172 (friends, others) = partition is_friend wanteds
173 is_friend friend = mk_key (wantedEvVarLoc friend) == the_key
175 mk_key :: WantedLoc -> (SrcSpan, String)
176 mk_key loc = (ctLocSpan loc, showSDoc (ppr (ctLocOrigin loc)))
177 -- It may seem crude to compare the error messages,
178 -- but it makes sure that we combine just what the user sees,
179 -- and it avoids need equality on InstLocs.
181 -- Add the "arising from..." part to a message about bunch of dicts
182 addArising :: CtOrigin -> SDoc -> SDoc
183 addArising orig msg = msg $$ nest 2 (pprArising orig)
185 pprWithArising :: [WantedEvVar] -> (WantedLoc, SDoc)
186 -- Print something like
187 -- (Eq a) arising from a use of x at y
188 -- (Show a) arising froma use of p at q
189 -- Also return a location for the erroe message
191 = panic "pprWithArising"
192 pprWithArising [WantedEvVar ev loc]
193 = (loc, pprEvVarTheta [ev] <+> pprArising (ctLocOrigin loc))
194 pprWithArising ev_vars
195 = (first_loc, vcat (map ppr_one ev_vars))
197 first_loc = wantedEvVarLoc (head ev_vars)
198 ppr_one (WantedEvVar v loc)
199 = parens (pprPred (evVarPred v)) <+> pprArisingAt loc
201 addErrorReport :: ReportErrCtxt -> SDoc -> TcM ()
202 addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt)
204 pprErrCtxtLoc :: ReportErrCtxt -> SDoc
206 = case map (ctLocOrigin . ic_loc) (cec_encl ctxt) of
207 [] -> ptext (sLit "the top level") -- Should not happen
208 (orig:origs) -> ppr_skol orig $$
209 vcat [ ptext (sLit "or") <+> ppr_skol orig | orig <- origs ]
211 ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc)
212 ppr_skol skol_info = pprSkolInfo skol_info
214 couldNotDeduce :: [EvVar] -> [PredType] -> SDoc
215 couldNotDeduce givens wanteds
216 = sep [ ptext (sLit "Could not deduce") <+> pprTheta wanteds
217 , nest 2 $ ptext (sLit "from the context")
218 <+> pprEvVarTheta givens]
220 getUserGivens :: ReportErrCtxt -> Maybe [EvVar]
221 -- Just gs => Say "could not deduce ... from gs"
222 -- Nothing => No interesting givens, say something else
223 getUserGivens (CEC {cec_encl = ctxt})
224 | null user_givens = Nothing
225 | otherwise = Just user_givens
227 givens = foldl (\gs ic -> ic_given ic ++ gs) [] ctxt
228 user_givens | opt_PprStyle_Debug = givens
229 | otherwise = filterOut isSelfDict givens
230 -- In user mode, don't show the "self-dict" given
231 -- which is only added to do co-inductive solving
232 -- Rather an awkward hack, but there we are
233 -- This is the only use of isSelfDict, so it's not in an inner loop
237 %************************************************************************
239 Implicit parameter errors
241 %************************************************************************
244 reportIPErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
245 reportIPErrs ctxt ips orig
246 = addErrorReport ctxt $ addArising orig msg
248 msg | Just givens <- getUserGivens ctxt
249 = couldNotDeduce givens ips
251 = sep [ ptext (sLit "Unbound implicit parameter") <> plural ips
252 , nest 2 (pprTheta ips) ]
256 %************************************************************************
260 %************************************************************************
263 reportEqErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
264 reportEqErrs ctxt eqs orig
265 = mapM_ report_one eqs
268 report_one (EqPred ty1 ty2)
269 = do { (env1, extra) <- getWantedEqExtra emptyTvSubst env0 orig ty1 ty2
270 ; let ctxt' = ctxt { cec_tidy = env1
271 , cec_extra = cec_extra ctxt $$ extra }
272 ; reportEqErr ctxt' ty1 ty2 }
274 = pprPanic "reportEqErrs" (ppr pred)
276 reportEqErr :: ReportErrCtxt -> TcType -> TcType -> TcM ()
277 reportEqErr ctxt ty1 ty2
278 | Just tv1 <- tcGetTyVar_maybe ty1 = reportTyVarEqErr ctxt tv1 ty2
279 | Just tv2 <- tcGetTyVar_maybe ty2 = reportTyVarEqErr ctxt tv2 ty1
280 | otherwise -- Neither side is a type variable
281 -- Since the unsolved constraint is canonical,
282 -- it must therefore be of form (F tys ~ ty)
283 = addErrorReport ctxt (msg $$ mkTyFunInfoMsg ty1 ty2)
285 msg = case getUserGivens ctxt of
286 Just givens -> couldNotDeduce givens [EqPred ty1 ty2]
287 Nothing -> misMatchMsg ty1 ty2
289 reportTyVarEqErr :: ReportErrCtxt -> TcTyVar -> TcType -> TcM ()
290 reportTyVarEqErr ctxt tv1 ty2
292 , Just tv2 <- tcGetTyVar_maybe ty2
294 = -- sk ~ alpha: swap
295 reportTyVarEqErr ctxt tv2 ty1
298 = -- sk ~ ty, where ty isn't a meta-tyvar: mis-match
299 addErrTcM (misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2)
301 -- So tv is a meta tyvar, and presumably it is
302 -- an *untouchable* meta tyvar, else it'd have been unified
303 | not (k2 `isSubKind` k1) -- Kind error
304 = addErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2)
306 -- Check for skolem escape
307 | (implic:_) <- cec_encl ctxt -- Get the innermost context
308 , let esc_skols = varSetElems (tyVarsOfType ty2 `intersectVarSet` ic_skols implic)
309 implic_loc = ic_loc implic
310 , not (null esc_skols)
311 = setCtLoc implic_loc $ -- Override the error message location from the
312 -- place the equality arose to the implication site
313 do { (env1, env_sigs) <- findGlobals ctxt (unitVarSet tv1)
314 ; let msg = misMatchMsg ty1 ty2
315 esc_doc | isSingleton esc_skols
316 = ptext (sLit "because this skolem type variable would escape:")
318 = ptext (sLit "because these skolem type variables would escape:")
319 extra1 = vcat [ nest 2 $ esc_doc <+> pprQuotedList esc_skols
320 , sep [ (if isSingleton esc_skols
321 then ptext (sLit "This skolem is")
322 else ptext (sLit "These skolems are"))
323 <+> ptext (sLit "bound by")
324 , nest 2 $ pprSkolInfo (ctLocOrigin implic_loc) ] ]
325 ; addErrTcM (env1, msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) }
327 -- Nastiest case: attempt to unify an untouchable variable
328 | (implic:_) <- cec_encl ctxt -- Get the innermost context
329 , let implic_loc = ic_loc implic
330 given = ic_given implic
331 = setCtLoc (ic_loc implic) $
332 do { let (env1, msg) = misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2
333 extra = vcat [ ptext (sLit "because") <+> ppr tv1 <+> ptext (sLit "is untouchable")
334 , ptext (sLit "inside the constraints") <+> pprEvVarTheta given
335 , nest 2 (ptext (sLit "bound at")
336 <+> pprSkolInfo (ctLocOrigin implic_loc)) ]
337 ; addErrTcM (env1, msg $$ extra) }
339 | otherwise -- I'm not sure how this can happen!
340 = addErrTcM (misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2)
342 is_meta1 = isMetaTyVar tv1
347 mkTyFunInfoMsg :: TcType -> TcType -> SDoc
348 -- See Note [Non-injective type functions]
349 mkTyFunInfoMsg ty1 ty2
350 | Just (tc1,_) <- tcSplitTyConApp_maybe ty1
351 , Just (tc2,_) <- tcSplitTyConApp_maybe ty2
352 , tc1 == tc2, isSynFamilyTyCon tc1
353 = ptext (sLit "NB:") <+> quotes (ppr tc1)
354 <+> ptext (sLit "is a type function") <> (pp_inj tc1)
357 pp_inj tc | isInjectiveTyCon tc = empty
358 | otherwise = ptext (sLit (", and may not be injective"))
360 misMatchMsgWithExtras :: TidyEnv -> TcType -> TcType -> (TidyEnv, SDoc)
361 -- This version is used by TcSimplify too, which doesn't track the
362 -- expected/acutal thing, so we just have ty1 ty2 here
363 -- NB: The types are already tidied
364 misMatchMsgWithExtras env ty1 ty2
365 = (env2, sep [ misMatchMsg ty1 ty2, nest 2 (extra1 $$ extra2) ])
367 (env1, extra1) = typeExtraInfoMsg env ty1
368 (env2, extra2) = typeExtraInfoMsg env1 ty2
370 misMatchMsg :: TcType -> TcType -> SDoc -- Types are already tidy
371 misMatchMsg ty1 ty2 = sep [ ptext (sLit "Couldn't match type") <+> quotes (ppr ty1)
372 , nest 15 $ ptext (sLit "with") <+> quotes (ppr ty2)]
374 kindErrorMsg :: TcType -> TcType -> SDoc -- Types are already tidy
376 = vcat [ ptext (sLit "Kind incompatibility when matching types:")
377 , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1
378 , ppr ty2 <+> dcolon <+> ppr k2 ]) ]
383 typeExtraInfoMsg :: TidyEnv -> Type -> (TidyEnv, SDoc)
384 -- Shows a bit of extra info about skolem constants
385 typeExtraInfoMsg env ty
386 | Just tv <- tcGetTyVar_maybe ty
388 , isSkolemTyVar tv || isSigTyVar tv
390 , let (env1, tv1) = tidySkolemTyVar env tv
391 = (env1, pprSkolTvBinding tv1)
393 typeExtraInfoMsg env _ty = (env, empty) -- Normal case
396 unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc)
397 unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env
398 = do { act_ty' <- zonkTcType act_ty
399 ; exp_ty' <- zonkTcType exp_ty
400 ; let (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
401 (env2, act_ty'') = tidyOpenType env1 act_ty'
402 ; return (env2, mkExpectedActualMsg act_ty'' exp_ty'') }
404 mkExpectedActualMsg :: Type -> Type -> SDoc
405 mkExpectedActualMsg act_ty exp_ty
406 = vcat [ text "Expected type" <> colon <+> ppr exp_ty
407 , text " Actual type" <> colon <+> ppr act_ty ]
410 Note [Non-injective type functions]
411 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
412 It's very confusing to get a message like
413 Couldn't match expected type `Depend s'
414 against inferred type `Depend s1'
415 so mkTyFunInfoMsg adds:
416 NB: `Depend' is type function, and hence may not be injective
418 Warn of loopy local equalities that were dropped.
421 %************************************************************************
425 %************************************************************************
428 reportDictErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
429 reportDictErrs ctxt wanteds orig
430 = do { inst_envs <- tcGetInstEnvs
431 ; let (others, overlaps) = partitionWith (check_overlap inst_envs) wanteds
432 ; unless (null others) $
433 addErrorReport ctxt (mk_no_inst_err others)
434 ; mapM_ (addErrorReport ctxt) overlaps }
436 check_overlap :: (InstEnv,InstEnv) -> PredType -> Either PredType SDoc
437 -- Right msg => overlap message
438 -- Left inst => no instance
439 check_overlap inst_envs pred@(ClassP clas tys)
440 = case lookupInstEnv inst_envs clas tys of
441 ([], _) -> Left pred -- No match
442 -- The case of exactly one match and no unifiers means a
443 -- successful lookup. That can't happen here, because dicts
444 -- only end up here if they didn't match in Inst.lookupInst
446 | debugIsOn -> pprPanic "check_overlap" (ppr pred)
447 res -> Right (mk_overlap_msg pred res)
448 check_overlap _ _ = panic "check_overlap"
450 mk_overlap_msg pred (matches, unifiers)
451 = ASSERT( not (null matches) )
452 vcat [ addArising orig (ptext (sLit "Overlapping instances for")
454 , sep [ptext (sLit "Matching instances") <> colon,
455 nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
456 , if not (isSingleton matches)
457 then -- Two or more matches
459 else -- One match, plus some unifiers
460 ASSERT( not (null unifiers) )
461 parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
462 quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
463 ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
464 ptext (sLit "when compiling the other instance declarations")])]
466 ispecs = [ispec | (ispec, _) <- matches]
468 mk_no_inst_err :: [PredType] -> SDoc
469 mk_no_inst_err wanteds
470 | Just givens <- getUserGivens ctxt
471 = vcat [ addArising orig $ couldNotDeduce givens wanteds
472 , show_fixes (fix1 : fixes2) ]
474 | otherwise -- Top level
475 = vcat [ addArising orig $
476 ptext (sLit "No instance") <> plural wanteds
477 <+> ptext (sLit "for") <+> pprTheta wanteds
478 , show_fixes fixes2 ]
481 fix1 = sep [ ptext (sLit "add") <+> pprTheta wanteds
482 <+> ptext (sLit "to the context of")
483 , nest 2 $ pprErrCtxtLoc ctxt ]
485 fixes2 | null instance_dicts = []
486 | otherwise = [sep [ptext (sLit "add an instance declaration for"),
487 pprTheta instance_dicts]]
488 instance_dicts = filterOut isTyVarClassPred wanteds
489 -- Insts for which it is worth suggesting an adding an
490 -- instance declaration. Exclude tyvar dicts.
492 show_fixes :: [SDoc] -> SDoc
493 show_fixes [] = empty
494 show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"),
495 nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
497 reportAmbigErrs :: ReportErrCtxt -> TcTyVarSet -> [WantedEvVar] -> TcM ()
498 reportAmbigErrs ctxt skols ambigs
499 -- Divide into groups that share a common set of ambiguous tyvars
500 = mapM_ report (equivClasses cmp ambigs_w_tvs)
502 ambigs_w_tvs = [ (d, varSetElems (tyVarsOfWantedEvVar d `minusVarSet` skols))
504 cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
506 report :: [(WantedEvVar, [TcTyVar])] -> TcM ()
509 do { let main_msg = sep [ text "Ambiguous type variable" <> plural tvs
510 <+> pprQuotedList tvs
511 <+> text "in the constraint" <> plural pairs <> colon
512 , nest 2 pp_wanteds ]
513 ; (tidy_env, mono_msg) <- mkMonomorphismMsg ctxt tvs
514 ; addErrTcM (tidy_env, main_msg $$ mono_msg) }
517 (loc, pp_wanteds) = pprWithArising (map fst pairs)
519 mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc)
520 -- There's an error with these Insts; if they have free type variables
521 -- it's probably caused by the monomorphism restriction.
522 -- Try to identify the offending variable
523 -- ASSUMPTION: the Insts are fully zonked
524 mkMonomorphismMsg ctxt inst_tvs
525 = do { dflags <- getDOpts
526 ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
527 ; return (tidy_env, mk_msg dflags docs) }
529 mk_msg _ _ | any isRuntimeUnk inst_tvs
530 = vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
531 (pprWithCommas ppr inst_tvs),
532 ptext (sLit "Use :print or :force to determine these types")]
533 mk_msg _ [] = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)")
534 -- This happens in things like
535 -- f x = show (read "foo")
536 -- where monomorphism doesn't play any role
538 = vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"),
540 monomorphism_fix dflags]
542 monomorphism_fix :: DynFlags -> SDoc
543 monomorphism_fix dflags
544 = ptext (sLit "Probable fix:") <+> vcat
545 [ptext (sLit "give these definition(s) an explicit type signature"),
546 if xopt Opt_MonomorphismRestriction dflags
547 then ptext (sLit "or use -XNoMonomorphismRestriction")
548 else empty] -- Only suggest adding "-XNoMonomorphismRestriction"
549 -- if it is not already set!
552 -----------------------
553 -- findGlobals looks at the value environment and finds values whose
554 -- types mention any of the offending type variables. It has to be
555 -- careful to zonk the Id's type first, so it has to be in the monad.
556 -- We must be careful to pass it a zonked type variable, too.
558 mkEnvSigMsg :: SDoc -> [SDoc] -> SDoc
559 mkEnvSigMsg what env_sigs
560 | null env_sigs = empty
561 | otherwise = vcat [ ptext (sLit "The following variables have types that mention") <+> what
562 , nest 2 (vcat env_sigs) ]
564 findGlobals :: ReportErrCtxt
566 -> TcM (TidyEnv, [SDoc])
569 = do { lcl_ty_env <- case cec_encl ctxt of
571 (i:_) -> return (ic_env i)
572 ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) }
574 go tidy_env acc [] = return (tidy_env, acc)
575 go tidy_env acc (thing : things) = do
576 (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing
578 Just d -> go tidy_env1 (d:acc) things
579 Nothing -> go tidy_env1 acc things
581 ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
583 -----------------------
584 find_thing :: TidyEnv -> (TcType -> Bool)
585 -> TcTyThing -> TcM (TidyEnv, Maybe SDoc)
586 find_thing tidy_env ignore_it (ATcId { tct_id = id })
587 = do { id_ty <- zonkTcType (idType id)
588 ; if ignore_it id_ty then
589 return (tidy_env, Nothing)
591 { let (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
592 msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty
593 , nest 2 (parens (ptext (sLit "bound at") <+>
594 ppr (getSrcLoc id)))]
595 ; return (tidy_env', Just msg) } }
597 find_thing tidy_env ignore_it (ATyVar tv ty)
598 = do { tv_ty <- zonkTcType ty
599 ; if ignore_it tv_ty then
600 return (tidy_env, Nothing)
602 { let -- The name tv is scoped, so we don't need to tidy it
603 (tidy_env1, tidy_ty) = tidyOpenType tidy_env tv_ty
604 msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff
607 eq_stuff | Just tv' <- tcGetTyVar_maybe tv_ty
608 , getOccName tv == getOccName tv' = empty
609 | otherwise = equals <+> ppr tidy_ty
610 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
611 bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
613 ; return (tidy_env1, Just msg) } }
615 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
617 warnDefaulting :: [WantedEvVar] -> Type -> TcM ()
618 warnDefaulting wanteds default_ty
619 = do { warn_default <- doptM Opt_WarnTypeDefaults
620 ; setCtLoc loc $ warnTc warn_default warn_msg }
623 warn_msg = vcat [ ptext (sLit "Defaulting the following constraint(s) to type") <+>
624 quotes (ppr default_ty),
626 (loc, ppr_wanteds) = pprWithArising wanteds
629 %************************************************************************
631 Error from the canonicaliser
632 These ones are called *during* constraint simplification
634 %************************************************************************
637 kindErrorTcS :: CtFlavor -> TcType -> TcType -> TcS ()
638 -- If there's a kind error, we don't want to blindly say "kind error"
639 -- We might, say, be unifying a skolem 'a' with a type 'Int',
640 -- in which case that's the error to report. So we set things
641 -- up to call reportEqErr, which does the business properly
642 kindErrorTcS fl ty1 ty2
643 = wrapEqErrTcS fl ty1 ty2 $ \ env0 ty1 ty2 extra ->
644 do { let ctxt = CEC { cec_encl = []
647 ; reportEqErr ctxt ty1 ty2 }
649 misMatchErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a
650 misMatchErrorTcS fl ty1 ty2
651 = wrapEqErrTcS fl ty1 ty2 $ \ env0 ty1 ty2 extra ->
652 do { let (env1, msg) = misMatchMsgWithExtras env0 ty1 ty2
653 ; failWithTcM (env1, inaccessible_msg $$ msg $$ extra) }
657 Given loc -> hang (ptext (sLit "Inaccessible code in"))
661 = case ctLocOrigin loc of
662 PatSkol dc mc -> sep [ ptext (sLit "a pattern with constructor")
663 <+> quotes (ppr dc) <> comma
664 , ptext (sLit "in") <+> pprMatchContext mc ]
665 other_skol -> pprSkolInfo other_skol
667 occursCheckErrorTcS :: CtFlavor -> TcTyVar -> TcType -> TcS a
668 occursCheckErrorTcS fl tv ty
669 = wrapEqErrTcS fl (mkTyVarTy tv) ty $ \ env0 ty1 ty2 extra2 ->
670 do { let extra1 = sep [ppr ty1, char '=', ppr ty2]
671 ; failWithTcM (env0, hang msg 2 (extra1 $$ extra2)) }
673 msg = text $ "Occurs check: cannot construct the infinite type:"
675 solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a
676 solverDepthErrorTcS depth stack
677 | null stack -- Shouldn't happen unless you say -fcontext-stack=0
678 = wrapErrTcS $ failWith msg
681 setCtFlavorLoc (cc_flavor top_item) $
682 do { env0 <- tcInitTidyEnv
683 ; let ev_vars = map cc_id stack
684 env1 = tidyFreeTyVars env0 free_tvs
685 free_tvs = foldr (unionVarSet . tyVarsOfEvVar) emptyVarSet ev_vars
686 extra = pprEvVars (map (tidyEvVar env1) ev_vars)
687 ; failWithTcM (env1, hang msg 2 extra) }
689 top_item = head stack
690 msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
691 , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
693 flattenForAllErrorTcS :: CtFlavor -> TcType -> Bag CanonicalCt -> TcS a
694 flattenForAllErrorTcS fl ty _bad_eqs
697 do { env0 <- tcInitTidyEnv
698 ; let (env1, ty') = tidyOpenType env0 ty
699 msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:")
701 ; failWithTcM (env1, msg) }
704 %************************************************************************
708 %************************************************************************
711 setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
712 setCtFlavorLoc (Wanted loc) thing = setCtLoc loc thing
713 setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing
714 setCtFlavorLoc (Given loc) thing = setCtLoc loc thing
716 wrapEqErrTcS :: CtFlavor -> TcType -> TcType
717 -> (TidyEnv -> TcType -> TcType -> SDoc -> TcM a)
719 wrapEqErrTcS fl ty1 ty2 thing_inside
720 = do { ty_binds_var <- getTcSTyBinds
721 ; wrapErrTcS $ setCtFlavorLoc fl $
722 do { -- Apply the current substitition
723 -- and zonk to get rid of flatten-skolems
724 ; ty_binds_bag <- readTcRef ty_binds_var
725 ; let subst = mkOpenTvSubst (mkVarEnv (bagToList ty_binds_bag))
726 ; env0 <- tcInitTidyEnv
727 ; (env1, ty1) <- zonkSubstTidy env0 subst ty1
728 ; (env2, ty2) <- zonkSubstTidy env1 subst ty2
729 ; let do_wanted loc = do { (env3, extra) <- getWantedEqExtra subst env2
730 (ctLocOrigin loc) ty1 ty2
731 ; thing_inside env3 ty1 ty2 extra }
733 Wanted loc -> do_wanted loc
734 Derived loc -> do_wanted loc
735 Given {} -> thing_inside env2 ty1 ty2 empty
736 -- We could print more info, but it
737 -- seems to be coming out already
741 getWantedEqExtra :: TvSubst -> TidyEnv -> CtOrigin -> TcType -> TcType
742 -> TcM (TidyEnv, SDoc)
743 getWantedEqExtra subst env0 (TypeEqOrigin item) ty1 ty2
744 -- If the types in the error message are the same
745 -- as the types we are unifying (remember to zonk the latter)
746 -- don't add the extra expected/actual message
748 -- The complication is that the types in the TypeEqOrigin must
750 -- (b) have any TcS-monad pending equalities applied to them
751 -- (hence the passed-in substitution)
752 = do { (env1, act) <- zonkSubstTidy env0 subst (uo_actual item)
753 ; (env2, exp) <- zonkSubstTidy env1 subst (uo_expected item)
754 ; if (act `tcEqType` ty1 && exp `tcEqType` ty2)
755 || (exp `tcEqType` ty1 && act `tcEqType` ty2)
759 return (env2, mkExpectedActualMsg act exp) }
761 getWantedEqExtra _ env0 orig _ _
762 = return (env0, pprArising orig)
764 zonkSubstTidy :: TidyEnv -> TvSubst -> TcType -> TcM (TidyEnv, TcType)
765 -- In general, becore printing a type, we want to
766 -- a) Zonk it. Even during constraint simplification this is
767 -- is important, to un-flatten the flatten skolems in a type
768 -- b) Substitute any solved unification variables. This is
769 -- only important *during* solving, becuase after solving
770 -- the substitution is expressed in the mutable type variables
771 -- But during solving there may be constraint (F xi ~ ty)
772 -- where the substitution has not been applied to the RHS
773 zonkSubstTidy env subst ty
774 = do { ty' <- zonkTcTypeAndSubst subst ty
775 ; return (tidyOpenType env ty') }