3 reportUnsolved, reportUnsolvedImplication, reportUnsolvedDeriv,
4 reportUnsolvedWantedEvVars, warnDefaulting, typeExtraInfoMsg,
5 kindErrorTcS, misMatchErrorTcS, flattenForAllErrorTcS,
6 occursCheckErrorTcS, solverDepthErrorTcS
9 #include "HsVersions.h"
22 import HsExpr ( pprMatchContext )
28 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 { env0 <- tcInitTidyEnv
56 ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfWanteds unsolved)
57 tidy_unsolved = tidyWanteds tidy_env unsolved
58 err_ctxt = CEC { cec_encl = []
60 , cec_tidy = tidy_env }
61 ; traceTc "reportUnsolved" (ppr unsolved)
62 ; reportTidyWanteds err_ctxt tidy_unsolved }
64 unsolved = mkWantedConstraints unsolved_flats unsolved_implics
66 reportUnsolvedWantedEvVars :: Bag WantedEvVar -> TcM ()
67 reportUnsolvedWantedEvVars wanteds
71 = do { env0 <- tcInitTidyEnv
72 ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfWantedEvVars wanteds)
73 tidy_unsolved = tidyWantedEvVars tidy_env wanteds
74 err_ctxt = CEC { cec_encl = []
76 , cec_tidy = tidy_env }
77 ; groupErrs (reportFlat err_ctxt) (bagToList tidy_unsolved) }
79 reportUnsolvedDeriv :: [PredType] -> WantedLoc -> TcM ()
80 reportUnsolvedDeriv unsolved loc
84 = do { env0 <- tcInitTidyEnv
85 ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfTheta unsolved)
86 tidy_unsolved = map (tidyPred tidy_env) unsolved
87 err_ctxt = CEC { cec_encl = []
89 , cec_tidy = tidy_env }
90 ; reportFlat err_ctxt tidy_unsolved loc }
92 alt_fix = vcat [ptext (sLit "Alternatively, use a standalone 'deriving instance' declaration,"),
93 nest 2 $ ptext (sLit "so you can specify the instance context yourself")]
95 reportUnsolvedImplication :: Implication -> TcM ()
96 reportUnsolvedImplication implic
97 = do { env0 <- tcInitTidyEnv
98 ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfImplication implic)
99 tidy_implic = tidyImplication tidy_env implic
100 new_tidy_env = foldNameEnv add tidy_env (ic_env implic)
101 err_ctxt = CEC { cec_encl = [tidy_implic]
103 , cec_tidy = new_tidy_env }
104 ; reportTidyWanteds err_ctxt (ic_wanted tidy_implic) }
106 -- Extend the tidy env with a mapping from tyvars to the
107 -- names the user originally used. At the moment we do this
108 -- from the type env, but it might be better to record the
109 -- scoped type variable in the Implication. Urgh.
110 add (ATyVar name ty) (occ_env, var_env)
111 | Just tv <- tcGetTyVar_maybe ty
112 , not (getUnique name `elemVarEnvByKey` var_env)
113 = case tidyOccName occ_env (nameOccName name) of
114 (occ_env', occ') -> (occ_env', extendVarEnv var_env tv tv')
116 tv' = setTyVarName tv name'
117 name' = tidyNameOcc name occ'
118 add _ tidy_env = tidy_env
121 = CEC { cec_encl :: [Implication] -- Enclosing implications
123 , cec_tidy :: TidyEnv
124 , cec_extra :: SDoc -- Add this to each error message
127 reportTidyImplic :: ReportErrCtxt -> Implication -> TcM ()
128 reportTidyImplic ctxt implic
129 = reportTidyWanteds ctxt' (ic_wanted implic)
131 ctxt' = ctxt { cec_encl = implic : cec_encl ctxt }
133 reportTidyWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
134 reportTidyWanteds ctxt unsolved
135 = do { let (flats, implics) = splitWanteds unsolved
136 (ambigs, others) = partition is_ambiguous (bagToList flats)
137 ; groupErrs (reportFlat ctxt) others
138 ; mapBagM_ (reportTidyImplic ctxt) implics
139 ; ifErrsM (return ()) $
140 -- Only report ambiguity if no other errors happened
141 -- See Note [Avoiding spurious errors]
142 reportAmbigErrs ctxt skols ambigs }
144 skols = foldr (unionVarSet . ic_skols) emptyVarSet (cec_encl ctxt)
146 -- Treat it as "ambiguous" if
147 -- (a) it is a class constraint
148 -- (b) it constrains only type variables
149 -- (else we'd prefer to report it as "no instance for...")
150 -- (c) it mentions type variables that are not skolems
151 is_ambiguous d = isTyVarClassPred pred
152 && not (tyVarsOfPred pred `subVarSet` skols)
154 pred = wantedEvVarPred d
156 reportFlat :: ReportErrCtxt -> [PredType] -> WantedLoc -> TcM ()
157 reportFlat ctxt flats loc
158 = do { unless (null dicts) $ reportDictErrs ctxt dicts loc
159 ; unless (null eqs) $ reportEqErrs ctxt eqs loc
160 ; unless (null ips) $ reportIPErrs ctxt ips loc
161 ; ASSERT( null others ) return () }
163 (dicts, non_dicts) = partition isClassPred flats
164 (eqs, non_eqs) = partition isEqPred non_dicts
165 (ips, others) = partition isIPPred non_eqs
167 --------------------------------------------
169 --------------------------------------------
171 groupErrs :: ([PredType] -> WantedLoc -> TcM ()) -- Deal with one group
172 -> [WantedEvVar] -- Unsolved wanteds
174 -- Group together insts with the same origin
175 -- We want to report them together in error messages
179 groupErrs report_err (wanted : wanteds)
180 = do { setCtLoc the_loc $ report_err the_vars the_loc
181 ; groupErrs report_err others }
183 the_loc = wantedEvVarLoc wanted
184 the_key = mk_key the_loc
185 the_vars = map wantedEvVarPred (wanted:friends)
186 (friends, others) = partition is_friend wanteds
187 is_friend friend = mk_key (wantedEvVarLoc friend) == the_key
189 mk_key :: WantedLoc -> (SrcSpan, String)
190 mk_key loc = (ctLocSpan loc, showSDoc (ppr (ctLocOrigin loc)))
191 -- It may seem crude to compare the error messages,
192 -- but it makes sure that we combine just what the user sees,
193 -- and it avoids need equality on InstLocs.
195 -- Add the "arising from..." part to a message about bunch of dicts
196 addArising :: WantedLoc -> SDoc -> SDoc
197 addArising loc msg = msg $$ nest 2 (pprArising loc)
199 pprWithArising :: [WantedEvVar] -> (WantedLoc, SDoc)
200 -- Print something like
201 -- (Eq a) arising from a use of x at y
202 -- (Show a) arising froma use of p at q
203 -- Also return a location for the erroe message
205 = panic "pprWithArising"
206 pprWithArising [WantedEvVar ev loc]
207 = (loc, pprEvVarTheta [ev] <+> pprArising loc)
208 pprWithArising ev_vars
209 = (first_loc, vcat (map ppr_one ev_vars))
211 first_loc = wantedEvVarLoc (head ev_vars)
212 ppr_one (WantedEvVar v loc)
213 = parens (pprPred (evVarPred v)) <+> pprArisingAt loc
215 addErrorReport :: ReportErrCtxt -> SDoc -> TcM ()
216 addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt)
218 pprErrCtxtLoc :: ReportErrCtxt -> SDoc
220 = case map (ctLocOrigin . ic_loc) (cec_encl ctxt) of
221 [] -> ptext (sLit "the top level") -- Should not happen
222 (orig:origs) -> ppr_skol orig $$
223 vcat [ ptext (sLit "or") <+> ppr_skol orig | orig <- origs ]
225 ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc)
226 ppr_skol skol_info = pprSkolInfo skol_info
228 couldNotDeduce :: [EvVar] -> [PredType] -> SDoc
229 couldNotDeduce givens wanteds
230 = sep [ ptext (sLit "Could not deduce") <+> pprTheta wanteds
231 , nest 2 $ ptext (sLit "from the context")
232 <+> pprEvVarTheta givens]
234 getUserGivens :: ReportErrCtxt -> Maybe [EvVar]
235 -- Just gs => Say "could not deduce ... from gs"
236 -- Nothing => No interesting givens, say something else
237 getUserGivens (CEC {cec_encl = ctxt})
238 | null user_givens = Nothing
239 | otherwise = Just user_givens
241 givens = foldl (\gs ic -> ic_given ic ++ gs) [] ctxt
242 user_givens | opt_PprStyle_Debug = givens
243 | otherwise = filterOut isSelfDict givens
244 -- In user mode, don't show the "self-dict" given
245 -- which is only added to do co-inductive solving
246 -- Rather an awkward hack, but there we are
247 -- This is the only use of isSelfDict, so it's not in an inner loop
251 %************************************************************************
253 Implicit parameter errors
255 %************************************************************************
258 reportIPErrs :: ReportErrCtxt -> [PredType] -> WantedLoc -> TcM ()
259 reportIPErrs ctxt ips loc
260 = addErrorReport ctxt $ addArising loc msg
262 msg | Just givens <- getUserGivens ctxt
263 = couldNotDeduce givens ips
265 = sep [ ptext (sLit "Unbound implicit parameter") <> plural ips
266 , nest 2 (pprTheta ips) ]
270 %************************************************************************
274 %************************************************************************
277 reportEqErrs :: ReportErrCtxt -> [PredType] -> WantedLoc -> TcM ()
278 reportEqErrs ctxt eqs loc = mapM_ (reportEqErr ctxt loc) eqs
280 reportEqErr :: ReportErrCtxt -> WantedLoc -> PredType -> TcM ()
281 reportEqErr ctxt loc pred@(EqPred ty1 ty2)
282 | Just tv1 <- tcGetTyVar_maybe ty1 = reportTyVarEqErr ctxt loc tv1 ty2
283 | Just tv2 <- tcGetTyVar_maybe ty2 = reportTyVarEqErr ctxt loc tv2 ty1
284 | otherwise -- Neither side is a type variable
285 -- Since the unsolved constraint is canonical,
286 -- it must therefore be of form (F tys ~ ty)
287 = addErrorReport ctxt (msg $$ mkTyFunInfoMsg ty1 ty2)
289 msg = case getUserGivens ctxt of
290 Just givens -> couldNotDeduce givens [pred]
291 Nothing -> misMatchMsg ty1 ty2
293 reportEqErr _ _ _ = panic "reportEqErr" -- Must be equality pred
295 reportTyVarEqErr :: ReportErrCtxt -> WantedLoc
296 -> TcTyVar -> TcType -> TcM ()
297 reportTyVarEqErr ctxt loc tv1 ty2
299 , Just tv2 <- tcGetTyVar_maybe ty2
301 = -- sk ~ alpha: swap
302 reportTyVarEqErr ctxt loc tv2 ty1
305 = -- sk ~ ty, where ty isn't a meta-tyvar: mis-match
306 addErrTcM (misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2)
308 -- So tv is a meta tyvar, and presumably it is
309 -- an *untouchable* meta tyvar, else it'd have been unified
310 | not (k2 `isSubKind` k1) -- Kind error
311 = addErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2)
313 -- Check for skolem escape
314 | (implic:_) <- cec_encl ctxt -- Get the innermost context
315 , let esc_skols = varSetElems (tyVarsOfType ty2 `intersectVarSet` ic_skols implic)
316 implic_loc = ic_loc implic
317 , not (null esc_skols)
318 = setCtLoc implic_loc $ -- Override the error message location from the
319 -- place the equality arose to the implication site
320 do { (env1, env_sigs) <- findGlobals ctxt (unitVarSet tv1)
321 ; let msg = misMatchMsg ty1 ty2
322 esc_doc | isSingleton esc_skols
323 = ptext (sLit "because this skolem type variable would escape:")
325 = ptext (sLit "because these skolem type variables would escape:")
326 extra1 = vcat [ nest 2 $ esc_doc <+> pprQuotedList esc_skols
327 , sep [ (if isSingleton esc_skols
328 then ptext (sLit "This skolem is")
329 else ptext (sLit "These skolems are"))
330 <+> ptext (sLit "bound by")
331 , nest 2 $ pprSkolInfo (ctLocOrigin implic_loc) ] ]
332 ; addErrTcM (env1, msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) }
334 -- Nastiest case: attempt to unify an untouchable variable
335 | (implic:_) <- cec_encl ctxt -- Get the innermost context
336 , let implic_loc = ic_loc implic
337 given = ic_given implic
338 = setCtLoc (ic_loc implic) $
339 do { let (env1, msg) = misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2
340 extra = vcat [ ptext (sLit "because") <+> ppr tv1 <+> ptext (sLit "is untouchable")
341 , ptext (sLit "inside the constraints") <+> pprEvVarTheta given
342 , nest 2 (ptext (sLit "bound at")
343 <+> pprSkolInfo (ctLocOrigin implic_loc)) ]
344 ; addErrTcM (env1, msg $$ extra) }
346 | otherwise -- I'm not sure how this can happen!
347 = addErrTcM (misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2)
349 is_meta1 = isMetaTyVar tv1
354 mkTyFunInfoMsg :: TcType -> TcType -> SDoc
355 -- See Note [Non-injective type functions]
356 mkTyFunInfoMsg ty1 ty2
357 | Just (tc1,_) <- tcSplitTyConApp_maybe ty1
358 , Just (tc2,_) <- tcSplitTyConApp_maybe ty2
359 , tc1 == tc2, isSynFamilyTyCon tc1
360 = ptext (sLit "NB:") <+> quotes (ppr tc1)
361 <+> ptext (sLit "is a type function") <> (pp_inj tc1)
364 pp_inj tc | isInjectiveTyCon tc = empty
365 | otherwise = ptext (sLit (", and may not be injective"))
367 misMatchMsgWithExtras :: TidyEnv -> TcType -> TcType -> (TidyEnv, SDoc)
368 -- This version is used by TcSimplify too, which doesn't track the
369 -- expected/acutal thing, so we just have ty1 ty2 here
370 -- NB: The types are already tidied
371 misMatchMsgWithExtras env ty1 ty2
372 = (env2, sep [ misMatchMsg ty1 ty2, nest 2 (extra1 $$ extra2) ])
374 (env1, extra1) = typeExtraInfoMsg env ty1
375 (env2, extra2) = typeExtraInfoMsg env1 ty2
377 misMatchMsg :: TcType -> TcType -> SDoc -- Types are already tidy
378 misMatchMsg ty1 ty2 = sep [ ptext (sLit "Couldn't match type") <+> quotes (ppr ty1)
379 , nest 15 $ ptext (sLit "with") <+> quotes (ppr ty2)]
381 kindErrorMsg :: TcType -> TcType -> SDoc -- Types are already tidy
383 = vcat [ ptext (sLit "Kind incompatibility when matching types:")
384 , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1
385 , ppr ty2 <+> dcolon <+> ppr k2 ]) ]
390 typeExtraInfoMsg :: TidyEnv -> Type -> (TidyEnv, SDoc)
391 -- Shows a bit of extra info about skolem constants
392 typeExtraInfoMsg env ty
393 | Just tv <- tcGetTyVar_maybe ty
395 , isSkolemTyVar tv || isSigTyVar tv
397 , let (env1, tv1) = tidySkolemTyVar env tv
398 = (env1, pprSkolTvBinding tv1)
400 typeExtraInfoMsg env _ty = (env, empty) -- Normal case
403 Note [Non-injective type functions]
404 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
405 It's very confusing to get a message like
406 Couldn't match expected type `Depend s'
407 against inferred type `Depend s1'
408 so mkTyFunInfoMsg adds:
409 NB: `Depend' is type function, and hence may not be injective
411 Warn of loopy local equalities that were dropped.
414 %************************************************************************
418 %************************************************************************
421 reportDictErrs :: ReportErrCtxt -> [PredType] -> WantedLoc -> TcM ()
422 reportDictErrs ctxt wanteds loc
423 = do { inst_envs <- tcGetInstEnvs
424 ; let (others, overlaps) = partitionWith (check_overlap inst_envs) wanteds
425 ; unless (null others) $
426 addErrorReport ctxt (mk_no_inst_err others)
427 ; mapM_ (addErrorReport ctxt) overlaps }
429 check_overlap :: (InstEnv,InstEnv) -> PredType -> Either PredType SDoc
430 -- Right msg => overlap message
431 -- Left inst => no instance
432 check_overlap inst_envs pred@(ClassP clas tys)
433 = case lookupInstEnv inst_envs clas tys of
434 ([], _) -> Left pred -- No match
435 -- The case of exactly one match and no unifiers means a
436 -- successful lookup. That can't happen here, because dicts
437 -- only end up here if they didn't match in Inst.lookupInst
439 | debugIsOn -> pprPanic "check_overlap" (ppr pred)
440 res -> Right (mk_overlap_msg pred res)
441 check_overlap _ _ = panic "check_overlap"
443 mk_overlap_msg pred (matches, unifiers)
444 = ASSERT( not (null matches) )
445 vcat [ addArising loc (ptext (sLit "Overlapping instances for")
447 , sep [ptext (sLit "Matching instances") <> colon,
448 nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
449 , if not (isSingleton matches)
450 then -- Two or more matches
452 else -- One match, plus some unifiers
453 ASSERT( not (null unifiers) )
454 parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
455 quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
456 ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
457 ptext (sLit "when compiling the other instance declarations")])]
459 ispecs = [ispec | (ispec, _) <- matches]
461 mk_no_inst_err :: [PredType] -> SDoc
462 mk_no_inst_err wanteds
463 | Just givens <- getUserGivens ctxt
464 = vcat [ addArising loc $ couldNotDeduce givens wanteds
465 , show_fixes (fix1 : fixes2) ]
467 | otherwise -- Top level
468 = vcat [ addArising loc $
469 ptext (sLit "No instance") <> plural wanteds
470 <+> ptext (sLit "for") <+> pprTheta wanteds
471 , show_fixes fixes2 ]
474 fix1 = sep [ ptext (sLit "add") <+> pprTheta wanteds
475 <+> ptext (sLit "to the context of")
476 , nest 2 $ pprErrCtxtLoc ctxt ]
478 fixes2 | null instance_dicts = []
479 | otherwise = [sep [ptext (sLit "add an instance declaration for"),
480 pprTheta instance_dicts]]
481 instance_dicts = filterOut isTyVarClassPred wanteds
482 -- Insts for which it is worth suggesting an adding an
483 -- instance declaration. Exclude tyvar dicts.
485 show_fixes :: [SDoc] -> SDoc
486 show_fixes [] = empty
487 show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"),
488 nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
490 reportAmbigErrs :: ReportErrCtxt -> TcTyVarSet -> [WantedEvVar] -> TcM ()
491 reportAmbigErrs ctxt skols ambigs
492 -- Divide into groups that share a common set of ambiguous tyvars
493 = mapM_ report (equivClasses cmp ambigs_w_tvs)
495 ambigs_w_tvs = [ (d, varSetElems (tyVarsOfWantedEvVar d `minusVarSet` skols))
497 cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
499 report :: [(WantedEvVar, [TcTyVar])] -> TcM ()
502 do { let main_msg = sep [ text "Ambiguous type variable" <> plural tvs
503 <+> pprQuotedList tvs
504 <+> text "in the constraint" <> plural pairs <> colon
505 , nest 2 pp_wanteds ]
506 ; (tidy_env, mono_msg) <- mkMonomorphismMsg ctxt tvs
507 ; addErrTcM (tidy_env, main_msg $$ mono_msg) }
510 (loc, pp_wanteds) = pprWithArising (map fst pairs)
512 mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc)
513 -- There's an error with these Insts; if they have free type variables
514 -- it's probably caused by the monomorphism restriction.
515 -- Try to identify the offending variable
516 -- ASSUMPTION: the Insts are fully zonked
517 mkMonomorphismMsg ctxt inst_tvs
518 = do { dflags <- getDOpts
519 ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
520 ; return (tidy_env, mk_msg dflags docs) }
522 mk_msg _ _ | any isRuntimeUnk inst_tvs
523 = vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
524 (pprWithCommas ppr inst_tvs),
525 ptext (sLit "Use :print or :force to determine these types")]
526 mk_msg _ [] = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)")
527 -- This happens in things like
528 -- f x = show (read "foo")
529 -- where monomorphism doesn't play any role
531 = vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"),
533 monomorphism_fix dflags]
535 monomorphism_fix :: DynFlags -> SDoc
536 monomorphism_fix dflags
537 = ptext (sLit "Probable fix:") <+> vcat
538 [ptext (sLit "give these definition(s) an explicit type signature"),
539 if dopt Opt_MonomorphismRestriction dflags
540 then ptext (sLit "or use -XNoMonomorphismRestriction")
541 else empty] -- Only suggest adding "-XNoMonomorphismRestriction"
542 -- if it is not already set!
545 -----------------------
546 -- findGlobals looks at the value environment and finds values whose
547 -- types mention any of the offending type variables. It has to be
548 -- careful to zonk the Id's type first, so it has to be in the monad.
549 -- We must be careful to pass it a zonked type variable, too.
551 mkEnvSigMsg :: SDoc -> [SDoc] -> SDoc
552 mkEnvSigMsg what env_sigs
553 | null env_sigs = empty
554 | otherwise = vcat [ ptext (sLit "The following variables have types that mention") <+> what
555 , nest 2 (vcat env_sigs) ]
557 findGlobals :: ReportErrCtxt
559 -> TcM (TidyEnv, [SDoc])
562 = do { lcl_ty_env <- case cec_encl ctxt of
564 (i:_) -> return (ic_env i)
565 ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) }
567 go tidy_env acc [] = return (tidy_env, acc)
568 go tidy_env acc (thing : things) = do
569 (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing
571 Just d -> go tidy_env1 (d:acc) things
572 Nothing -> go tidy_env1 acc things
574 ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
576 -----------------------
577 find_thing :: TidyEnv -> (TcType -> Bool)
578 -> TcTyThing -> TcM (TidyEnv, Maybe SDoc)
579 find_thing tidy_env ignore_it (ATcId { tct_id = id })
580 = do { id_ty <- zonkTcType (idType id)
581 ; if ignore_it id_ty then
582 return (tidy_env, Nothing)
584 { let (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
585 msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty
586 , nest 2 (parens (ptext (sLit "bound at") <+>
587 ppr (getSrcLoc id)))]
588 ; return (tidy_env', Just msg) } }
590 find_thing tidy_env ignore_it (ATyVar tv ty)
591 = do { tv_ty <- zonkTcType ty
592 ; if ignore_it tv_ty then
593 return (tidy_env, Nothing)
595 { let -- The name tv is scoped, so we don't need to tidy it
596 (tidy_env1, tidy_ty) = tidyOpenType tidy_env tv_ty
597 msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff
600 eq_stuff | Just tv' <- tcGetTyVar_maybe tv_ty
601 , getOccName tv == getOccName tv' = empty
602 | otherwise = equals <+> ppr tidy_ty
603 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
604 bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
606 ; return (tidy_env1, Just msg) } }
608 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
610 warnDefaulting :: [WantedEvVar] -> Type -> TcM ()
611 warnDefaulting wanteds default_ty
612 = do { warn_default <- doptM Opt_WarnTypeDefaults
613 ; setCtLoc loc $ warnTc warn_default warn_msg }
616 warn_msg = vcat [ ptext (sLit "Defaulting the following constraint(s) to type") <+>
617 quotes (ppr default_ty),
619 (loc, ppr_wanteds) = pprWithArising wanteds
622 %************************************************************************
624 Error from the canonicaliser
626 %************************************************************************
629 kindErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a
630 kindErrorTcS fl ty1 ty2
633 do { env0 <- tcInitTidyEnv
634 ; let (env1, ty1') = tidyOpenType env0 ty1
635 (env2, ty2') = tidyOpenType env1 ty2
636 ; failWithTcM (env2, kindErrorMsg ty1' ty2') }
638 misMatchErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a
639 misMatchErrorTcS fl ty1 ty2
642 do { env0 <- tcInitTidyEnv
643 ; let (env1, ty1') = tidyOpenType env0 ty1
644 (env2, ty2') = tidyOpenType env1 ty2
645 (env3, msg) = misMatchMsgWithExtras env2 ty1' ty2'
646 ; failWithTcM (env3, inaccessible_msg $$ msg) }
650 Given loc -> hang (ptext (sLit "Inaccessible code in"))
654 = case ctLocOrigin loc of
655 PatSkol dc mc -> sep [ ptext (sLit "a pattern with constructor")
656 <+> quotes (ppr dc) <> comma
657 , ptext (sLit "in") <+> pprMatchContext mc ]
658 other_skol -> pprSkolInfo other_skol
660 occursCheckErrorTcS :: CtFlavor -> TcTyVar -> TcType -> TcS a
661 occursCheckErrorTcS fl tv ty
664 do { env0 <- tcInitTidyEnv
665 ; let (env1, tv') = tidyOpenTyVar env0 tv
666 (env2, ty') = tidyOpenType env1 ty
667 extra = sep [ppr tv', char '=', ppr ty']
668 ; failWithTcM (env2, hang msg 2 extra) }
670 msg = text $ "Occurs check: cannot construct the infinite type:"
672 setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
673 setCtFlavorLoc (Wanted loc) thing = setCtLoc loc thing
674 setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing
675 setCtFlavorLoc (Given loc) thing = setCtLoc loc thing
677 solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a
678 solverDepthErrorTcS depth stack
679 | null stack -- Shouldn't happen unless you say -fcontext-stack=0
680 = wrapErrTcS $ failWith msg
683 setCtFlavorLoc (cc_flavor top_item) $
684 do { env0 <- tcInitTidyEnv
685 ; let ev_vars = map cc_id stack
686 env1 = tidyFreeTyVars env0 free_tvs
687 free_tvs = foldr (unionVarSet . tyVarsOfEvVar) emptyVarSet ev_vars
688 extra = pprEvVars (map (tidyEvVar env1) ev_vars)
689 ; failWithTcM (env1, hang msg 2 extra) }
691 top_item = head stack
692 msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
693 , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
695 flattenForAllErrorTcS :: CtFlavor -> TcType -> Bag CanonicalCt -> TcS a
696 flattenForAllErrorTcS fl ty _bad_eqs
699 do { env0 <- tcInitTidyEnv
700 ; let (env1, ty') = tidyOpenType env0 ty
701 msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:")
703 ; failWithTcM (env1, msg) }