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