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