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