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