3 reportUnsolved, reportUnsolvedImplication, 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 )
35 import StaticFlags( opt_PprStyle_Debug )
36 import Data.List( partition )
37 import Control.Monad( unless )
40 %************************************************************************
42 \section{Errors and contexts}
44 %************************************************************************
46 ToDo: for these error messages, should we note the location as coming
47 from the insts, or just whatever seems to be around in the monad just
51 reportUnsolved :: (CanonicalCts, Bag Implication) -> TcM ()
52 reportUnsolved (unsolved_flats, unsolved_implics)
56 = do { env0 <- tcInitTidyEnv
57 ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfWanteds unsolved)
58 tidy_unsolved = tidyWanteds tidy_env unsolved
59 err_ctxt = CEC { cec_encl = []
61 , cec_tidy = tidy_env }
62 ; traceTc "reportUnsolved" (ppr unsolved)
63 ; reportTidyWanteds err_ctxt tidy_unsolved }
65 unsolved = mkWantedConstraints unsolved_flats unsolved_implics
67 reportUnsolvedWantedEvVars :: Bag WantedEvVar -> TcM ()
68 reportUnsolvedWantedEvVars wanteds
72 = do { env0 <- tcInitTidyEnv
73 ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfWantedEvVars wanteds)
74 tidy_unsolved = tidyWantedEvVars tidy_env wanteds
75 err_ctxt = CEC { cec_encl = []
77 , cec_tidy = tidy_env }
78 ; groupErrs (reportFlat err_ctxt) (bagToList tidy_unsolved) }
80 reportUnsolvedDeriv :: [PredType] -> WantedLoc -> TcM ()
81 reportUnsolvedDeriv unsolved loc
86 do { env0 <- tcInitTidyEnv
87 ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfTheta unsolved)
88 tidy_unsolved = map (tidyPred tidy_env) unsolved
89 err_ctxt = CEC { cec_encl = []
91 , cec_tidy = tidy_env }
92 ; reportFlat err_ctxt tidy_unsolved (ctLocOrigin loc) }
94 alt_fix = vcat [ptext (sLit "Alternatively, use a standalone 'deriving instance' declaration,"),
95 nest 2 $ ptext (sLit "so you can specify the instance context yourself")]
97 reportUnsolvedImplication :: Implication -> TcM ()
98 reportUnsolvedImplication implic
99 = do { env0 <- tcInitTidyEnv
100 ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfImplication implic)
101 tidy_implic = tidyImplication tidy_env implic
102 new_tidy_env = foldNameEnv add tidy_env (ic_env implic)
103 err_ctxt = CEC { cec_encl = [tidy_implic]
105 , cec_tidy = new_tidy_env }
106 ; reportTidyWanteds err_ctxt (ic_wanted tidy_implic) }
108 -- Extend the tidy env with a mapping from tyvars to the
109 -- names the user originally used. At the moment we do this
110 -- from the type env, but it might be better to record the
111 -- scoped type variable in the Implication. Urgh.
112 add (ATyVar name ty) (occ_env, var_env)
113 | Just tv <- tcGetTyVar_maybe ty
114 , not (getUnique name `elemVarEnvByKey` var_env)
115 = case tidyOccName occ_env (nameOccName name) of
116 (occ_env', occ') -> (occ_env', extendVarEnv var_env tv tv')
118 tv' = setTyVarName tv name'
119 name' = tidyNameOcc name occ'
120 add _ tidy_env = tidy_env
123 = CEC { cec_encl :: [Implication] -- Enclosing implications
125 , cec_tidy :: TidyEnv
126 , cec_extra :: SDoc -- Add this to each error message
129 reportTidyImplic :: ReportErrCtxt -> Implication -> TcM ()
130 reportTidyImplic ctxt implic
131 = reportTidyWanteds ctxt' (ic_wanted implic)
133 ctxt' = ctxt { cec_encl = implic : cec_encl ctxt }
135 reportTidyWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
136 reportTidyWanteds ctxt unsolved
137 = do { let (flats, implics) = splitWanteds unsolved
138 (ambigs, others) = partition is_ambiguous (bagToList flats)
139 ; groupErrs (reportFlat ctxt) others
140 ; mapBagM_ (reportTidyImplic ctxt) implics
141 ; ifErrsM (return ()) $
142 -- Only report ambiguity if no other errors happened
143 -- See Note [Avoiding spurious errors]
144 reportAmbigErrs ctxt skols ambigs }
146 skols = foldr (unionVarSet . ic_skols) emptyVarSet (cec_encl ctxt)
148 -- Treat it as "ambiguous" if
149 -- (a) it is a class constraint
150 -- (b) it constrains only type variables
151 -- (else we'd prefer to report it as "no instance for...")
152 -- (c) it mentions type variables that are not skolems
153 is_ambiguous d = isTyVarClassPred pred
154 && not (tyVarsOfPred pred `subVarSet` skols)
156 pred = wantedEvVarPred d
158 reportFlat :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
159 reportFlat ctxt flats origin
160 = do { unless (null dicts) $ reportDictErrs ctxt dicts origin
161 ; unless (null eqs) $ reportEqErrs ctxt eqs origin
162 ; unless (null ips) $ reportIPErrs ctxt ips origin
163 ; ASSERT( null others ) return () }
165 (dicts, non_dicts) = partition isClassPred flats
166 (eqs, non_eqs) = partition isEqPred non_dicts
167 (ips, others) = partition isIPPred non_eqs
169 --------------------------------------------
171 --------------------------------------------
173 groupErrs :: ([PredType] -> CtOrigin -> TcM ()) -- Deal with one group
174 -> [WantedEvVar] -- Unsolved wanteds
176 -- Group together insts with the same origin
177 -- We want to report them together in error messages
181 groupErrs report_err (wanted : wanteds)
182 = do { setCtLoc the_loc $
183 report_err the_vars (ctLocOrigin the_loc)
184 ; groupErrs report_err others }
186 the_loc = wantedEvVarLoc wanted
187 the_key = mk_key the_loc
188 the_vars = map wantedEvVarPred (wanted:friends)
189 (friends, others) = partition is_friend wanteds
190 is_friend friend = mk_key (wantedEvVarLoc friend) == the_key
192 mk_key :: WantedLoc -> (SrcSpan, String)
193 mk_key loc = (ctLocSpan loc, showSDoc (ppr (ctLocOrigin loc)))
194 -- It may seem crude to compare the error messages,
195 -- but it makes sure that we combine just what the user sees,
196 -- and it avoids need equality on InstLocs.
198 -- Add the "arising from..." part to a message about bunch of dicts
199 addArising :: CtOrigin -> SDoc -> SDoc
200 addArising orig msg = msg $$ nest 2 (pprArising orig)
202 pprWithArising :: [WantedEvVar] -> (WantedLoc, SDoc)
203 -- Print something like
204 -- (Eq a) arising from a use of x at y
205 -- (Show a) arising froma use of p at q
206 -- Also return a location for the erroe message
208 = panic "pprWithArising"
209 pprWithArising [WantedEvVar ev loc]
210 = (loc, pprEvVarTheta [ev] <+> pprArising (ctLocOrigin loc))
211 pprWithArising ev_vars
212 = (first_loc, vcat (map ppr_one ev_vars))
214 first_loc = wantedEvVarLoc (head ev_vars)
215 ppr_one (WantedEvVar v loc)
216 = parens (pprPred (evVarPred v)) <+> pprArisingAt loc
218 addErrorReport :: ReportErrCtxt -> SDoc -> TcM ()
219 addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt)
221 pprErrCtxtLoc :: ReportErrCtxt -> SDoc
223 = case map (ctLocOrigin . ic_loc) (cec_encl ctxt) of
224 [] -> ptext (sLit "the top level") -- Should not happen
225 (orig:origs) -> ppr_skol orig $$
226 vcat [ ptext (sLit "or") <+> ppr_skol orig | orig <- origs ]
228 ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc)
229 ppr_skol skol_info = pprSkolInfo skol_info
231 couldNotDeduce :: [EvVar] -> [PredType] -> SDoc
232 couldNotDeduce givens wanteds
233 = sep [ ptext (sLit "Could not deduce") <+> pprTheta wanteds
234 , nest 2 $ ptext (sLit "from the context")
235 <+> pprEvVarTheta givens]
237 getUserGivens :: ReportErrCtxt -> Maybe [EvVar]
238 -- Just gs => Say "could not deduce ... from gs"
239 -- Nothing => No interesting givens, say something else
240 getUserGivens (CEC {cec_encl = ctxt})
241 | null user_givens = Nothing
242 | otherwise = Just user_givens
244 givens = foldl (\gs ic -> ic_given ic ++ gs) [] ctxt
245 user_givens | opt_PprStyle_Debug = givens
246 | otherwise = filterOut isSelfDict givens
247 -- In user mode, don't show the "self-dict" given
248 -- which is only added to do co-inductive solving
249 -- Rather an awkward hack, but there we are
250 -- This is the only use of isSelfDict, so it's not in an inner loop
254 %************************************************************************
256 Implicit parameter errors
258 %************************************************************************
261 reportIPErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
262 reportIPErrs ctxt ips orig
263 = addErrorReport ctxt $ addArising orig msg
265 msg | Just givens <- getUserGivens ctxt
266 = couldNotDeduce givens ips
268 = sep [ ptext (sLit "Unbound implicit parameter") <> plural ips
269 , nest 2 (pprTheta ips) ]
273 %************************************************************************
277 %************************************************************************
280 reportEqErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
281 reportEqErrs ctxt eqs orig
282 = mapM_ report_one eqs
284 report_one (EqPred ty1 ty2)
285 = do { (env1, extra) <- getWantedEqExtra (cec_tidy ctxt) orig ty1 ty2
286 ; let ctxt' = ctxt { cec_tidy = env1
287 , cec_extra = cec_extra ctxt $$ extra }
288 ; reportEqErr ctxt' ty1 ty2 }
290 = pprPanic "reportEqErrs" (ppr pred)
292 reportEqErr :: ReportErrCtxt -> TcType -> TcType -> TcM ()
293 reportEqErr ctxt ty1 ty2
294 | Just tv1 <- tcGetTyVar_maybe ty1 = reportTyVarEqErr ctxt tv1 ty2
295 | Just tv2 <- tcGetTyVar_maybe ty2 = reportTyVarEqErr ctxt tv2 ty1
296 | otherwise -- Neither side is a type variable
297 -- Since the unsolved constraint is canonical,
298 -- it must therefore be of form (F tys ~ ty)
299 = addErrorReport ctxt (msg $$ mkTyFunInfoMsg ty1 ty2)
301 msg = case getUserGivens ctxt of
302 Just givens -> couldNotDeduce givens [EqPred ty1 ty2]
303 Nothing -> misMatchMsg ty1 ty2
305 reportTyVarEqErr :: ReportErrCtxt -> TcTyVar -> TcType -> TcM ()
306 reportTyVarEqErr ctxt tv1 ty2
308 , Just tv2 <- tcGetTyVar_maybe ty2
310 = -- sk ~ alpha: swap
311 reportTyVarEqErr ctxt tv2 ty1
314 = -- sk ~ ty, where ty isn't a meta-tyvar: mis-match
315 addErrTcM (misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2)
317 -- So tv is a meta tyvar, and presumably it is
318 -- an *untouchable* meta tyvar, else it'd have been unified
319 | not (k2 `isSubKind` k1) -- Kind error
320 = addErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2)
322 -- Check for skolem escape
323 | (implic:_) <- cec_encl ctxt -- Get the innermost context
324 , let esc_skols = varSetElems (tyVarsOfType ty2 `intersectVarSet` ic_skols implic)
325 implic_loc = ic_loc implic
326 , not (null esc_skols)
327 = setCtLoc implic_loc $ -- Override the error message location from the
328 -- place the equality arose to the implication site
329 do { (env1, env_sigs) <- findGlobals ctxt (unitVarSet tv1)
330 ; let msg = misMatchMsg ty1 ty2
331 esc_doc | isSingleton esc_skols
332 = ptext (sLit "because this skolem type variable would escape:")
334 = ptext (sLit "because these skolem type variables would escape:")
335 extra1 = vcat [ nest 2 $ esc_doc <+> pprQuotedList esc_skols
336 , sep [ (if isSingleton esc_skols
337 then ptext (sLit "This skolem is")
338 else ptext (sLit "These skolems are"))
339 <+> ptext (sLit "bound by")
340 , nest 2 $ pprSkolInfo (ctLocOrigin implic_loc) ] ]
341 ; addErrTcM (env1, msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) }
343 -- Nastiest case: attempt to unify an untouchable variable
344 | (implic:_) <- cec_encl ctxt -- Get the innermost context
345 , let implic_loc = ic_loc implic
346 given = ic_given implic
347 = setCtLoc (ic_loc implic) $
348 do { let (env1, msg) = misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2
349 extra = vcat [ ptext (sLit "because") <+> ppr tv1 <+> ptext (sLit "is untouchable")
350 , ptext (sLit "inside the constraints") <+> pprEvVarTheta given
351 , nest 2 (ptext (sLit "bound at")
352 <+> pprSkolInfo (ctLocOrigin implic_loc)) ]
353 ; addErrTcM (env1, msg $$ extra) }
355 | otherwise -- I'm not sure how this can happen!
356 = addErrTcM (misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2)
358 is_meta1 = isMetaTyVar tv1
363 mkTyFunInfoMsg :: TcType -> TcType -> SDoc
364 -- See Note [Non-injective type functions]
365 mkTyFunInfoMsg ty1 ty2
366 | Just (tc1,_) <- tcSplitTyConApp_maybe ty1
367 , Just (tc2,_) <- tcSplitTyConApp_maybe ty2
368 , tc1 == tc2, isSynFamilyTyCon tc1
369 = ptext (sLit "NB:") <+> quotes (ppr tc1)
370 <+> ptext (sLit "is a type function") <> (pp_inj tc1)
373 pp_inj tc | isInjectiveTyCon tc = empty
374 | otherwise = ptext (sLit (", and may not be injective"))
376 misMatchMsgWithExtras :: TidyEnv -> TcType -> TcType -> (TidyEnv, SDoc)
377 -- This version is used by TcSimplify too, which doesn't track the
378 -- expected/acutal thing, so we just have ty1 ty2 here
379 -- NB: The types are already tidied
380 misMatchMsgWithExtras env ty1 ty2
381 = (env2, sep [ misMatchMsg ty1 ty2, nest 2 (extra1 $$ extra2) ])
383 (env1, extra1) = typeExtraInfoMsg env ty1
384 (env2, extra2) = typeExtraInfoMsg env1 ty2
386 misMatchMsg :: TcType -> TcType -> SDoc -- Types are already tidy
387 misMatchMsg ty1 ty2 = sep [ ptext (sLit "Couldn't match type") <+> quotes (ppr ty1)
388 , nest 15 $ ptext (sLit "with") <+> quotes (ppr ty2)]
390 kindErrorMsg :: TcType -> TcType -> SDoc -- Types are already tidy
392 = vcat [ ptext (sLit "Kind incompatibility when matching types:")
393 , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1
394 , ppr ty2 <+> dcolon <+> ppr k2 ]) ]
399 typeExtraInfoMsg :: TidyEnv -> Type -> (TidyEnv, SDoc)
400 -- Shows a bit of extra info about skolem constants
401 typeExtraInfoMsg env ty
402 | Just tv <- tcGetTyVar_maybe ty
404 , isSkolemTyVar tv || isSigTyVar tv
406 , let (env1, tv1) = tidySkolemTyVar env tv
407 = (env1, pprSkolTvBinding tv1)
409 typeExtraInfoMsg env _ty = (env, empty) -- Normal case
412 unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc)
413 unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env
414 = do { act_ty' <- zonkTcType act_ty
415 ; exp_ty' <- zonkTcType exp_ty
416 ; let (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
417 (env2, act_ty'') = tidyOpenType env1 act_ty'
418 ; return (env2, mkExpectedActualMsg act_ty'' exp_ty'') }
420 mkExpectedActualMsg :: Type -> Type -> SDoc
421 mkExpectedActualMsg act_ty exp_ty
422 = vcat [ text "Expected type" <> colon <+> ppr exp_ty
423 , text " Actual type" <> colon <+> ppr act_ty ]
426 Note [Non-injective type functions]
427 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
428 It's very confusing to get a message like
429 Couldn't match expected type `Depend s'
430 against inferred type `Depend s1'
431 so mkTyFunInfoMsg adds:
432 NB: `Depend' is type function, and hence may not be injective
434 Warn of loopy local equalities that were dropped.
437 %************************************************************************
441 %************************************************************************
444 reportDictErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
445 reportDictErrs ctxt wanteds orig
446 = do { inst_envs <- tcGetInstEnvs
447 ; let (others, overlaps) = partitionWith (check_overlap inst_envs) wanteds
448 ; unless (null others) $
449 addErrorReport ctxt (mk_no_inst_err others)
450 ; mapM_ (addErrorReport ctxt) overlaps }
452 check_overlap :: (InstEnv,InstEnv) -> PredType -> Either PredType SDoc
453 -- Right msg => overlap message
454 -- Left inst => no instance
455 check_overlap inst_envs pred@(ClassP clas tys)
456 = case lookupInstEnv inst_envs clas tys of
457 ([], _) -> Left pred -- No match
458 -- The case of exactly one match and no unifiers means a
459 -- successful lookup. That can't happen here, because dicts
460 -- only end up here if they didn't match in Inst.lookupInst
462 | debugIsOn -> pprPanic "check_overlap" (ppr pred)
463 res -> Right (mk_overlap_msg pred res)
464 check_overlap _ _ = panic "check_overlap"
466 mk_overlap_msg pred (matches, unifiers)
467 = ASSERT( not (null matches) )
468 vcat [ addArising orig (ptext (sLit "Overlapping instances for")
470 , sep [ptext (sLit "Matching instances") <> colon,
471 nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
472 , if not (isSingleton matches)
473 then -- Two or more matches
475 else -- One match, plus some unifiers
476 ASSERT( not (null unifiers) )
477 parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
478 quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
479 ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
480 ptext (sLit "when compiling the other instance declarations")])]
482 ispecs = [ispec | (ispec, _) <- matches]
484 mk_no_inst_err :: [PredType] -> SDoc
485 mk_no_inst_err wanteds
486 | Just givens <- getUserGivens ctxt
487 = vcat [ addArising orig $ couldNotDeduce givens wanteds
488 , show_fixes (fix1 : fixes2) ]
490 | otherwise -- Top level
491 = vcat [ addArising orig $
492 ptext (sLit "No instance") <> plural wanteds
493 <+> ptext (sLit "for") <+> pprTheta wanteds
494 , show_fixes fixes2 ]
497 fix1 = sep [ ptext (sLit "add") <+> pprTheta wanteds
498 <+> ptext (sLit "to the context of")
499 , nest 2 $ pprErrCtxtLoc ctxt ]
501 fixes2 | null instance_dicts = []
502 | otherwise = [sep [ptext (sLit "add an instance declaration for"),
503 pprTheta instance_dicts]]
504 instance_dicts = filterOut isTyVarClassPred wanteds
505 -- Insts for which it is worth suggesting an adding an
506 -- instance declaration. Exclude tyvar dicts.
508 show_fixes :: [SDoc] -> SDoc
509 show_fixes [] = empty
510 show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"),
511 nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
513 reportAmbigErrs :: ReportErrCtxt -> TcTyVarSet -> [WantedEvVar] -> TcM ()
514 reportAmbigErrs ctxt skols ambigs
515 -- Divide into groups that share a common set of ambiguous tyvars
516 = mapM_ report (equivClasses cmp ambigs_w_tvs)
518 ambigs_w_tvs = [ (d, varSetElems (tyVarsOfWantedEvVar d `minusVarSet` skols))
520 cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
522 report :: [(WantedEvVar, [TcTyVar])] -> TcM ()
525 do { let main_msg = sep [ text "Ambiguous type variable" <> plural tvs
526 <+> pprQuotedList tvs
527 <+> text "in the constraint" <> plural pairs <> colon
528 , nest 2 pp_wanteds ]
529 ; (tidy_env, mono_msg) <- mkMonomorphismMsg ctxt tvs
530 ; addErrTcM (tidy_env, main_msg $$ mono_msg) }
533 (loc, pp_wanteds) = pprWithArising (map fst pairs)
535 mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc)
536 -- There's an error with these Insts; if they have free type variables
537 -- it's probably caused by the monomorphism restriction.
538 -- Try to identify the offending variable
539 -- ASSUMPTION: the Insts are fully zonked
540 mkMonomorphismMsg ctxt inst_tvs
541 = do { dflags <- getDOpts
542 ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
543 ; return (tidy_env, mk_msg dflags docs) }
545 mk_msg _ _ | any isRuntimeUnk inst_tvs
546 = vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
547 (pprWithCommas ppr inst_tvs),
548 ptext (sLit "Use :print or :force to determine these types")]
549 mk_msg _ [] = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)")
550 -- This happens in things like
551 -- f x = show (read "foo")
552 -- where monomorphism doesn't play any role
554 = vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"),
556 monomorphism_fix dflags]
558 monomorphism_fix :: DynFlags -> SDoc
559 monomorphism_fix dflags
560 = ptext (sLit "Probable fix:") <+> vcat
561 [ptext (sLit "give these definition(s) an explicit type signature"),
562 if dopt Opt_MonomorphismRestriction dflags
563 then ptext (sLit "or use -XNoMonomorphismRestriction")
564 else empty] -- Only suggest adding "-XNoMonomorphismRestriction"
565 -- if it is not already set!
568 -----------------------
569 -- findGlobals looks at the value environment and finds values whose
570 -- types mention any of the offending type variables. It has to be
571 -- careful to zonk the Id's type first, so it has to be in the monad.
572 -- We must be careful to pass it a zonked type variable, too.
574 mkEnvSigMsg :: SDoc -> [SDoc] -> SDoc
575 mkEnvSigMsg what env_sigs
576 | null env_sigs = empty
577 | otherwise = vcat [ ptext (sLit "The following variables have types that mention") <+> what
578 , nest 2 (vcat env_sigs) ]
580 findGlobals :: ReportErrCtxt
582 -> TcM (TidyEnv, [SDoc])
585 = do { lcl_ty_env <- case cec_encl ctxt of
587 (i:_) -> return (ic_env i)
588 ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) }
590 go tidy_env acc [] = return (tidy_env, acc)
591 go tidy_env acc (thing : things) = do
592 (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing
594 Just d -> go tidy_env1 (d:acc) things
595 Nothing -> go tidy_env1 acc things
597 ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
599 -----------------------
600 find_thing :: TidyEnv -> (TcType -> Bool)
601 -> TcTyThing -> TcM (TidyEnv, Maybe SDoc)
602 find_thing tidy_env ignore_it (ATcId { tct_id = id })
603 = do { id_ty <- zonkTcType (idType id)
604 ; if ignore_it id_ty then
605 return (tidy_env, Nothing)
607 { let (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
608 msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty
609 , nest 2 (parens (ptext (sLit "bound at") <+>
610 ppr (getSrcLoc id)))]
611 ; return (tidy_env', Just msg) } }
613 find_thing tidy_env ignore_it (ATyVar tv ty)
614 = do { tv_ty <- zonkTcType ty
615 ; if ignore_it tv_ty then
616 return (tidy_env, Nothing)
618 { let -- The name tv is scoped, so we don't need to tidy it
619 (tidy_env1, tidy_ty) = tidyOpenType tidy_env tv_ty
620 msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff
623 eq_stuff | Just tv' <- tcGetTyVar_maybe tv_ty
624 , getOccName tv == getOccName tv' = empty
625 | otherwise = equals <+> ppr tidy_ty
626 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
627 bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
629 ; return (tidy_env1, Just msg) } }
631 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
633 warnDefaulting :: [WantedEvVar] -> Type -> TcM ()
634 warnDefaulting wanteds default_ty
635 = do { warn_default <- doptM Opt_WarnTypeDefaults
636 ; setCtLoc loc $ warnTc warn_default warn_msg }
639 warn_msg = vcat [ ptext (sLit "Defaulting the following constraint(s) to type") <+>
640 quotes (ppr default_ty),
642 (loc, ppr_wanteds) = pprWithArising wanteds
645 %************************************************************************
647 Error from the canonicaliser
649 %************************************************************************
652 kindErrorTcS :: CtFlavor -> TcType -> TcType -> TcS ()
653 -- If there's a kind error, we don't want to blindly say "kind error"
654 -- We might, say, be unifying a skolem 'a' with a type 'Int',
655 -- in which case that's the error to report. So we set things
656 -- up to call reportEqErr, which does the business properly
657 kindErrorTcS fl ty1 ty2
660 do { env0 <- tcInitTidyEnv
661 ; (env1, extra) <- getEqExtra env0 fl ty1 ty2
662 ; let (env2, ty1') = tidyOpenType env1 ty1
663 (env3, ty2') = tidyOpenType env2 ty2
664 ctxt = CEC { cec_encl = []
667 ; reportEqErr ctxt ty1' ty2' }
669 misMatchErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a
670 misMatchErrorTcS fl ty1 ty2
673 do { env0 <- tcInitTidyEnv
674 ; let (env1, ty1') = tidyOpenType env0 ty1
675 (env2, ty2') = tidyOpenType env1 ty2
676 (env3, msg) = misMatchMsgWithExtras env2 ty1' ty2'
677 ; (env4, extra) <- getEqExtra env3 fl ty1 ty2
678 ; failWithTcM (env4, inaccessible_msg $$ msg $$ extra) }
682 Given loc -> hang (ptext (sLit "Inaccessible code in"))
686 = case ctLocOrigin loc of
687 PatSkol dc mc -> sep [ ptext (sLit "a pattern with constructor")
688 <+> quotes (ppr dc) <> comma
689 , ptext (sLit "in") <+> pprMatchContext mc ]
690 other_skol -> pprSkolInfo other_skol
692 occursCheckErrorTcS :: CtFlavor -> TcTyVar -> TcType -> TcS a
693 occursCheckErrorTcS fl tv ty
696 do { env0 <- tcInitTidyEnv
697 ; let (env1, tv') = tidyOpenTyVar env0 tv
698 (env2, ty') = tidyOpenType env1 ty
699 extra1 = sep [ppr tv', char '=', ppr ty']
700 ; (env3, extra2) <- getEqExtra env2 fl (mkTyVarTy tv) ty
701 ; failWithTcM (env3, hang msg 2 (extra1 $$ extra2)) }
703 msg = text $ "Occurs check: cannot construct the infinite type:"
705 solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a
706 solverDepthErrorTcS depth stack
707 | null stack -- Shouldn't happen unless you say -fcontext-stack=0
708 = wrapErrTcS $ failWith msg
711 setCtFlavorLoc (cc_flavor top_item) $
712 do { env0 <- tcInitTidyEnv
713 ; let ev_vars = map cc_id stack
714 env1 = tidyFreeTyVars env0 free_tvs
715 free_tvs = foldr (unionVarSet . tyVarsOfEvVar) emptyVarSet ev_vars
716 extra = pprEvVars (map (tidyEvVar env1) ev_vars)
717 ; failWithTcM (env1, hang msg 2 extra) }
719 top_item = head stack
720 msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
721 , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
723 flattenForAllErrorTcS :: CtFlavor -> TcType -> Bag CanonicalCt -> TcS a
724 flattenForAllErrorTcS fl ty _bad_eqs
727 do { env0 <- tcInitTidyEnv
728 ; let (env1, ty') = tidyOpenType env0 ty
729 msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:")
731 ; failWithTcM (env1, msg) }
734 %************************************************************************
738 %************************************************************************
741 setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
742 setCtFlavorLoc (Wanted loc) thing = setCtLoc loc thing
743 setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing
744 setCtFlavorLoc (Given loc) thing = setCtLoc loc thing
746 getEqExtra :: TidyEnv -> CtFlavor -> TcType -> TcType -> TcM (TidyEnv, SDoc)
747 getEqExtra env (Wanted loc) ty1 ty2 = getWantedEqExtra env (ctLocOrigin loc) ty1 ty2
748 getEqExtra env (Derived loc) ty1 ty2 = getWantedEqExtra env (ctLocOrigin loc) ty1 ty2
749 getEqExtra env (Given _) _ _ = return (env, empty)
750 -- We could print more info, but it seems to be already coming out
752 getWantedEqExtra :: TidyEnv -> CtOrigin -> TcType -> TcType -> TcM (TidyEnv, SDoc)
753 getWantedEqExtra env0 (TypeEqOrigin item) ty1 ty2
754 -- If the types in the error message are the same
755 -- as the types we are unifying (remember to zonk the latter)
756 -- don't add the extra expected/actual message
757 = do { act <- zonkTcType (uo_actual item)
758 ; exp <- zonkTcType (uo_expected item)
759 ; if (act `tcEqType` ty1 && exp `tcEqType` ty2)
760 || (exp `tcEqType` ty1 && act `tcEqType` ty2)
764 { let (env1, exp') = tidyOpenType env0 exp
765 (env2, act') = tidyOpenType env1 act
766 ; return (env2, mkExpectedActualMsg act' exp') } }
768 getWantedEqExtra env0 orig _ _
769 = return (env0, pprArising orig)