23cc0481f1da06ebb845888d20953ec1030024c4
[ghc.git] / compiler / typecheck / TcErrors.hs
1 {-# LANGUAGE CPP, ScopedTypeVariables #-}
2
3 module TcErrors(
4 reportUnsolved, reportAllUnsolved,
5 warnDefaulting,
6
7 solverDepthErrorTcS
8 ) where
9
10 #include "HsVersions.h"
11
12 import TcRnTypes
13 import TcRnMonad
14 import TcMType
15 import TcType
16 import TypeRep
17 import Type
18 import Kind ( isKind )
19 import Unify ( tcMatchTys )
20 import Module
21 import FamInst
22 import Inst
23 import InstEnv
24 import TyCon
25 import DataCon
26 import TcEvidence
27 import Name
28 import RdrName ( lookupGRE_Name, GlobalRdrEnv )
29 import Id
30 import Var
31 import VarSet
32 import VarEnv
33 import NameEnv
34 import Bag
35 import ErrUtils ( ErrMsg, makeIntoWarning, pprLocErrMsg )
36 import BasicTypes
37 import Util
38 import FastString
39 import Outputable
40 import SrcLoc
41 import DynFlags
42 import StaticFlags ( opt_PprStyle_Debug )
43 import ListSetOps ( equivClasses )
44
45 import Data.Maybe
46 import Data.List ( partition, mapAccumL, nub, sortBy )
47
48 {-
49 ************************************************************************
50 * *
51 \section{Errors and contexts}
52 * *
53 ************************************************************************
54
55 ToDo: for these error messages, should we note the location as coming
56 from the insts, or just whatever seems to be around in the monad just
57 now?
58
59 Note [Deferring coercion errors to runtime]
60 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
61 While developing, sometimes it is desirable to allow compilation to succeed even
62 if there are type errors in the code. Consider the following case:
63
64 module Main where
65
66 a :: Int
67 a = 'a'
68
69 main = print "b"
70
71 Even though `a` is ill-typed, it is not used in the end, so if all that we're
72 interested in is `main` it is handy to be able to ignore the problems in `a`.
73
74 Since we treat type equalities as evidence, this is relatively simple. Whenever
75 we run into a type mismatch in TcUnify, we normally just emit an error. But it
76 is always safe to defer the mismatch to the main constraint solver. If we do
77 that, `a` will get transformed into
78
79 co :: Int ~ Char
80 co = ...
81
82 a :: Int
83 a = 'a' `cast` co
84
85 The constraint solver would realize that `co` is an insoluble constraint, and
86 emit an error with `reportUnsolved`. But we can also replace the right-hand side
87 of `co` with `error "Deferred type error: Int ~ Char"`. This allows the program
88 to compile, and it will run fine unless we evaluate `a`. This is what
89 `deferErrorsToRuntime` does.
90
91 It does this by keeping track of which errors correspond to which coercion
92 in TcErrors. TcErrors.reportTidyWanteds does not print the errors
93 and does not fail if -fdefer-type-errors is on, so that we can continue
94 compilation. The errors are turned into warnings in `reportUnsolved`.
95 -}
96
97 reportUnsolved :: WantedConstraints -> TcM (Bag EvBind)
98 reportUnsolved wanted
99 = do { binds_var <- newTcEvBinds
100 ; defer_errors <- goptM Opt_DeferTypeErrors
101
102 ; defer_holes <- goptM Opt_DeferTypedHoles
103 ; warn_holes <- woptM Opt_WarnTypedHoles
104 ; let expr_holes | not defer_holes = HoleError
105 | warn_holes = HoleWarn
106 | otherwise = HoleDefer
107
108 ; partial_sigs <- xoptM Opt_PartialTypeSignatures
109 ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures
110 ; let type_holes | not partial_sigs = HoleError
111 | warn_partial_sigs = HoleWarn
112 | otherwise = HoleDefer
113
114 ; report_unsolved (Just binds_var) defer_errors expr_holes type_holes wanted
115 ; getTcEvBinds binds_var }
116
117 reportAllUnsolved :: WantedConstraints -> TcM ()
118 -- Report *all* unsolved goals as errors, even if -fdefer-type-errors is on
119 -- See Note [Deferring coercion errors to runtime]
120 reportAllUnsolved wanted
121 = report_unsolved Nothing False HoleError HoleError wanted
122
123 report_unsolved :: Maybe EvBindsVar -- cec_binds
124 -> Bool -- cec_defer_type_errors
125 -> HoleChoice -- Expression holes
126 -> HoleChoice -- Type holes
127 -> WantedConstraints -> TcM ()
128 -- Important precondition:
129 -- WantedConstraints are fully zonked and unflattened, that is,
130 -- zonkWC has already been applied to these constraints.
131 report_unsolved mb_binds_var defer_errors expr_holes type_holes wanted
132 | isEmptyWC wanted
133 = return ()
134 | otherwise
135 = do { traceTc "reportUnsolved (before unflattening)" (ppr wanted)
136
137 ; env0 <- tcInitTidyEnv
138
139 -- If we are deferring we are going to need /all/ evidence around,
140 -- including the evidence produced by unflattening (zonkWC)
141 ; let tidy_env = tidyFreeTyVars env0 free_tvs
142 free_tvs = tyVarsOfWC wanted
143 err_ctxt = CEC { cec_encl = []
144 , cec_tidy = tidy_env
145 , cec_defer_type_errors = defer_errors
146 , cec_expr_holes = expr_holes
147 , cec_type_holes = type_holes
148 , cec_suppress = False -- See Note [Suppressing error messages]
149 , cec_binds = mb_binds_var }
150
151 ; traceTc "reportUnsolved (after unflattening):" $
152 vcat [ pprTvBndrs (varSetElems free_tvs)
153 , ppr wanted ]
154
155 ; reportWanteds err_ctxt wanted }
156
157 --------------------------------------------
158 -- Internal functions
159 --------------------------------------------
160
161 data HoleChoice
162 = HoleError -- A hole is a compile-time error
163 | HoleWarn -- Defer to runtime, emit a compile-time warning
164 | HoleDefer -- Defer to runtime, no warning
165
166 data ReportErrCtxt
167 = CEC { cec_encl :: [Implication] -- Enclosing implications
168 -- (innermost first)
169 -- ic_skols and givens are tidied, rest are not
170 , cec_tidy :: TidyEnv
171 , cec_binds :: Maybe EvBindsVar
172 -- Nothinng <=> Report all errors, including holes; no bindings
173 -- Just ev <=> make some errors (depending on cec_defer)
174 -- into warnings, and emit evidence bindings
175 -- into 'ev' for unsolved constraints
176
177 , cec_defer_type_errors :: Bool -- True <=> -fdefer-type-errors
178 -- Defer type errors until runtime
179 -- Irrelevant if cec_binds = Nothing
180
181 , cec_expr_holes :: HoleChoice -- Holes in expressions
182 , cec_type_holes :: HoleChoice -- Holes in types
183
184 , cec_suppress :: Bool -- True <=> More important errors have occurred,
185 -- so create bindings if need be, but
186 -- don't issue any more errors/warnings
187 -- See Note [Suppressing error messages]
188 }
189
190 {-
191 Note [Suppressing error messages]
192 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
193 The cec_suppress flag says "don't report any errors". Instead, just create
194 evidence bindings (as usual). It's used when more important errors have occurred.
195
196 Specifically (see reportWanteds)
197 * If there are insoluble Givens, then we are in unreachable code and all bets
198 are off. So don't report any further errors.
199 * If there are any insolubles (eg Int~Bool), here or in a nested implication,
200 then suppress errors from the simple constraints here. Sometimes the
201 simple-constraint errors are a knock-on effect of the insolubles.
202 -}
203
204 reportImplic :: ReportErrCtxt -> Implication -> TcM ()
205 reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given
206 , ic_wanted = wanted, ic_binds = evb
207 , ic_insol = ic_insoluble, ic_info = info })
208 | BracketSkol <- info
209 , not ic_insoluble -- For Template Haskell brackets report only
210 = return () -- definite errors. The whole thing will be re-checked
211 -- later when we plug it in, and meanwhile there may
212 -- certainly be un-satisfied constraints
213
214 | otherwise
215 = reportWanteds ctxt' wanted
216 where
217 (env1, tvs') = mapAccumL tidyTyVarBndr (cec_tidy ctxt) tvs
218 (env2, info') = tidySkolemInfo env1 info
219 implic' = implic { ic_skols = tvs'
220 , ic_given = map (tidyEvVar env2) given
221 , ic_info = info' }
222 ctxt' = ctxt { cec_tidy = env2
223 , cec_encl = implic' : cec_encl ctxt
224 , cec_binds = case cec_binds ctxt of
225 Nothing -> Nothing
226 Just {} -> Just evb }
227
228 reportWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
229 reportWanteds ctxt wanted@(WC { wc_simple = simples, wc_insol = insols, wc_impl = implics })
230 = do { reportSimples ctxt (mapBag (tidyCt env) insol_given)
231 ; reportSimples ctxt1 (mapBag (tidyCt env) insol_wanted)
232 ; reportSimples ctxt2 (mapBag (tidyCt env) simples)
233 -- All the Derived ones have been filtered out of simples
234 -- by the constraint solver. This is ok; we don't want
235 -- to report unsolved Derived goals as errors
236 -- See Note [Do not report derived but soluble errors]
237 ; mapBagM_ (reportImplic ctxt1) implics }
238 -- NB ctxt1: don't suppress inner insolubles if there's only a
239 -- wanted insoluble here; but do suppress inner insolubles
240 -- if there's a given insoluble here (= inaccessible code)
241 where
242 (insol_given, insol_wanted) = partitionBag isGivenCt insols
243 env = cec_tidy ctxt
244
245 -- See Note [Suppressing error messages]
246 suppress0 = cec_suppress ctxt
247 suppress1 = suppress0 || not (isEmptyBag insol_given)
248 suppress2 = suppress0 || insolubleWC wanted
249 ctxt1 = ctxt { cec_suppress = suppress1 }
250 ctxt2 = ctxt { cec_suppress = suppress2 }
251
252 reportSimples :: ReportErrCtxt -> Cts -> TcM ()
253 reportSimples ctxt simples -- Here 'simples' includes insolble goals
254 = traceTc "reportSimples" (vcat [ ptext (sLit "Simples =") <+> ppr simples
255 , ptext (sLit "Suppress =") <+> ppr (cec_suppress ctxt)])
256 >> tryReporters
257 [ -- First deal with things that are utterly wrong
258 -- Like Int ~ Bool (incl nullary TyCons)
259 -- or Int ~ t a (AppTy on one side)
260 ("Utterly wrong", utterly_wrong, True, mkGroupReporter mkEqErr)
261 , ("Holes", is_hole, False, mkHoleReporter)
262
263 -- Report equalities of form (a~ty). They are usually
264 -- skolem-equalities, and they cause confusing knock-on
265 -- effects in other errors; see test T4093b.
266 , ("Skolem equalities", skolem_eq, True, mkSkolReporter)
267
268 -- Other equalities; also confusing knock on effects
269 , ("Equalities", is_equality, True, mkGroupReporter mkEqErr)
270
271 , ("Implicit params", is_ip, False, mkGroupReporter mkIPErr)
272 , ("Irreds", is_irred, False, mkGroupReporter mkIrredErr)
273 , ("Dicts", is_dict, False, mkGroupReporter mkDictErr)
274 ]
275 panicReporter ctxt (bagToList simples)
276 -- TuplePreds should have been expanded away by the constraint
277 -- simplifier, so they shouldn't show up at this point
278 where
279 utterly_wrong, skolem_eq, is_hole, is_dict,
280 is_equality, is_ip, is_irred :: Ct -> PredTree -> Bool
281
282 utterly_wrong _ (EqPred _ ty1 ty2) = isRigid ty1 && isRigid ty2
283 utterly_wrong _ _ = False
284
285 is_hole ct _ = isHoleCt ct
286
287 skolem_eq _ (EqPred NomEq ty1 ty2) = isRigidOrSkol ty1 && isRigidOrSkol ty2
288 skolem_eq _ _ = False
289
290 is_equality _ (EqPred {}) = True
291 is_equality _ _ = False
292
293 is_dict _ (ClassPred {}) = True
294 is_dict _ _ = False
295
296 is_ip _ (ClassPred cls _) = isIPClass cls
297 is_ip _ _ = False
298
299 is_irred _ (IrredPred {}) = True
300 is_irred _ _ = False
301
302
303 ---------------
304 isRigid, isRigidOrSkol :: Type -> Bool
305 isRigid ty
306 | Just (tc,_) <- tcSplitTyConApp_maybe ty = isDecomposableTyCon tc
307 | Just {} <- tcSplitAppTy_maybe ty = True
308 | isForAllTy ty = True
309 | otherwise = False
310
311 isRigidOrSkol ty
312 | Just tv <- getTyVar_maybe ty = isSkolemTyVar tv
313 | otherwise = isRigid ty
314
315 isTyFun_maybe :: Type -> Maybe TyCon
316 isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of
317 Just (tc,_) | isTypeFamilyTyCon tc -> Just tc
318 _ -> Nothing
319
320
321 --------------------------------------------
322 -- Reporters
323 --------------------------------------------
324
325 type Reporter
326 = ReportErrCtxt -> [Ct] -> TcM ()
327 type ReporterSpec
328 = ( String -- Name
329 , Ct -> PredTree -> Bool -- Pick these ones
330 , Bool -- True <=> suppress subsequent reporters
331 , Reporter) -- The reporter itself
332
333 panicReporter :: Reporter
334 panicReporter _ cts
335 | null cts = return ()
336 | otherwise = pprPanic "reportSimples" (ppr cts)
337
338 mkSkolReporter :: Reporter
339 -- Suppress duplicates with the same LHS
340 mkSkolReporter ctxt cts
341 = mapM_ (reportGroup mkEqErr ctxt) (equivClasses cmp_lhs_type cts)
342 where
343 cmp_lhs_type ct1 ct2
344 = case (classifyPredType (ctPred ct1), classifyPredType (ctPred ct2)) of
345 (EqPred eq_rel1 ty1 _, EqPred eq_rel2 ty2 _) ->
346 (eq_rel1 `compare` eq_rel2) `thenCmp` (ty1 `cmpType` ty2)
347 _ -> pprPanic "mkSkolReporter" (ppr ct1 $$ ppr ct2)
348
349 mkHoleReporter :: Reporter
350 -- Reports errors one at a time
351 mkHoleReporter ctxt
352 = mapM_ $ \ct ->
353 do { err <- mkHoleError ctxt ct
354 ; maybeReportHoleError ctxt ct err
355 ; maybeAddDeferredHoleBinding ctxt err ct }
356
357 mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg)
358 -- Make error message for a group
359 -> Reporter -- Deal with lots of constraints
360 -- Group together errors from same location,
361 -- and report only the first (to avoid a cascade)
362 mkGroupReporter mk_err ctxt cts
363 = mapM_ (reportGroup mk_err ctxt) (equivClasses cmp_loc cts)
364 where
365 cmp_loc ct1 ct2 = ctLocSpan (ctLoc ct1) `compare` ctLocSpan (ctLoc ct2)
366
367 reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> ReportErrCtxt
368 -> [Ct] -> TcM ()
369 reportGroup mk_err ctxt cts
370 = do { err <- mk_err ctxt cts
371 ; maybeReportError ctxt err
372 ; mapM_ (maybeAddDeferredBinding ctxt err) cts }
373 -- Add deferred bindings for all
374 -- But see Note [Always warn with -fdefer-type-errors]
375
376 maybeReportHoleError :: ReportErrCtxt -> Ct -> ErrMsg -> TcM ()
377 maybeReportHoleError ctxt ct err
378 -- When -XPartialTypeSignatures is on, warnings (instead of errors) are
379 -- generated for holes in partial type signatures. Unless
380 -- -fwarn_partial_type_signatures is not on, in which case the messages are
381 -- discarded.
382 | isTypeHoleCt ct
383 = -- For partial type signatures, generate warnings only, and do that
384 -- only if -fwarn_partial_type_signatures is on
385 case cec_type_holes ctxt of
386 HoleError -> reportError err
387 HoleWarn -> reportWarning (makeIntoWarning err)
388 HoleDefer -> return ()
389
390 -- Otherwise this is a typed hole in an expression
391 | otherwise
392 = -- If deferring, report a warning only if -fwarn-typed-holds is on
393 case cec_expr_holes ctxt of
394 HoleError -> reportError err
395 HoleWarn -> reportWarning (makeIntoWarning err)
396 HoleDefer -> return ()
397
398 maybeReportError :: ReportErrCtxt -> ErrMsg -> TcM ()
399 -- Report the error and/or make a deferred binding for it
400 maybeReportError ctxt err
401 -- See Note [Always warn with -fdefer-type-errors]
402 | cec_defer_type_errors ctxt
403 = reportWarning (makeIntoWarning err)
404 | cec_suppress ctxt
405 = return ()
406 | otherwise
407 = reportError err
408
409 addDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
410 -- See Note [Deferring coercion errors to runtime]
411 addDeferredBinding ctxt err ct
412 | CtWanted { ctev_pred = pred, ctev_evar = ev_id } <- ctEvidence ct
413 -- Only add deferred bindings for Wanted constraints
414 , Just ev_binds_var <- cec_binds ctxt -- We have somewhere to put the bindings
415 = do { dflags <- getDynFlags
416 ; let err_msg = pprLocErrMsg err
417 err_fs = mkFastString $ showSDoc dflags $
418 err_msg $$ text "(deferred type error)"
419
420 -- Create the binding
421 ; addTcEvBind ev_binds_var ev_id (EvDelayedError pred err_fs) }
422
423 | otherwise -- Do not set any evidence for Given/Derived
424 = return ()
425
426 maybeAddDeferredHoleBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
427 maybeAddDeferredHoleBinding ctxt err ct
428 | isExprHoleCt ct
429 , case cec_expr_holes ctxt of
430 HoleDefer -> True
431 HoleWarn -> True
432 HoleError -> False
433 = addDeferredBinding ctxt err ct -- Only add bindings for holes in expressions
434 | otherwise -- not for holes in partial type signatures
435 = return ()
436
437 maybeAddDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
438 maybeAddDeferredBinding ctxt err ct
439 | cec_defer_type_errors ctxt
440 = addDeferredBinding ctxt err ct
441 | otherwise
442 = return ()
443
444 tryReporters :: [ReporterSpec] -> Reporter -> Reporter
445 -- Use the first reporter in the list whose predicate says True
446 tryReporters reporters deflt ctxt cts
447 = do { traceTc "tryReporters {" (ppr cts)
448 ; go ctxt reporters cts
449 ; traceTc "tryReporters }" empty }
450 where
451 go ctxt [] cts = deflt ctxt cts
452 go ctxt ((str, pred, suppress_after, reporter) : rs) cts
453 | null yeses = do { traceTc "tryReporters: no" (text str)
454 ; go ctxt rs cts }
455 | otherwise = do { traceTc "tryReporters: yes" (text str <+> ppr yeses)
456 ; reporter ctxt yeses :: TcM ()
457 ; let ctxt' = ctxt { cec_suppress = suppress_after || cec_suppress ctxt }
458 ; go ctxt' rs nos }
459 -- Carry on with the rest, because we must make
460 -- deferred bindings for them if we have
461 -- -fdefer-type-errors
462 -- But suppress their error messages
463 where
464 (yeses, nos) = partition keep_me cts
465 keep_me ct = pred ct (classifyPredType (ctPred ct))
466
467 -- Add the "arising from..." part to a message about bunch of dicts
468 addArising :: CtOrigin -> SDoc -> SDoc
469 addArising orig msg = hang msg 2 (pprArising orig)
470
471 pprWithArising :: [Ct] -> (CtLoc, SDoc)
472 -- Print something like
473 -- (Eq a) arising from a use of x at y
474 -- (Show a) arising from a use of p at q
475 -- Also return a location for the error message
476 -- Works for Wanted/Derived only
477 pprWithArising []
478 = panic "pprWithArising"
479 pprWithArising (ct:cts)
480 | null cts
481 = (loc, addArising (ctLocOrigin loc)
482 (pprTheta [ctPred ct]))
483 | otherwise
484 = (loc, vcat (map ppr_one (ct:cts)))
485 where
486 loc = ctLoc ct
487 ppr_one ct' = hang (parens (pprType (ctPred ct')))
488 2 (pprArisingAt (ctLoc ct'))
489
490 mkErrorMsg :: ReportErrCtxt -> Ct -> SDoc -> TcM ErrMsg
491 mkErrorMsg ctxt ct msg
492 = do { let tcl_env = ctLocEnv (ctLoc ct)
493 ; err_info <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)
494 ; mkLongErrAt (RealSrcSpan (tcl_loc tcl_env)) msg err_info }
495
496 type UserGiven = ([EvVar], SkolemInfo, Bool, RealSrcSpan)
497
498 getUserGivens :: ReportErrCtxt -> [UserGiven]
499 -- One item for each enclosing implication
500 getUserGivens (CEC {cec_encl = ctxt})
501 = reverse $
502 [ (givens, info, no_eqs, tcl_loc env)
503 | Implic { ic_given = givens, ic_env = env
504 , ic_no_eqs = no_eqs, ic_info = info } <- ctxt
505 , not (null givens) ]
506
507 {-
508 Note [Always warn with -fdefer-type-errors]
509 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
510 When -fdefer-type-errors is on we warn about *all* type errors, even
511 if cec_suppress is on. This can lead to a lot more warnings than you
512 would get errors without -fdefer-type-errors, but if we suppress any of
513 them you might get a runtime error that wasn't warned about at compile
514 time.
515
516 This is an easy design choice to change; just flip the order of the
517 first two equations for maybeReportError
518
519 To be consistent, we should also report multiple warnings from a single
520 location in mkGroupReporter, when -fdefer-type-errors is on. But that
521 is perhaps a bit *over*-consistent! Again, an easy choice to change.
522
523
524 Note [Do not report derived but soluble errors]
525 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
526 The wc_simples include Derived constraints that have not been solved, but are
527 not insoluble (in that case they'd be in wc_insols). We do not want to report
528 these as errors:
529
530 * Superclass constraints. If we have an unsolved [W] Ord a, we'll also have
531 an unsolved [D] Eq a, and we do not want to report that; it's just noise.
532
533 * Functional dependencies. For givens, consider
534 class C a b | a -> b
535 data T a where
536 MkT :: C a d => [d] -> T a
537 f :: C a b => T a -> F Int
538 f (MkT xs) = length xs
539 Then we get a [D] b~d. But there *is* a legitimate call to
540 f, namely f (MkT [True]) :: T Bool, in which b=d. So we should
541 not reject the program.
542
543 For wanteds, something similar
544 data T a where
545 MkT :: C Int b => a -> b -> T a
546 g :: C Int c => c -> ()
547 f :: T a -> ()
548 f (MkT x y) = g x
549 Here we get [G] C Int b, [W] C Int a, hence [D] a~b.
550 But again f (MkT True True) is a legitimate call.
551
552 (We leave the Deriveds in wc_simple until reportErrors, so that we don't lose
553 derived superclasses between iterations of the solver.)
554
555 For functional dependencies, here is a real example,
556 stripped off from libraries/utf8-string/Codec/Binary/UTF8/Generic.hs
557
558 class C a b | a -> b
559 g :: C a b => a -> b -> ()
560 f :: C a b => a -> b -> ()
561 f xa xb =
562 let loop = g xa
563 in loop xb
564
565 We will first try to infer a type for loop, and we will succeed:
566 C a b' => b' -> ()
567 Subsequently, we will type check (loop xb) and all is good. But,
568 recall that we have to solve a final implication constraint:
569 C a b => (C a b' => .... cts from body of loop .... ))
570 And now we have a problem as we will generate an equality b ~ b' and fail to
571 solve it.
572
573
574 ************************************************************************
575 * *
576 Irreducible predicate errors
577 * *
578 ************************************************************************
579 -}
580
581 mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
582 mkIrredErr ctxt cts
583 = do { (ctxt, binds_msg) <- relevantBindings True ctxt ct1
584 ; mkErrorMsg ctxt ct1 (msg $$ binds_msg) }
585 where
586 (ct1:_) = cts
587 orig = ctLocOrigin (ctLoc ct1)
588 givens = getUserGivens ctxt
589 msg = couldNotDeduce givens (map ctPred cts, orig)
590
591 ----------------
592 mkHoleError :: ReportErrCtxt -> Ct -> TcM ErrMsg
593 mkHoleError ctxt ct@(CHoleCan { cc_occ = occ, cc_hole = hole_sort })
594 = do { let tyvars = varSetElems (tyVarsOfCt ct)
595 tyvars_msg = map loc_msg tyvars
596 msg = vcat [ hang (ptext (sLit "Found hole") <+> quotes (ppr occ))
597 2 (ptext (sLit "with type:") <+> pprType (ctEvPred (ctEvidence ct)))
598 , ppUnless (null tyvars_msg) (ptext (sLit "Where:") <+> vcat tyvars_msg)
599 , pts_hint ]
600 ; (ctxt, binds_doc) <- relevantBindings False ctxt ct
601 -- The 'False' means "don't filter the bindings"; see Trac #8191
602 ; mkErrorMsg ctxt ct (msg $$ binds_doc) }
603 where
604 pts_hint
605 | TypeHole <- hole_sort
606 , HoleError <- cec_type_holes ctxt
607 = ptext (sLit "To use the inferred type, enable PartialTypeSignatures")
608 | otherwise
609 = empty
610
611 loc_msg tv
612 = case tcTyVarDetails tv of
613 SkolemTv {} -> quotes (ppr tv) <+> skol_msg
614 MetaTv {} -> quotes (ppr tv) <+> ptext (sLit "is an ambiguous type variable")
615 det -> pprTcTyVarDetails det
616 where
617 skol_msg = pprSkol (getSkolemInfo (cec_encl ctxt) tv) (getSrcLoc tv)
618
619 mkHoleError _ ct = pprPanic "mkHoleError" (ppr ct)
620
621 ----------------
622 mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
623 mkIPErr ctxt cts
624 = do { (ctxt, bind_msg) <- relevantBindings True ctxt ct1
625 ; mkErrorMsg ctxt ct1 (msg $$ bind_msg) }
626 where
627 (ct1:_) = cts
628 orig = ctLocOrigin (ctLoc ct1)
629 preds = map ctPred cts
630 givens = getUserGivens ctxt
631 msg | null givens
632 = addArising orig $
633 sep [ ptext (sLit "Unbound implicit parameter") <> plural cts
634 , nest 2 (pprTheta preds) ]
635 | otherwise
636 = couldNotDeduce givens (preds, orig)
637
638 {-
639 ************************************************************************
640 * *
641 Equality errors
642 * *
643 ************************************************************************
644
645 Note [Inaccessible code]
646 ~~~~~~~~~~~~~~~~~~~~~~~~
647 Consider
648 data T a where
649 T1 :: T a
650 T2 :: T Bool
651
652 f :: (a ~ Int) => T a -> Int
653 f T1 = 3
654 f T2 = 4 -- Unreachable code
655
656 Here the second equation is unreachable. The original constraint
657 (a~Int) from the signature gets rewritten by the pattern-match to
658 (Bool~Int), so the danger is that we report the error as coming from
659 the *signature* (Trac #7293). So, for Given errors we replace the
660 env (and hence src-loc) on its CtLoc with that from the immediately
661 enclosing implication.
662 -}
663
664 mkEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
665 -- Don't have multiple equality errors from the same location
666 -- E.g. (Int,Bool) ~ (Bool,Int) one error will do!
667 mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct
668 mkEqErr _ [] = panic "mkEqErr"
669
670 mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg
671 -- Wanted constraints only!
672 mkEqErr1 ctxt ct
673 | isGiven ev
674 = do { (ctxt, binds_msg) <- relevantBindings True ctxt ct
675 ; let (given_loc, given_msg) = mk_given (cec_encl ctxt)
676 ; dflags <- getDynFlags
677 ; mkEqErr_help dflags ctxt (given_msg $$ binds_msg)
678 (ct { cc_ev = ev {ctev_loc = given_loc}}) -- Note [Inaccessible code]
679 Nothing ty1 ty2 }
680
681 | otherwise -- Wanted or derived
682 = do { (ctxt, binds_msg) <- relevantBindings True ctxt ct
683 ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc)
684 ; rdr_env <- getGlobalRdrEnv
685 ; fam_envs <- tcGetFamInstEnvs
686 ; let (is_oriented, wanted_msg) = mk_wanted_extra tidy_orig
687 coercible_msg = case ctEvEqRel ev of
688 NomEq -> empty
689 ReprEq -> mkCoercibleExplanation rdr_env fam_envs ty1 ty2
690 ; dflags <- getDynFlags
691 ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctLocOrigin loc) $$ pprCtOrigin tidy_orig)
692 ; mkEqErr_help dflags (ctxt {cec_tidy = env1})
693 (wanted_msg $$ coercible_msg $$ binds_msg)
694 ct is_oriented ty1 ty2 }
695 where
696 ev = ctEvidence ct
697 loc = ctEvLoc ev
698 (ty1, ty2) = getEqPredTys (ctEvPred ev)
699
700 mk_given :: [Implication] -> (CtLoc, SDoc)
701 -- For given constraints we overwrite the env (and hence src-loc)
702 -- with one from the implication. See Note [Inaccessible code]
703 mk_given [] = (loc, empty)
704 mk_given (implic : _) = (setCtLocEnv loc (ic_env implic)
705 , hang (ptext (sLit "Inaccessible code in"))
706 2 (ppr (ic_info implic)))
707
708 -- If the types in the error message are the same as the types
709 -- we are unifying, don't add the extra expected/actual message
710 mk_wanted_extra orig@(TypeEqOrigin {})
711 = mkExpectedActualMsg ty1 ty2 orig
712
713 mk_wanted_extra (KindEqOrigin cty1 cty2 sub_o)
714 = (Nothing, msg1 $$ msg2)
715 where
716 msg1 = hang (ptext (sLit "When matching types"))
717 2 (vcat [ ppr cty1 <+> dcolon <+> ppr (typeKind cty1)
718 , ppr cty2 <+> dcolon <+> ppr (typeKind cty2) ])
719 msg2 = case sub_o of
720 TypeEqOrigin {} -> snd (mkExpectedActualMsg cty1 cty2 sub_o)
721 _ -> empty
722
723 mk_wanted_extra orig@(FunDepOrigin1 {}) = (Nothing, pprArising orig)
724 mk_wanted_extra orig@(FunDepOrigin2 {}) = (Nothing, pprArising orig)
725 mk_wanted_extra orig@(DerivOriginCoerce _ oty1 oty2)
726 = (Nothing, pprArising orig $+$ mkRoleSigs oty1 oty2)
727 mk_wanted_extra orig@(CoercibleOrigin oty1 oty2)
728 -- if the origin types are the same as the final types, don't
729 -- clutter output with repetitive information
730 | not (oty1 `eqType` ty1 && oty2 `eqType` ty2) &&
731 not (oty1 `eqType` ty2 && oty2 `eqType` ty1)
732 = (Nothing, pprArising orig $+$ mkRoleSigs oty1 oty2)
733 | otherwise
734 -- still print role sigs even if types line up
735 = (Nothing, mkRoleSigs oty1 oty2)
736 mk_wanted_extra _ = (Nothing, empty)
737
738 -- | This function tries to reconstruct why a "Coercible ty1 ty2" constraint
739 -- is left over.
740 mkCoercibleExplanation :: GlobalRdrEnv -> FamInstEnvs
741 -> TcType -> TcType -> SDoc
742 mkCoercibleExplanation rdr_env fam_envs ty1 ty2
743 | Just (tc, tys) <- tcSplitTyConApp_maybe ty1
744 , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys
745 , Just msg <- coercible_msg_for_tycon rep_tc
746 = msg
747 | Just (tc, tys) <- splitTyConApp_maybe ty2
748 , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys
749 , Just msg <- coercible_msg_for_tycon rep_tc
750 = msg
751 | Just (s1, _) <- tcSplitAppTy_maybe ty1
752 , Just (s2, _) <- tcSplitAppTy_maybe ty2
753 , s1 `eqType` s2
754 , has_unknown_roles s1
755 = hang (text "NB: We cannot know what roles the parameters to" <+>
756 quotes (ppr s1) <+> text "have;")
757 2 (text "we must assume that the role is nominal")
758 | otherwise
759 = empty
760 where
761 coercible_msg_for_tycon tc
762 | isAbstractTyCon tc
763 = Just $ hsep [ text "NB: The type constructor"
764 , quotes (pprSourceTyCon tc)
765 , text "is abstract" ]
766 | isNewTyCon tc
767 , [data_con] <- tyConDataCons tc
768 , let dc_name = dataConName data_con
769 , null (lookupGRE_Name rdr_env dc_name)
770 = Just $ hang (text "The data constructor" <+> quotes (ppr dc_name))
771 2 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc)
772 , text "is not in scope" ])
773 | otherwise = Nothing
774
775 has_unknown_roles ty
776 | Just (tc, tys) <- tcSplitTyConApp_maybe ty
777 = length tys >= tyConArity tc -- oversaturated tycon
778 | Just (s, _) <- tcSplitAppTy_maybe ty
779 = has_unknown_roles s
780 | isTyVarTy ty
781 = True
782 | otherwise
783 = False
784
785 -- | Make a listing of role signatures for all the parameterised tycons
786 -- used in the provided types
787 mkRoleSigs :: Type -> Type -> SDoc
788 mkRoleSigs ty1 ty2
789 = ppUnless (null role_sigs) $
790 hang (text "Relevant role signatures:")
791 2 (vcat role_sigs)
792 where
793 tcs = nameEnvElts $ tyConsOfType ty1 `plusNameEnv` tyConsOfType ty2
794 role_sigs = mapMaybe ppr_role_sig tcs
795
796 ppr_role_sig tc
797 | null roles -- if there are no parameters, don't bother printing
798 = Nothing
799 | otherwise
800 = Just $ hsep $ [text "type role", ppr tc] ++ map ppr roles
801 where
802 roles = tyConRoles tc
803
804 mkEqErr_help :: DynFlags -> ReportErrCtxt -> SDoc
805 -> Ct
806 -> Maybe SwapFlag -- Nothing <=> not sure
807 -> TcType -> TcType -> TcM ErrMsg
808 mkEqErr_help dflags ctxt extra ct oriented ty1 ty2
809 | Just tv1 <- tcGetTyVar_maybe ty1 = mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2
810 | Just tv2 <- tcGetTyVar_maybe ty2 = mkTyVarEqErr dflags ctxt extra ct swapped tv2 ty1
811 | otherwise = reportEqErr ctxt extra ct oriented ty1 ty2
812 where
813 swapped = fmap flipSwap oriented
814
815 reportEqErr :: ReportErrCtxt -> SDoc
816 -> Ct
817 -> Maybe SwapFlag -- Nothing <=> not sure
818 -> TcType -> TcType -> TcM ErrMsg
819 reportEqErr ctxt extra1 ct oriented ty1 ty2
820 = do { let extra2 = mkEqInfoMsg ct ty1 ty2
821 ; mkErrorMsg ctxt ct (vcat [ misMatchOrCND ctxt ct oriented ty1 ty2
822 , extra2, extra1]) }
823
824 mkTyVarEqErr :: DynFlags -> ReportErrCtxt -> SDoc -> Ct
825 -> Maybe SwapFlag -> TcTyVar -> TcType -> TcM ErrMsg
826 -- tv1 and ty2 are already tidied
827 mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2
828 | isUserSkolem ctxt tv1 -- ty2 won't be a meta-tyvar, or else the thing would
829 -- be oriented the other way round;
830 -- see TcCanonical.canEqTyVarTyVar
831 || isSigTyVar tv1 && not (isTyVarTy ty2)
832 = mkErrorMsg ctxt ct (vcat [ misMatchOrCND ctxt ct oriented ty1 ty2
833 , extraTyVarInfo ctxt tv1 ty2
834 , extra ])
835
836 -- So tv is a meta tyvar (or started that way before we
837 -- generalised it). So presumably it is an *untouchable*
838 -- meta tyvar or a SigTv, else it'd have been unified
839 | not (k2 `tcIsSubKind` k1) -- Kind error
840 = mkErrorMsg ctxt ct $ (kindErrorMsg (mkTyVarTy tv1) ty2 $$ extra)
841
842 | OC_Occurs <- occ_check_expand
843 , NomEq <- ctEqRel ct -- reporting occurs check for Coercible is strange
844 = do { let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:")
845 2 (sep [ppr ty1, char '~', ppr ty2])
846 extra2 = mkEqInfoMsg ct ty1 ty2
847 ; mkErrorMsg ctxt ct (occCheckMsg $$ extra2 $$ extra) }
848
849 | OC_Forall <- occ_check_expand
850 = do { let msg = vcat [ ptext (sLit "Cannot instantiate unification variable")
851 <+> quotes (ppr tv1)
852 , hang (ptext (sLit "with a type involving foralls:")) 2 (ppr ty2)
853 , nest 2 (ptext (sLit "Perhaps you want ImpredicativeTypes")) ]
854 ; mkErrorMsg ctxt ct msg }
855
856 -- If the immediately-enclosing implication has 'tv' a skolem, and
857 -- we know by now its an InferSkol kind of skolem, then presumably
858 -- it started life as a SigTv, else it'd have been unified, given
859 -- that there's no occurs-check or forall problem
860 | (implic:_) <- cec_encl ctxt
861 , Implic { ic_skols = skols } <- implic
862 , tv1 `elem` skols
863 = mkErrorMsg ctxt ct (vcat [ misMatchMsg oriented eq_rel ty1 ty2
864 , extraTyVarInfo ctxt tv1 ty2
865 , extra ])
866
867 -- Check for skolem escape
868 | (implic:_) <- cec_encl ctxt -- Get the innermost context
869 , Implic { ic_env = env, ic_skols = skols, ic_info = skol_info } <- implic
870 , let esc_skols = filter (`elemVarSet` (tyVarsOfType ty2)) skols
871 , not (null esc_skols)
872 = do { let msg = misMatchMsg oriented eq_rel ty1 ty2
873 esc_doc = sep [ ptext (sLit "because type variable") <> plural esc_skols
874 <+> pprQuotedList esc_skols
875 , ptext (sLit "would escape") <+>
876 if isSingleton esc_skols then ptext (sLit "its scope")
877 else ptext (sLit "their scope") ]
878 tv_extra = vcat [ nest 2 $ esc_doc
879 , sep [ (if isSingleton esc_skols
880 then ptext (sLit "This (rigid, skolem) type variable is")
881 else ptext (sLit "These (rigid, skolem) type variables are"))
882 <+> ptext (sLit "bound by")
883 , nest 2 $ ppr skol_info
884 , nest 2 $ ptext (sLit "at") <+> ppr (tcl_loc env) ] ]
885 ; mkErrorMsg ctxt ct (msg $$ tv_extra $$ extra) }
886
887 -- Nastiest case: attempt to unify an untouchable variable
888 | (implic:_) <- cec_encl ctxt -- Get the innermost context
889 , Implic { ic_env = env, ic_given = given, ic_info = skol_info } <- implic
890 = do { let msg = misMatchMsg oriented eq_rel ty1 ty2
891 tclvl_extra
892 = nest 2 $
893 sep [ quotes (ppr tv1) <+> ptext (sLit "is untouchable")
894 , nest 2 $ ptext (sLit "inside the constraints:") <+> pprEvVarTheta given
895 , nest 2 $ ptext (sLit "bound by") <+> ppr skol_info
896 , nest 2 $ ptext (sLit "at") <+> ppr (tcl_loc env) ]
897 tv_extra = extraTyVarInfo ctxt tv1 ty2
898 add_sig = suggestAddSig ctxt ty1 ty2
899 ; mkErrorMsg ctxt ct (vcat [msg, tclvl_extra, tv_extra, add_sig, extra]) }
900
901 | otherwise
902 = reportEqErr ctxt extra ct oriented (mkTyVarTy tv1) ty2
903 -- This *can* happen (Trac #6123, and test T2627b)
904 -- Consider an ambiguous top-level constraint (a ~ F a)
905 -- Not an occurs check, because F is a type function.
906 where
907 occ_check_expand = occurCheckExpand dflags tv1 ty2
908 k1 = tyVarKind tv1
909 k2 = typeKind ty2
910 ty1 = mkTyVarTy tv1
911 eq_rel = ctEqRel ct
912
913 mkEqInfoMsg :: Ct -> TcType -> TcType -> SDoc
914 -- Report (a) ambiguity if either side is a type function application
915 -- e.g. F a0 ~ Int
916 -- (b) warning about injectivity if both sides are the same
917 -- type function application F a ~ F b
918 -- See Note [Non-injective type functions]
919 mkEqInfoMsg ct ty1 ty2
920 = tyfun_msg $$ ambig_msg
921 where
922 mb_fun1 = isTyFun_maybe ty1
923 mb_fun2 = isTyFun_maybe ty2
924
925 ambig_msg | isJust mb_fun1 || isJust mb_fun2
926 = snd (mkAmbigMsg ct)
927 | otherwise = empty
928
929 tyfun_msg | Just tc1 <- mb_fun1
930 , Just tc2 <- mb_fun2
931 , tc1 == tc2
932 = ptext (sLit "NB:") <+> quotes (ppr tc1)
933 <+> ptext (sLit "is a type function, and may not be injective")
934 | otherwise = empty
935
936 isUserSkolem :: ReportErrCtxt -> TcTyVar -> Bool
937 -- See Note [Reporting occurs-check errors]
938 isUserSkolem ctxt tv
939 = isSkolemTyVar tv && any is_user_skol_tv (cec_encl ctxt)
940 where
941 is_user_skol_tv (Implic { ic_skols = sks, ic_info = skol_info })
942 = tv `elem` sks && is_user_skol_info skol_info
943
944 is_user_skol_info (InferSkol {}) = False
945 is_user_skol_info _ = True
946
947 misMatchOrCND :: ReportErrCtxt -> Ct -> Maybe SwapFlag -> TcType -> TcType -> SDoc
948 -- If oriented then ty1 is actual, ty2 is expected
949 misMatchOrCND ctxt ct oriented ty1 ty2
950 | null givens ||
951 (isRigid ty1 && isRigid ty2) ||
952 isGivenCt ct
953 -- If the equality is unconditionally insoluble
954 -- or there is no context, don't report the context
955 = misMatchMsg oriented (ctEqRel ct) ty1 ty2
956 | otherwise
957 = couldNotDeduce givens ([mkTcEqPred ty1 ty2], orig)
958 where
959 givens = [ given | given@(_, _, no_eqs, _) <- getUserGivens ctxt, not no_eqs]
960 -- Keep only UserGivens that have some equalities
961 orig = TypeEqOrigin { uo_actual = ty1, uo_expected = ty2 }
962
963 couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc
964 couldNotDeduce givens (wanteds, orig)
965 = vcat [ addArising orig (ptext (sLit "Could not deduce:") <+> pprTheta wanteds)
966 , vcat (pp_givens givens)]
967
968 pp_givens :: [UserGiven] -> [SDoc]
969 pp_givens givens
970 = case givens of
971 [] -> []
972 (g:gs) -> ppr_given (ptext (sLit "from the context:")) g
973 : map (ppr_given (ptext (sLit "or from:"))) gs
974 where
975 ppr_given herald (gs, skol_info, _, loc)
976 = hang (herald <+> pprEvVarTheta gs)
977 2 (sep [ ptext (sLit "bound by") <+> ppr skol_info
978 , ptext (sLit "at") <+> ppr loc])
979
980 extraTyVarInfo :: ReportErrCtxt -> TcTyVar -> TcType -> SDoc
981 -- Add on extra info about skolem constants
982 -- NB: The types themselves are already tidied
983 extraTyVarInfo ctxt tv1 ty2
984 = nest 2 (tv_extra tv1 $$ ty_extra ty2)
985 where
986 implics = cec_encl ctxt
987 ty_extra ty = case tcGetTyVar_maybe ty of
988 Just tv -> tv_extra tv
989 Nothing -> empty
990
991 tv_extra tv | isTcTyVar tv, isSkolemTyVar tv
992 , let pp_tv = quotes (ppr tv)
993 = case tcTyVarDetails tv of
994 SkolemTv {} -> pp_tv <+> pprSkol (getSkolemInfo implics tv) (getSrcLoc tv)
995 FlatSkol {} -> pp_tv <+> ptext (sLit "is a flattening type variable")
996 RuntimeUnk {} -> pp_tv <+> ptext (sLit "is an interactive-debugger skolem")
997 MetaTv {} -> empty
998
999 | otherwise -- Normal case
1000 = empty
1001
1002 suggestAddSig :: ReportErrCtxt -> TcType -> TcType -> SDoc
1003 -- See Note [Suggest adding a type signature]
1004 suggestAddSig ctxt ty1 ty2
1005 | null inferred_bndrs
1006 = empty
1007 | [bndr] <- inferred_bndrs
1008 = ptext (sLit "Possible fix: add a type signature for") <+> quotes (ppr bndr)
1009 | otherwise
1010 = ptext (sLit "Possible fix: add type signatures for some or all of") <+> (ppr inferred_bndrs)
1011 where
1012 inferred_bndrs = nub (get_inf ty1 ++ get_inf ty2)
1013 get_inf ty | Just tv <- tcGetTyVar_maybe ty
1014 , isTcTyVar tv, isSkolemTyVar tv
1015 , InferSkol prs <- getSkolemInfo (cec_encl ctxt) tv
1016 = map fst prs
1017 | otherwise
1018 = []
1019
1020 kindErrorMsg :: TcType -> TcType -> SDoc -- Types are already tidy
1021 kindErrorMsg ty1 ty2
1022 = vcat [ ptext (sLit "Kind incompatibility when matching types:")
1023 , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1
1024 , ppr ty2 <+> dcolon <+> ppr k2 ]) ]
1025 where
1026 k1 = typeKind ty1
1027 k2 = typeKind ty2
1028
1029 --------------------
1030 misMatchMsg :: Maybe SwapFlag -> EqRel -> TcType -> TcType -> SDoc
1031 -- Types are already tidy
1032 -- If oriented then ty1 is actual, ty2 is expected
1033 misMatchMsg oriented eq_rel ty1 ty2
1034 | Just IsSwapped <- oriented
1035 = misMatchMsg (Just NotSwapped) eq_rel ty2 ty1
1036 | Just NotSwapped <- oriented
1037 = sep [ text "Couldn't match" <+> repr1 <+> text "expected" <+>
1038 what <+> quotes (ppr ty2)
1039 , nest (12 + extra_space) $
1040 text "with" <+> repr2 <+> text "actual" <+> what <+> quotes (ppr ty1)
1041 , sameOccExtra ty2 ty1 ]
1042 | otherwise
1043 = sep [ text "Couldn't match" <+> repr1 <+> what <+> quotes (ppr ty1)
1044 , nest (15 + extra_space) $
1045 text "with" <+> repr2 <+> quotes (ppr ty2)
1046 , sameOccExtra ty1 ty2 ]
1047 where
1048 what | isKind ty1 = ptext (sLit "kind")
1049 | otherwise = ptext (sLit "type")
1050
1051 (repr1, repr2, extra_space) = case eq_rel of
1052 NomEq -> (empty, empty, 0)
1053 ReprEq -> (text "representation of", text "that of", 10)
1054
1055 mkExpectedActualMsg :: Type -> Type -> CtOrigin -> (Maybe SwapFlag, SDoc)
1056 -- NotSwapped means (actual, expected), IsSwapped is the reverse
1057 mkExpectedActualMsg ty1 ty2 (TypeEqOrigin { uo_actual = act, uo_expected = exp })
1058 | act `pickyEqType` ty1, exp `pickyEqType` ty2 = (Just NotSwapped, empty)
1059 | exp `pickyEqType` ty1, act `pickyEqType` ty2 = (Just IsSwapped, empty)
1060 | otherwise = (Nothing, msg)
1061 where
1062 msg = vcat [ text "Expected type:" <+> ppr exp
1063 , text " Actual type:" <+> ppr act ]
1064
1065 mkExpectedActualMsg _ _ _ = panic "mkExprectedAcutalMsg"
1066
1067 sameOccExtra :: TcType -> TcType -> SDoc
1068 -- See Note [Disambiguating (X ~ X) errors]
1069 sameOccExtra ty1 ty2
1070 | Just (tc1, _) <- tcSplitTyConApp_maybe ty1
1071 , Just (tc2, _) <- tcSplitTyConApp_maybe ty2
1072 , let n1 = tyConName tc1
1073 n2 = tyConName tc2
1074 same_occ = nameOccName n1 == nameOccName n2
1075 same_pkg = modulePackageKey (nameModule n1) == modulePackageKey (nameModule n2)
1076 , n1 /= n2 -- Different Names
1077 , same_occ -- but same OccName
1078 = ptext (sLit "NB:") <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2)
1079 | otherwise
1080 = empty
1081 where
1082 ppr_from same_pkg nm
1083 | isGoodSrcSpan loc
1084 = hang (quotes (ppr nm) <+> ptext (sLit "is defined at"))
1085 2 (ppr loc)
1086 | otherwise -- Imported things have an UnhelpfulSrcSpan
1087 = hang (quotes (ppr nm))
1088 2 (sep [ ptext (sLit "is defined in") <+> quotes (ppr (moduleName mod))
1089 , ppUnless (same_pkg || pkg == mainPackageKey) $
1090 nest 4 $ ptext (sLit "in package") <+> quotes (ppr pkg) ])
1091 where
1092 pkg = modulePackageKey mod
1093 mod = nameModule nm
1094 loc = nameSrcSpan nm
1095
1096 {-
1097 Note [Suggest adding a type signature]
1098 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1099 The OutsideIn algorithm rejects GADT programs that don't have a principal
1100 type, and indeed some that do. Example:
1101 data T a where
1102 MkT :: Int -> T Int
1103
1104 f (MkT n) = n
1105
1106 Does this have type f :: T a -> a, or f :: T a -> Int?
1107 The error that shows up tends to be an attempt to unify an
1108 untouchable type variable. So suggestAddSig sees if the offending
1109 type variable is bound by an *inferred* signature, and suggests
1110 adding a declared signature instead.
1111
1112 This initially came up in Trac #8968, concerning pattern synonyms.
1113
1114 Note [Disambiguating (X ~ X) errors]
1115 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1116 See Trac #8278
1117
1118 Note [Reporting occurs-check errors]
1119 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1120 Given (a ~ [a]), if 'a' is a rigid type variable bound by a user-supplied
1121 type signature, then the best thing is to report that we can't unify
1122 a with [a], because a is a skolem variable. That avoids the confusing
1123 "occur-check" error message.
1124
1125 But nowadays when inferring the type of a function with no type signature,
1126 even if there are errors inside, we still generalise its signature and
1127 carry on. For example
1128 f x = x:x
1129 Here we will infer somethiing like
1130 f :: forall a. a -> [a]
1131 with a suspended error of (a ~ [a]). So 'a' is now a skolem, but not
1132 one bound by the programmer! Here we really should report an occurs check.
1133
1134 So isUserSkolem distinguishes the two.
1135
1136 Note [Non-injective type functions]
1137 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1138 It's very confusing to get a message like
1139 Couldn't match expected type `Depend s'
1140 against inferred type `Depend s1'
1141 so mkTyFunInfoMsg adds:
1142 NB: `Depend' is type function, and hence may not be injective
1143
1144 Warn of loopy local equalities that were dropped.
1145
1146
1147 ************************************************************************
1148 * *
1149 Type-class errors
1150 * *
1151 ************************************************************************
1152 -}
1153
1154 mkDictErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
1155 mkDictErr ctxt cts
1156 = ASSERT( not (null cts) )
1157 do { inst_envs <- tcGetInstEnvs
1158 ; let (ct1:_) = cts -- ct1 just for its location
1159 min_cts = elim_superclasses cts
1160 ; lookups <- mapM (lookup_cls_inst inst_envs) min_cts
1161 ; let (no_inst_cts, overlap_cts) = partition is_no_inst lookups
1162
1163 -- Report definite no-instance errors,
1164 -- or (iff there are none) overlap errors
1165 -- But we report only one of them (hence 'head') because they all
1166 -- have the same source-location origin, to try avoid a cascade
1167 -- of error from one location
1168 ; (ctxt, err) <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts))
1169 ; mkErrorMsg ctxt ct1 err }
1170 where
1171 no_givens = null (getUserGivens ctxt)
1172
1173 is_no_inst (ct, (matches, unifiers, _))
1174 = no_givens
1175 && null matches
1176 && (null unifiers || all (not . isAmbiguousTyVar) (varSetElems (tyVarsOfCt ct)))
1177
1178 lookup_cls_inst inst_envs ct
1179 = do { tys_flat <- mapM quickFlattenTy tys
1180 -- Note [Flattening in error message generation]
1181 ; return (ct, lookupInstEnv inst_envs clas tys_flat) }
1182 where
1183 (clas, tys) = getClassPredTys (ctPred ct)
1184
1185
1186 -- When simplifying [W] Ord (Set a), we need
1187 -- [W] Eq a, [W] Ord a
1188 -- but we really only want to report the latter
1189 elim_superclasses cts
1190 = filter (\ct -> any (eqPred (ctPred ct)) min_preds) cts
1191 where
1192 min_preds = mkMinimalBySCs (map ctPred cts)
1193
1194 mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult)
1195 -> TcM (ReportErrCtxt, SDoc)
1196 -- Report an overlap error if this class constraint results
1197 -- from an overlap (returning Left clas), otherwise return (Right pred)
1198 mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell))
1199 | null matches -- No matches but perhaps several unifiers
1200 = do { let (is_ambig, ambig_msg) = mkAmbigMsg ct
1201 ; (ctxt, binds_msg) <- relevantBindings True ctxt ct
1202 ; traceTc "mk_dict_err" (ppr ct $$ ppr is_ambig $$ ambig_msg)
1203 ; return (ctxt, cannot_resolve_msg is_ambig binds_msg ambig_msg) }
1204
1205 | not safe_haskell -- Some matches => overlap errors
1206 = return (ctxt, overlap_msg)
1207
1208 | otherwise
1209 = return (ctxt, safe_haskell_msg)
1210 where
1211 orig = ctLocOrigin (ctLoc ct)
1212 pred = ctPred ct
1213 (clas, tys) = getClassPredTys pred
1214 ispecs = [ispec | (ispec, _) <- matches]
1215 givens = getUserGivens ctxt
1216 all_tyvars = all isTyVarTy tys
1217
1218 cannot_resolve_msg has_ambig_tvs binds_msg ambig_msg
1219 = vcat [ addArising orig no_inst_msg
1220 , vcat (pp_givens givens)
1221 , ppWhen (has_ambig_tvs && not (null unifiers && null givens))
1222 (vcat [ ambig_msg, binds_msg, potential_msg ])
1223 , show_fixes (add_to_ctxt_fixes has_ambig_tvs ++ drv_fixes) ]
1224
1225 potential_msg
1226 = ppWhen (not (null unifiers) && want_potential orig) $
1227 hang (if isSingleton unifiers
1228 then ptext (sLit "Note: there is a potential instance available:")
1229 else ptext (sLit "Note: there are several potential instances:"))
1230 2 (ppr_insts (sortBy fuzzyClsInstCmp unifiers))
1231
1232 -- Report "potential instances" only when the constraint arises
1233 -- directly from the user's use of an overloaded function
1234 want_potential (TypeEqOrigin {}) = False
1235 want_potential _ = True
1236
1237 add_to_ctxt_fixes has_ambig_tvs
1238 | not has_ambig_tvs && all_tyvars
1239 , (orig:origs) <- usefulContext ctxt pred
1240 = [sep [ ptext (sLit "add") <+> pprParendType pred
1241 <+> ptext (sLit "to the context of")
1242 , nest 2 $ ppr_skol orig $$
1243 vcat [ ptext (sLit "or") <+> ppr_skol orig
1244 | orig <- origs ] ] ]
1245 | otherwise = []
1246
1247 ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc)
1248 ppr_skol skol_info = ppr skol_info
1249
1250 no_inst_msg
1251 | null givens && null matches
1252 = ptext (sLit "No instance for")
1253 <+> pprParendType pred
1254 $$ if type_has_arrow pred
1255 then nest 2 $ ptext (sLit "(maybe you haven't applied a function to enough arguments?)")
1256 else empty
1257
1258 | otherwise
1259 = ptext (sLit "Could not deduce") <+> pprParendType pred
1260
1261 type_has_arrow (TyVarTy _) = False
1262 type_has_arrow (AppTy t1 t2) = type_has_arrow t1 || type_has_arrow t2
1263 type_has_arrow (TyConApp _ ts) = or $ map type_has_arrow ts
1264 type_has_arrow (FunTy _ _) = True
1265 type_has_arrow (ForAllTy _ t) = type_has_arrow t
1266 type_has_arrow (LitTy _) = False
1267
1268 drv_fixes = case orig of
1269 DerivOrigin -> [drv_fix]
1270 DerivOriginDC {} -> [drv_fix]
1271 DerivOriginCoerce {} -> [drv_fix]
1272 _ -> []
1273
1274 drv_fix = hang (ptext (sLit "use a standalone 'deriving instance' declaration,"))
1275 2 (ptext (sLit "so you can specify the instance context yourself"))
1276
1277 -- Normal overlap error
1278 overlap_msg
1279 = ASSERT( not (null matches) )
1280 vcat [ addArising orig (ptext (sLit "Overlapping instances for")
1281 <+> pprType (mkClassPred clas tys))
1282
1283 , ppUnless (null matching_givens) $
1284 sep [ptext (sLit "Matching givens (or their superclasses):")
1285 , nest 2 (vcat matching_givens)]
1286
1287 , sep [ptext (sLit "Matching instances:"),
1288 nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
1289
1290 , ppWhen (null matching_givens && isSingleton matches && null unifiers) $
1291 -- Intuitively, some given matched the wanted in their
1292 -- flattened or rewritten (from given equalities) form
1293 -- but the matcher can't figure that out because the
1294 -- constraints are non-flat and non-rewritten so we
1295 -- simply report back the whole given
1296 -- context. Accelerate Smart.hs showed this problem.
1297 sep [ ptext (sLit "There exists a (perhaps superclass) match:")
1298 , nest 2 (vcat (pp_givens givens))]
1299
1300 , ppWhen (isSingleton matches) $
1301 parens (vcat [ ptext (sLit "The choice depends on the instantiation of") <+>
1302 quotes (pprWithCommas ppr (varSetElems (tyVarsOfTypes tys)))
1303 , ppWhen (null (matching_givens)) $
1304 vcat [ ptext (sLit "To pick the first instance above, use IncoherentInstances")
1305 , ptext (sLit "when compiling the other instance declarations")]
1306 ])]
1307 where
1308 ispecs = [ispec | (ispec, _) <- matches]
1309
1310 givens = getUserGivens ctxt
1311 matching_givens = mapMaybe matchable givens
1312
1313 matchable (evvars,skol_info,_,loc)
1314 = case ev_vars_matching of
1315 [] -> Nothing
1316 _ -> Just $ hang (pprTheta ev_vars_matching)
1317 2 (sep [ ptext (sLit "bound by") <+> ppr skol_info
1318 , ptext (sLit "at") <+> ppr loc])
1319 where ev_vars_matching = filter ev_var_matches (map evVarPred evvars)
1320 ev_var_matches ty = case getClassPredTys_maybe ty of
1321 Just (clas', tys')
1322 | clas' == clas
1323 , Just _ <- tcMatchTys (tyVarsOfTypes tys) tys tys'
1324 -> True
1325 | otherwise
1326 -> any ev_var_matches (immSuperClasses clas' tys')
1327 Nothing -> False
1328
1329 -- Overlap error because of Safe Haskell (first
1330 -- match should be the most specific match)
1331 safe_haskell_msg
1332 = ASSERT( length matches > 1 )
1333 vcat [ addArising orig (ptext (sLit "Unsafe overlapping instances for")
1334 <+> pprType (mkClassPred clas tys))
1335 , sep [ptext (sLit "The matching instance is:"),
1336 nest 2 (pprInstance $ head ispecs)]
1337 , vcat [ ptext $ sLit "It is compiled in a Safe module and as such can only"
1338 , ptext $ sLit "overlap instances from the same module, however it"
1339 , ptext $ sLit "overlaps the following instances from different modules:"
1340 , nest 2 (vcat [pprInstances $ tail ispecs])
1341 ]
1342 ]
1343
1344 usefulContext :: ReportErrCtxt -> TcPredType -> [SkolemInfo]
1345 usefulContext ctxt pred
1346 = go (cec_encl ctxt)
1347 where
1348 pred_tvs = tyVarsOfType pred
1349 go [] = []
1350 go (ic : ics)
1351 = case ic_info ic of
1352 -- Do not suggest adding constraints to an *inferred* type signature!
1353 SigSkol (InfSigCtxt {}) _ -> rest
1354 info -> info : rest
1355 where
1356 -- Stop when the context binds a variable free in the predicate
1357 rest | any (`elemVarSet` pred_tvs) (ic_skols ic) = []
1358 | otherwise = go ics
1359
1360 show_fixes :: [SDoc] -> SDoc
1361 show_fixes [] = empty
1362 show_fixes (f:fs) = sep [ ptext (sLit "Possible fix:")
1363 , nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
1364
1365 ppr_insts :: [ClsInst] -> SDoc
1366 ppr_insts insts
1367 = pprInstances (take 3 insts) $$ dot_dot_message
1368 where
1369 n_extra = length insts - 3
1370 dot_dot_message
1371 | n_extra <= 0 = empty
1372 | otherwise = ptext (sLit "...plus")
1373 <+> speakNOf n_extra (ptext (sLit "other"))
1374
1375 ----------------------
1376 quickFlattenTy :: TcType -> TcM TcType
1377 -- See Note [Flattening in error message generation]
1378 quickFlattenTy ty | Just ty' <- tcView ty = quickFlattenTy ty'
1379 quickFlattenTy ty@(TyVarTy {}) = return ty
1380 quickFlattenTy ty@(ForAllTy {}) = return ty -- See
1381 quickFlattenTy ty@(LitTy {}) = return ty
1382 -- Don't flatten because of the danger or removing a bound variable
1383 quickFlattenTy (AppTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
1384 ; fy2 <- quickFlattenTy ty2
1385 ; return (AppTy fy1 fy2) }
1386 quickFlattenTy (FunTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
1387 ; fy2 <- quickFlattenTy ty2
1388 ; return (FunTy fy1 fy2) }
1389 quickFlattenTy (TyConApp tc tys)
1390 | not (isTypeFamilyTyCon tc)
1391 = do { fys <- mapM quickFlattenTy tys
1392 ; return (TyConApp tc fys) }
1393 | otherwise
1394 = do { let (funtys,resttys) = splitAt (tyConArity tc) tys
1395 -- Ignore the arguments of the type family funtys
1396 ; v <- newMetaTyVar (TauTv False) (typeKind (TyConApp tc funtys))
1397 ; flat_resttys <- mapM quickFlattenTy resttys
1398 ; return (foldl AppTy (mkTyVarTy v) flat_resttys) }
1399
1400 {-
1401 Note [Flattening in error message generation]
1402 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1403 Consider (C (Maybe (F x))), where F is a type function, and we have
1404 instances
1405 C (Maybe Int) and C (Maybe a)
1406 Since (F x) might turn into Int, this is an overlap situation, and
1407 indeed (because of flattening) the main solver will have refrained
1408 from solving. But by the time we get to error message generation, we've
1409 un-flattened the constraint. So we must *re*-flatten it before looking
1410 up in the instance environment, lest we only report one matching
1411 instance when in fact there are two.
1412
1413 Re-flattening is pretty easy, because we don't need to keep track of
1414 evidence. We don't re-use the code in TcCanonical because that's in
1415 the TcS monad, and we are in TcM here.
1416
1417 Note [Quick-flatten polytypes]
1418 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1419 If we see C (Ix a => blah) or C (forall a. blah) we simply refrain from
1420 flattening any further. After all, there can be no instance declarations
1421 that match such things. And flattening under a for-all is problematic
1422 anyway; consider C (forall a. F a)
1423
1424 Note [Suggest -fprint-explicit-kinds]
1425 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1426 It can be terribly confusing to get an error message like (Trac #9171)
1427 Couldn't match expected type ‘GetParam Base (GetParam Base Int)’
1428 with actual type ‘GetParam Base (GetParam Base Int)’
1429 The reason may be that the kinds don't match up. Typically you'll get
1430 more useful information, but not when it's as a result of ambiguity.
1431 This test suggests -fprint-explicit-kinds when all the ambiguous type
1432 variables are kind variables.
1433 -}
1434
1435 mkAmbigMsg :: Ct -> (Bool, SDoc)
1436 mkAmbigMsg ct
1437 | null ambig_tkvs = (False, empty)
1438 | otherwise = (True, msg)
1439 where
1440 ambig_tkv_set = filterVarSet isAmbiguousTyVar (tyVarsOfCt ct)
1441 ambig_tkvs = varSetElems ambig_tkv_set
1442 (ambig_kvs, ambig_tvs) = partition isKindVar ambig_tkvs
1443
1444 msg | any isRuntimeUnkSkol ambig_tkvs -- See Note [Runtime skolems]
1445 = vcat [ ptext (sLit "Cannot resolve unknown runtime type") <> plural ambig_tvs
1446 <+> pprQuotedList ambig_tvs
1447 , ptext (sLit "Use :print or :force to determine these types")]
1448
1449 | not (null ambig_tvs)
1450 = pp_ambig (ptext (sLit "type")) ambig_tvs
1451
1452 | otherwise -- All ambiguous kind variabes; suggest -fprint-explicit-kinds
1453 = vcat [ pp_ambig (ptext (sLit "kind")) ambig_kvs
1454 , sdocWithDynFlags suggest_explicit_kinds ]
1455
1456 pp_ambig what tkvs
1457 = ptext (sLit "The") <+> what <+> ptext (sLit "variable") <> plural tkvs
1458 <+> pprQuotedList tkvs <+> is_or_are tkvs <+> ptext (sLit "ambiguous")
1459
1460 is_or_are [_] = text "is"
1461 is_or_are _ = text "are"
1462
1463 suggest_explicit_kinds dflags -- See Note [Suggest -fprint-explicit-kinds]
1464 | gopt Opt_PrintExplicitKinds dflags = empty
1465 | otherwise = ptext (sLit "Use -fprint-explicit-kinds to see the kind arguments")
1466
1467 pprSkol :: SkolemInfo -> SrcLoc -> SDoc
1468 pprSkol UnkSkol _
1469 = ptext (sLit "is an unknown type variable")
1470 pprSkol skol_info tv_loc
1471 = sep [ ptext (sLit "is a rigid type variable bound by"),
1472 sep [ppr skol_info, ptext (sLit "at") <+> ppr tv_loc]]
1473
1474 getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo
1475 -- Get the skolem info for a type variable
1476 -- from the implication constraint that binds it
1477 getSkolemInfo [] tv
1478 = pprPanic "No skolem info:" (ppr tv)
1479
1480 getSkolemInfo (implic:implics) tv
1481 | tv `elem` ic_skols implic = ic_info implic
1482 | otherwise = getSkolemInfo implics tv
1483
1484 -----------------------
1485 -- relevantBindings looks at the value environment and finds values whose
1486 -- types mention any of the offending type variables. It has to be
1487 -- careful to zonk the Id's type first, so it has to be in the monad.
1488 -- We must be careful to pass it a zonked type variable, too.
1489 --
1490 -- We always remove closed top-level bindings, though,
1491 -- since they are never relevant (cf Trac #8233)
1492
1493 relevantBindings :: Bool -- True <=> filter by tyvar; False <=> no filtering
1494 -- See Trac #8191
1495 -> ReportErrCtxt -> Ct
1496 -> TcM (ReportErrCtxt, SDoc)
1497 relevantBindings want_filtering ctxt ct
1498 = do { dflags <- getDynFlags
1499 ; (tidy_env', docs, discards)
1500 <- go (cec_tidy ctxt) (maxRelevantBinds dflags)
1501 emptyVarSet [] False
1502 (tcl_bndrs lcl_env)
1503 -- tcl_bndrs has the innermost bindings first,
1504 -- which are probably the most relevant ones
1505
1506 ; traceTc "relevantBindings" (ppr ct $$ ppr [id | TcIdBndr id _ <- tcl_bndrs lcl_env])
1507 ; let doc = hang (ptext (sLit "Relevant bindings include"))
1508 2 (vcat docs $$ max_msg)
1509 max_msg | discards
1510 = ptext (sLit "(Some bindings suppressed; use -fmax-relevant-binds=N or -fno-max-relevant-binds)")
1511 | otherwise = empty
1512
1513 ; if null docs
1514 then return (ctxt, empty)
1515 else do { traceTc "rb" doc
1516 ; return (ctxt { cec_tidy = tidy_env' }, doc) } }
1517 where
1518 loc = ctLoc ct
1519 lcl_env = ctLocEnv loc
1520 ct_tvs = tyVarsOfCt ct `unionVarSet` extra_tvs
1521
1522 -- For *kind* errors, report the relevant bindings of the
1523 -- enclosing *type* equality, because that's more useful for the programmer
1524 extra_tvs = case ctLocOrigin loc of
1525 KindEqOrigin t1 t2 _ -> tyVarsOfTypes [t1,t2]
1526 _ -> emptyVarSet
1527
1528 run_out :: Maybe Int -> Bool
1529 run_out Nothing = False
1530 run_out (Just n) = n <= 0
1531
1532 dec_max :: Maybe Int -> Maybe Int
1533 dec_max = fmap (\n -> n - 1)
1534
1535 go :: TidyEnv -> Maybe Int -> TcTyVarSet -> [SDoc]
1536 -> Bool -- True <=> some filtered out due to lack of fuel
1537 -> [TcIdBinder]
1538 -> TcM (TidyEnv, [SDoc], Bool) -- The bool says if we filtered any out
1539 -- because of lack of fuel
1540 go tidy_env _ _ docs discards []
1541 = return (tidy_env, reverse docs, discards)
1542 go tidy_env n_left tvs_seen docs discards (TcIdBndr id top_lvl : tc_bndrs)
1543 = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id)
1544 ; traceTc "relevantBindings 1" (ppr id <+> dcolon <+> ppr tidy_ty)
1545 ; let id_tvs = tyVarsOfType tidy_ty
1546 doc = sep [ pprPrefixOcc id <+> dcolon <+> ppr tidy_ty
1547 , nest 2 (parens (ptext (sLit "bound at")
1548 <+> ppr (getSrcLoc id)))]
1549 new_seen = tvs_seen `unionVarSet` id_tvs
1550
1551 ; if (want_filtering && not opt_PprStyle_Debug
1552 && id_tvs `disjointVarSet` ct_tvs)
1553 -- We want to filter out this binding anyway
1554 -- so discard it silently
1555 then go tidy_env n_left tvs_seen docs discards tc_bndrs
1556
1557 else if isTopLevel top_lvl && not (isNothing n_left)
1558 -- It's a top-level binding and we have not specified
1559 -- -fno-max-relevant-bindings, so discard it silently
1560 then go tidy_env n_left tvs_seen docs discards tc_bndrs
1561
1562 else if run_out n_left && id_tvs `subVarSet` tvs_seen
1563 -- We've run out of n_left fuel and this binding only
1564 -- mentions aleady-seen type variables, so discard it
1565 then go tidy_env n_left tvs_seen docs True tc_bndrs
1566
1567 -- Keep this binding, decrement fuel
1568 else go tidy_env' (dec_max n_left) new_seen (doc:docs) discards tc_bndrs }
1569
1570 -----------------------
1571 warnDefaulting :: Cts -> Type -> TcM ()
1572 warnDefaulting wanteds default_ty
1573 = do { warn_default <- woptM Opt_WarnTypeDefaults
1574 ; env0 <- tcInitTidyEnv
1575 ; let tidy_env = tidyFreeTyVars env0 $
1576 tyVarsOfCts wanteds
1577 tidy_wanteds = mapBag (tidyCt tidy_env) wanteds
1578 (loc, ppr_wanteds) = pprWithArising (bagToList tidy_wanteds)
1579 warn_msg = hang (ptext (sLit "Defaulting the following constraint(s) to type")
1580 <+> quotes (ppr default_ty))
1581 2 ppr_wanteds
1582 ; setCtLoc loc $ warnTc warn_default warn_msg }
1583
1584 {-
1585 Note [Runtime skolems]
1586 ~~~~~~~~~~~~~~~~~~~~~~
1587 We want to give a reasonably helpful error message for ambiguity
1588 arising from *runtime* skolems in the debugger. These
1589 are created by in RtClosureInspect.zonkRTTIType.
1590
1591 ************************************************************************
1592 * *
1593 Error from the canonicaliser
1594 These ones are called *during* constraint simplification
1595 * *
1596 ************************************************************************
1597 -}
1598
1599 solverDepthErrorTcS :: SubGoalCounter -> CtEvidence -> TcM a
1600 solverDepthErrorTcS cnt ev
1601 = setCtLoc loc $
1602 do { pred <- zonkTcType (ctEvPred ev)
1603 ; env0 <- tcInitTidyEnv
1604 ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfType pred)
1605 tidy_pred = tidyType tidy_env pred
1606 ; failWithTcM (tidy_env, hang (msg cnt) 2 (ppr tidy_pred)) }
1607 where
1608 loc = ctEvLoc ev
1609 depth = ctLocDepth loc
1610 value = subGoalCounterValue cnt depth
1611 msg CountConstraints =
1612 vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int value
1613 , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
1614 msg CountTyFunApps =
1615 vcat [ ptext (sLit "Type function application stack overflow; size =") <+> int value
1616 , ptext (sLit "Use -ftype-function-depth=N to increase stack size to N") ]