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