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