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