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( when, 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, non_ambigs) = partition is_ambiguous (bagToList flats)
122 (tv_eqs, others) = partition is_tv_eq non_ambigs
124 ; groupErrs (reportEqErrs ctxt) tv_eqs
125 ; when (null tv_eqs) $ groupErrs (reportFlat ctxt) others
126 ; when (null tv_eqs) $ mapBagM_ (reportTidyImplic ctxt) implics
128 -- Only report ambiguity if no other errors (at all) happened
129 -- See Note [Avoiding spurious errors] in TcSimplify
130 ; ifErrsM (return ()) $ reportAmbigErrs ctxt skols ambigs }
132 skols = foldr (unionVarSet . ic_skols) emptyVarSet (cec_encl ctxt)
134 -- Report equalities of form (a~ty) first. They are usually
135 -- skolem-equalities, and they cause confusing knock-on
136 -- effects in other errors; see test T4093b.
137 is_tv_eq c | EqPred ty1 ty2 <- wantedEvVarPred c
138 = tcIsTyVarTy ty1 || tcIsTyVarTy ty2
141 -- Treat it as "ambiguous" if
142 -- (a) it is a class constraint
143 -- (b) it constrains only type variables
144 -- (else we'd prefer to report it as "no instance for...")
145 -- (c) it mentions type variables that are not skolems
146 is_ambiguous d = isTyVarClassPred pred
147 && not (tyVarsOfPred pred `subVarSet` skols)
149 pred = wantedEvVarPred d
151 reportFlat :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
152 reportFlat ctxt flats origin
153 = do { unless (null dicts) $ reportDictErrs ctxt dicts origin
154 ; unless (null eqs) $ reportEqErrs ctxt eqs origin
155 ; unless (null ips) $ reportIPErrs ctxt ips origin
156 ; ASSERT( null others ) return () }
158 (dicts, non_dicts) = partition isClassPred flats
159 (eqs, non_eqs) = partition isEqPred non_dicts
160 (ips, others) = partition isIPPred non_eqs
162 --------------------------------------------
164 --------------------------------------------
166 groupErrs :: ([PredType] -> CtOrigin -> TcM ()) -- Deal with one group
167 -> [WantedEvVar] -- Unsolved wanteds
169 -- Group together insts with the same origin
170 -- We want to report them together in error messages
174 groupErrs report_err (wanted : wanteds)
175 = do { setCtLoc the_loc $
176 report_err the_vars (ctLocOrigin the_loc)
177 ; groupErrs report_err others }
179 the_loc = wantedEvVarLoc wanted
180 the_key = mk_key the_loc
181 the_vars = map wantedEvVarPred (wanted:friends)
182 (friends, others) = partition is_friend wanteds
183 is_friend friend = mk_key (wantedEvVarLoc friend) == the_key
185 mk_key :: WantedLoc -> (SrcSpan, String)
186 mk_key loc = (ctLocSpan loc, showSDoc (ppr (ctLocOrigin loc)))
187 -- It may seem crude to compare the error messages,
188 -- but it makes sure that we combine just what the user sees,
189 -- and it avoids need equality on InstLocs.
191 -- Add the "arising from..." part to a message about bunch of dicts
192 addArising :: CtOrigin -> SDoc -> SDoc
193 addArising orig msg = msg $$ nest 2 (pprArising orig)
195 pprWithArising :: [WantedEvVar] -> (WantedLoc, SDoc)
196 -- Print something like
197 -- (Eq a) arising from a use of x at y
198 -- (Show a) arising froma use of p at q
199 -- Also return a location for the erroe message
201 = panic "pprWithArising"
202 pprWithArising [WantedEvVar ev loc]
203 = (loc, pprEvVarTheta [ev] <+> pprArising (ctLocOrigin loc))
204 pprWithArising ev_vars
205 = (first_loc, vcat (map ppr_one ev_vars))
207 first_loc = wantedEvVarLoc (head ev_vars)
208 ppr_one (WantedEvVar v loc)
209 = parens (pprPred (evVarPred v)) <+> pprArisingAt loc
211 addErrorReport :: ReportErrCtxt -> SDoc -> TcM ()
212 addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt)
214 pprErrCtxtLoc :: ReportErrCtxt -> SDoc
216 = case map (ctLocOrigin . ic_loc) (cec_encl ctxt) of
217 [] -> ptext (sLit "the top level") -- Should not happen
218 (orig:origs) -> ppr_skol orig $$
219 vcat [ ptext (sLit "or") <+> ppr_skol orig | orig <- origs ]
221 ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc)
222 ppr_skol skol_info = pprSkolInfo skol_info
224 couldNotDeduce :: [EvVar] -> [PredType] -> SDoc
225 couldNotDeduce givens wanteds
226 = sep [ ptext (sLit "Could not deduce") <+> pprTheta wanteds
227 , nest 2 $ ptext (sLit "from the context")
228 <+> pprEvVarTheta givens]
230 getUserGivens :: ReportErrCtxt -> Maybe [EvVar]
231 -- Just gs => Say "could not deduce ... from gs"
232 -- Nothing => No interesting givens, say something else
233 getUserGivens (CEC {cec_encl = ctxt})
234 | null user_givens = Nothing
235 | otherwise = Just user_givens
237 givens = foldl (\gs ic -> ic_given ic ++ gs) [] ctxt
238 user_givens | opt_PprStyle_Debug = givens
239 | otherwise = filterOut isSelfDict givens
240 -- In user mode, don't show the "self-dict" given
241 -- which is only added to do co-inductive solving
242 -- Rather an awkward hack, but there we are
243 -- This is the only use of isSelfDict, so it's not in an inner loop
247 %************************************************************************
249 Implicit parameter errors
251 %************************************************************************
254 reportIPErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
255 reportIPErrs ctxt ips orig
256 = addErrorReport ctxt $ addArising orig msg
258 msg | Just givens <- getUserGivens ctxt
259 = couldNotDeduce givens ips
261 = sep [ ptext (sLit "Unbound implicit parameter") <> plural ips
262 , nest 2 (pprTheta ips) ]
266 %************************************************************************
270 %************************************************************************
273 reportEqErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
274 reportEqErrs ctxt eqs orig
275 = mapM_ report_one eqs
278 report_one (EqPred ty1 ty2)
279 = do { (env1, extra) <- getWantedEqExtra emptyTvSubst env0 orig ty1 ty2
280 ; let ctxt' = ctxt { cec_tidy = env1
281 , cec_extra = cec_extra ctxt $$ extra }
282 ; reportEqErr ctxt' ty1 ty2 }
284 = pprPanic "reportEqErrs" (ppr pred)
286 reportEqErr :: ReportErrCtxt -> TcType -> TcType -> TcM ()
287 reportEqErr ctxt ty1 ty2
288 | Just tv1 <- tcGetTyVar_maybe ty1 = reportTyVarEqErr ctxt tv1 ty2
289 | Just tv2 <- tcGetTyVar_maybe ty2 = reportTyVarEqErr ctxt tv2 ty1
290 | otherwise -- Neither side is a type variable
291 -- Since the unsolved constraint is canonical,
292 -- it must therefore be of form (F tys ~ ty)
293 = addErrorReport ctxt (msg $$ mkTyFunInfoMsg ty1 ty2)
295 msg = case getUserGivens ctxt of
296 Just givens -> couldNotDeduce givens [EqPred ty1 ty2]
297 Nothing -> misMatchMsg ty1 ty2
299 reportTyVarEqErr :: ReportErrCtxt -> TcTyVar -> TcType -> TcM ()
300 reportTyVarEqErr ctxt tv1 ty2
302 , Just tv2 <- tcGetTyVar_maybe ty2
304 = -- sk ~ alpha: swap
305 reportTyVarEqErr ctxt tv2 ty1
308 = -- sk ~ ty, where ty isn't a meta-tyvar: mis-match
309 addErrTcM (misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2)
311 -- So tv is a meta tyvar, and presumably it is
312 -- an *untouchable* meta tyvar, else it'd have been unified
313 | not (k2 `isSubKind` k1) -- Kind error
314 = addErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2)
316 -- Check for skolem escape
317 | (implic:_) <- cec_encl ctxt -- Get the innermost context
318 , let esc_skols = varSetElems (tyVarsOfType ty2 `intersectVarSet` ic_skols implic)
319 implic_loc = ic_loc implic
320 , not (null esc_skols)
321 = setCtLoc implic_loc $ -- Override the error message location from the
322 -- place the equality arose to the implication site
323 do { (env1, env_sigs) <- findGlobals ctxt (unitVarSet tv1)
324 ; let msg = misMatchMsg ty1 ty2
325 esc_doc | isSingleton esc_skols
326 = ptext (sLit "because this skolem type variable would escape:")
328 = ptext (sLit "because these skolem type variables would escape:")
329 extra1 = vcat [ nest 2 $ esc_doc <+> pprQuotedList esc_skols
330 , sep [ (if isSingleton esc_skols
331 then ptext (sLit "This skolem is")
332 else ptext (sLit "These skolems are"))
333 <+> ptext (sLit "bound by")
334 , nest 2 $ pprSkolInfo (ctLocOrigin implic_loc) ] ]
335 ; addErrTcM (env1, msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) }
337 -- Nastiest case: attempt to unify an untouchable variable
338 | (implic:_) <- cec_encl ctxt -- Get the innermost context
339 , let implic_loc = ic_loc implic
340 given = ic_given implic
341 = setCtLoc (ic_loc implic) $
342 do { let (env1, msg) = misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2
343 extra = vcat [ ptext (sLit "because") <+> ppr tv1 <+> ptext (sLit "is untouchable")
344 , ptext (sLit "inside the constraints") <+> pprEvVarTheta given
345 , nest 2 (ptext (sLit "bound at")
346 <+> pprSkolInfo (ctLocOrigin implic_loc)) ]
347 ; addErrTcM (env1, msg $$ extra) }
349 | otherwise -- I'm not sure how this can happen!
350 = addErrTcM (misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2)
352 is_meta1 = isMetaTyVar tv1
357 mkTyFunInfoMsg :: TcType -> TcType -> SDoc
358 -- See Note [Non-injective type functions]
359 mkTyFunInfoMsg ty1 ty2
360 | Just (tc1,_) <- tcSplitTyConApp_maybe ty1
361 , Just (tc2,_) <- tcSplitTyConApp_maybe ty2
362 , tc1 == tc2, isSynFamilyTyCon tc1
363 = ptext (sLit "NB:") <+> quotes (ppr tc1)
364 <+> ptext (sLit "is a type function") <> (pp_inj tc1)
367 pp_inj tc | isInjectiveTyCon tc = empty
368 | otherwise = ptext (sLit (", and may not be injective"))
370 misMatchMsgWithExtras :: TidyEnv -> TcType -> TcType -> (TidyEnv, SDoc)
371 -- This version is used by TcSimplify too, which doesn't track the
372 -- expected/acutal thing, so we just have ty1 ty2 here
373 -- NB: The types are already tidied
374 misMatchMsgWithExtras env ty1 ty2
375 = (env2, sep [ misMatchMsg ty1 ty2, nest 2 (extra1 $$ extra2) ])
377 (env1, extra1) = typeExtraInfoMsg env ty1
378 (env2, extra2) = typeExtraInfoMsg env1 ty2
380 misMatchMsg :: TcType -> TcType -> SDoc -- Types are already tidy
381 misMatchMsg ty1 ty2 = sep [ ptext (sLit "Couldn't match type") <+> quotes (ppr ty1)
382 , nest 15 $ ptext (sLit "with") <+> quotes (ppr ty2)]
384 kindErrorMsg :: TcType -> TcType -> SDoc -- Types are already tidy
386 = vcat [ ptext (sLit "Kind incompatibility when matching types:")
387 , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1
388 , ppr ty2 <+> dcolon <+> ppr k2 ]) ]
393 typeExtraInfoMsg :: TidyEnv -> Type -> (TidyEnv, SDoc)
394 -- Shows a bit of extra info about skolem constants
395 typeExtraInfoMsg env ty
396 | Just tv <- tcGetTyVar_maybe ty
398 , isSkolemTyVar tv || isSigTyVar tv
400 , let (env1, tv1) = tidySkolemTyVar env tv
401 = (env1, pprSkolTvBinding tv1)
403 typeExtraInfoMsg env _ty = (env, empty) -- Normal case
406 unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc)
407 unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env
408 = do { act_ty' <- zonkTcType act_ty
409 ; exp_ty' <- zonkTcType exp_ty
410 ; let (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
411 (env2, act_ty'') = tidyOpenType env1 act_ty'
412 ; return (env2, mkExpectedActualMsg act_ty'' exp_ty'') }
414 mkExpectedActualMsg :: Type -> Type -> SDoc
415 mkExpectedActualMsg act_ty exp_ty
416 = vcat [ text "Expected type" <> colon <+> ppr exp_ty
417 , text " Actual type" <> colon <+> ppr act_ty ]
420 Note [Non-injective type functions]
421 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
422 It's very confusing to get a message like
423 Couldn't match expected type `Depend s'
424 against inferred type `Depend s1'
425 so mkTyFunInfoMsg adds:
426 NB: `Depend' is type function, and hence may not be injective
428 Warn of loopy local equalities that were dropped.
431 %************************************************************************
435 %************************************************************************
438 reportDictErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
439 reportDictErrs ctxt wanteds orig
440 = do { inst_envs <- tcGetInstEnvs
441 ; let (others, overlaps) = partitionWith (check_overlap inst_envs) wanteds
442 ; unless (null others) $
443 addErrorReport ctxt (mk_no_inst_err others)
444 ; mapM_ (addErrorReport ctxt) overlaps }
446 check_overlap :: (InstEnv,InstEnv) -> PredType -> Either PredType SDoc
447 -- Right msg => overlap message
448 -- Left inst => no instance
449 check_overlap inst_envs pred@(ClassP clas tys)
450 = case lookupInstEnv inst_envs clas tys of
451 ([], _) -> Left pred -- No match
452 -- The case of exactly one match and no unifiers means a
453 -- successful lookup. That can't happen here, because dicts
454 -- only end up here if they didn't match in Inst.lookupInst
456 | debugIsOn -> pprPanic "check_overlap" (ppr pred)
457 res -> Right (mk_overlap_msg pred res)
458 check_overlap _ _ = panic "check_overlap"
460 mk_overlap_msg pred (matches, unifiers)
461 = ASSERT( not (null matches) )
462 vcat [ addArising orig (ptext (sLit "Overlapping instances for")
464 , sep [ptext (sLit "Matching instances") <> colon,
465 nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
466 , if not (isSingleton matches)
467 then -- Two or more matches
469 else -- One match, plus some unifiers
470 ASSERT( not (null unifiers) )
471 parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
472 quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
473 ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
474 ptext (sLit "when compiling the other instance declarations")])]
476 ispecs = [ispec | (ispec, _) <- matches]
478 mk_no_inst_err :: [PredType] -> SDoc
479 mk_no_inst_err wanteds
480 | Just givens <- getUserGivens ctxt
481 = vcat [ addArising orig $ couldNotDeduce givens wanteds
482 , show_fixes (fix1 : fixes2) ]
484 | otherwise -- Top level
485 = vcat [ addArising orig $
486 ptext (sLit "No instance") <> plural wanteds
487 <+> ptext (sLit "for") <+> pprTheta wanteds
488 , show_fixes fixes2 ]
491 fix1 = sep [ ptext (sLit "add") <+> pprTheta wanteds
492 <+> ptext (sLit "to the context of")
493 , nest 2 $ pprErrCtxtLoc ctxt ]
495 fixes2 | null instance_dicts = []
496 | otherwise = [sep [ptext (sLit "add an instance declaration for"),
497 pprTheta instance_dicts]]
498 instance_dicts = filterOut isTyVarClassPred wanteds
499 -- Insts for which it is worth suggesting an adding an
500 -- instance declaration. Exclude tyvar dicts.
502 show_fixes :: [SDoc] -> SDoc
503 show_fixes [] = empty
504 show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"),
505 nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
507 reportAmbigErrs :: ReportErrCtxt -> TcTyVarSet -> [WantedEvVar] -> TcM ()
508 reportAmbigErrs ctxt skols ambigs
509 -- Divide into groups that share a common set of ambiguous tyvars
510 = mapM_ report (equivClasses cmp ambigs_w_tvs)
512 ambigs_w_tvs = [ (d, varSetElems (tyVarsOfWantedEvVar d `minusVarSet` skols))
514 cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
516 report :: [(WantedEvVar, [TcTyVar])] -> TcM ()
519 do { let main_msg = sep [ text "Ambiguous type variable" <> plural tvs
520 <+> pprQuotedList tvs
521 <+> text "in the constraint" <> plural pairs <> colon
522 , nest 2 pp_wanteds ]
523 ; (tidy_env, mono_msg) <- mkMonomorphismMsg ctxt tvs
524 ; addErrTcM (tidy_env, main_msg $$ mono_msg) }
527 (loc, pp_wanteds) = pprWithArising (map fst pairs)
529 mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc)
530 -- There's an error with these Insts; if they have free type variables
531 -- it's probably caused by the monomorphism restriction.
532 -- Try to identify the offending variable
533 -- ASSUMPTION: the Insts are fully zonked
534 mkMonomorphismMsg ctxt inst_tvs
535 = do { dflags <- getDOpts
536 ; traceTc "Mono" (vcat (map pprSkolTvBinding inst_tvs))
537 ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
538 ; return (tidy_env, mk_msg dflags docs) }
540 mk_msg _ _ | any isRuntimeUnkSkol inst_tvs -- See Note [Runtime skolems]
541 = vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
542 (pprWithCommas ppr inst_tvs),
543 ptext (sLit "Use :print or :force to determine these types")]
544 mk_msg _ [] = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)")
545 -- This happens in things like
546 -- f x = show (read "foo")
547 -- where monomorphism doesn't play any role
549 = vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"),
551 monomorphism_fix dflags]
553 monomorphism_fix :: DynFlags -> SDoc
554 monomorphism_fix dflags
555 = ptext (sLit "Probable fix:") <+> vcat
556 [ptext (sLit "give these definition(s) an explicit type signature"),
557 if xopt Opt_MonomorphismRestriction dflags
558 then ptext (sLit "or use -XNoMonomorphismRestriction")
559 else empty] -- Only suggest adding "-XNoMonomorphismRestriction"
560 -- if it is not already set!
563 -----------------------
564 -- findGlobals looks at the value environment and finds values whose
565 -- types mention any of the offending type variables. It has to be
566 -- careful to zonk the Id's type first, so it has to be in the monad.
567 -- We must be careful to pass it a zonked type variable, too.
569 mkEnvSigMsg :: SDoc -> [SDoc] -> SDoc
570 mkEnvSigMsg what env_sigs
571 | null env_sigs = empty
572 | otherwise = vcat [ ptext (sLit "The following variables have types that mention") <+> what
573 , nest 2 (vcat env_sigs) ]
575 findGlobals :: ReportErrCtxt
577 -> TcM (TidyEnv, [SDoc])
580 = do { lcl_ty_env <- case cec_encl ctxt of
582 (i:_) -> return (ic_env i)
583 ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) }
585 go tidy_env acc [] = return (tidy_env, acc)
586 go tidy_env acc (thing : things) = do
587 (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing
589 Just d -> go tidy_env1 (d:acc) things
590 Nothing -> go tidy_env1 acc things
592 ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
594 -----------------------
595 find_thing :: TidyEnv -> (TcType -> Bool)
596 -> TcTyThing -> TcM (TidyEnv, Maybe SDoc)
597 find_thing tidy_env ignore_it (ATcId { tct_id = id })
598 = do { id_ty <- zonkTcType (idType id)
599 ; if ignore_it id_ty then
600 return (tidy_env, Nothing)
602 { let (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
603 msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty
604 , nest 2 (parens (ptext (sLit "bound at") <+>
605 ppr (getSrcLoc id)))]
606 ; return (tidy_env', Just msg) } }
608 find_thing tidy_env ignore_it (ATyVar tv ty)
609 = do { tv_ty <- zonkTcType ty
610 ; if ignore_it tv_ty then
611 return (tidy_env, Nothing)
613 { let -- The name tv is scoped, so we don't need to tidy it
614 (tidy_env1, tidy_ty) = tidyOpenType tidy_env tv_ty
615 msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff
618 eq_stuff | Just tv' <- tcGetTyVar_maybe tv_ty
619 , getOccName tv == getOccName tv' = empty
620 | otherwise = equals <+> ppr tidy_ty
621 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
622 bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
624 ; return (tidy_env1, Just msg) } }
626 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
628 warnDefaulting :: [WantedEvVar] -> Type -> TcM ()
629 warnDefaulting wanteds default_ty
630 = do { warn_default <- doptM Opt_WarnTypeDefaults
631 ; setCtLoc loc $ warnTc warn_default warn_msg }
634 warn_msg = vcat [ ptext (sLit "Defaulting the following constraint(s) to type") <+>
635 quotes (ppr default_ty),
637 (loc, ppr_wanteds) = pprWithArising wanteds
640 Note [Runtime skolems]
641 ~~~~~~~~~~~~~~~~~~~~~~
642 We want to give a reasonably helpful error message for ambiguity
643 arising from *runtime* skolems in the debugger. Mostly these
644 are created by in RtClosureInspec.zonkRTTIType. However at a
645 breakpoint we return Ids from the CoreExpr, whose types may have
646 free type variables bound by some enclosing 'forall'. These are
647 UnkSkols, created ty TcType.zonkQuantifiedTyVar.
649 These UnkSkols should never show up as ambiguous type variables in
650 normal typechecking, so we hackily emit the debugger-related message
651 both for RuntimeUnkSkols and UnkSkols. Hence the two cases in
652 TcType.isRuntimeUnkSkol. Yuk. The rest of the debugger is such
653 a mess that I don't feel motivated to clean up this bit.
656 %************************************************************************
658 Error from the canonicaliser
659 These ones are called *during* constraint simplification
661 %************************************************************************
664 kindErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a
665 -- If there's a kind error, we don't want to blindly say "kind error"
666 -- We might, say, be unifying a skolem 'a' with a type 'Int',
667 -- in which case that's the error to report. So we set things
668 -- up to call reportEqErr, which does the business properly
669 kindErrorTcS fl ty1 ty2
670 = wrapEqErrTcS fl ty1 ty2 $ \ env0 ty1 ty2 extra ->
671 do { let ctxt = CEC { cec_encl = []
674 ; reportEqErr ctxt ty1 ty2
678 misMatchErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a
679 misMatchErrorTcS fl ty1 ty2
680 = wrapEqErrTcS fl ty1 ty2 $ \ env0 ty1 ty2 extra ->
681 do { let (env1, msg) = misMatchMsgWithExtras env0 ty1 ty2
682 ; failWithTcM (env1, inaccessible_msg $$ msg $$ extra) }
686 Given loc -> hang (ptext (sLit "Inaccessible code in"))
690 = case ctLocOrigin loc of
691 PatSkol dc mc -> sep [ ptext (sLit "a pattern with constructor")
692 <+> quotes (ppr dc) <> comma
693 , ptext (sLit "in") <+> pprMatchContext mc ]
694 other_skol -> pprSkolInfo other_skol
696 occursCheckErrorTcS :: CtFlavor -> TcTyVar -> TcType -> TcS a
697 occursCheckErrorTcS fl tv ty
698 = wrapEqErrTcS fl (mkTyVarTy tv) ty $ \ env0 ty1 ty2 extra2 ->
699 do { let extra1 = sep [ppr ty1, char '=', ppr ty2]
700 ; failWithTcM (env0, hang msg 2 (extra1 $$ extra2)) }
702 msg = text $ "Occurs check: cannot construct the infinite type:"
704 solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a
705 solverDepthErrorTcS depth stack
706 | null stack -- Shouldn't happen unless you say -fcontext-stack=0
707 = wrapErrTcS $ failWith msg
710 setCtFlavorLoc (cc_flavor top_item) $
711 do { env0 <- tcInitTidyEnv
712 ; let ev_vars = map cc_id stack
713 env1 = tidyFreeTyVars env0 free_tvs
714 free_tvs = foldr (unionVarSet . tyVarsOfEvVar) emptyVarSet ev_vars
715 extra = pprEvVars (map (tidyEvVar env1) ev_vars)
716 ; failWithTcM (env1, hang msg 2 extra) }
718 top_item = head stack
719 msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
720 , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
722 flattenForAllErrorTcS :: CtFlavor -> TcType -> Bag CanonicalCt -> TcS a
723 flattenForAllErrorTcS fl ty _bad_eqs
726 do { env0 <- tcInitTidyEnv
727 ; let (env1, ty') = tidyOpenType env0 ty
728 msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:")
730 ; failWithTcM (env1, msg) }
733 %************************************************************************
737 %************************************************************************
740 setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
741 setCtFlavorLoc (Wanted loc) thing = setCtLoc loc thing
742 setCtFlavorLoc (Derived loc _) thing = setCtLoc loc thing
743 setCtFlavorLoc (Given loc) thing = setCtLoc loc thing
745 wrapEqErrTcS :: CtFlavor -> TcType -> TcType
746 -> (TidyEnv -> TcType -> TcType -> SDoc -> TcM a)
748 wrapEqErrTcS fl ty1 ty2 thing_inside
749 = do { ty_binds_var <- getTcSTyBinds
750 ; wrapErrTcS $ setCtFlavorLoc fl $
751 do { -- Apply the current substitition
752 -- and zonk to get rid of flatten-skolems
753 ; ty_binds_map <- readTcRef ty_binds_var
754 ; let subst = mkOpenTvSubst (mapVarEnv snd ty_binds_map)
755 ; env0 <- tcInitTidyEnv
756 ; (env1, ty1) <- zonkSubstTidy env0 subst ty1
757 ; (env2, ty2) <- zonkSubstTidy env1 subst ty2
758 ; let do_wanted loc = do { (env3, extra) <- getWantedEqExtra subst env2
759 (ctLocOrigin loc) ty1 ty2
760 ; thing_inside env3 ty1 ty2 extra }
762 Wanted loc -> do_wanted loc
763 Derived loc _ -> do_wanted loc
764 Given {} -> thing_inside env2 ty1 ty2 empty
765 -- We could print more info, but it
766 -- seems to be coming out already
770 getWantedEqExtra :: TvSubst -> TidyEnv -> CtOrigin -> TcType -> TcType
771 -> TcM (TidyEnv, SDoc)
772 getWantedEqExtra subst env0 (TypeEqOrigin item) ty1 ty2
773 -- If the types in the error message are the same
774 -- as the types we are unifying (remember to zonk the latter)
775 -- don't add the extra expected/actual message
777 -- The complication is that the types in the TypeEqOrigin must
779 -- (b) have any TcS-monad pending equalities applied to them
780 -- (hence the passed-in substitution)
781 = do { (env1, act) <- zonkSubstTidy env0 subst (uo_actual item)
782 ; (env2, exp) <- zonkSubstTidy env1 subst (uo_expected item)
783 ; if (act `tcEqType` ty1 && exp `tcEqType` ty2)
784 || (exp `tcEqType` ty1 && act `tcEqType` ty2)
788 return (env2, mkExpectedActualMsg act exp) }
790 getWantedEqExtra _ env0 orig _ _
791 = return (env0, pprArising orig)
793 zonkSubstTidy :: TidyEnv -> TvSubst -> TcType -> TcM (TidyEnv, TcType)
794 -- In general, becore printing a type, we want to
795 -- a) Zonk it. Even during constraint simplification this is
796 -- is important, to un-flatten the flatten skolems in a type
797 -- b) Substitute any solved unification variables. This is
798 -- only important *during* solving, becuase after solving
799 -- the substitution is expressed in the mutable type variables
800 -- But during solving there may be constraint (F xi ~ ty)
801 -- where the substitution has not been applied to the RHS
802 zonkSubstTidy env subst ty
803 = do { ty' <- zonkTcTypeAndSubst subst ty
804 ; return (tidyOpenType env ty') }