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