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