d47ecc631539d0e05c36ada5265cfa24ba86f3d6
[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 TcUnify( occCheckForErrors, OccCheckResult(..) )
16 import TcType
17 import RnEnv( unknownNameSuggestions )
18 import Type
19 import TyCoRep
20 import Kind
21 import Unify ( tcMatchTys )
22 import Module
23 import FamInst
24 import FamInstEnv ( flattenTys )
25 import Inst
26 import InstEnv
27 import TyCon
28 import Class
29 import DataCon
30 import TcEvidence
31 import HsExpr ( UnboundVar(..) )
32 import HsBinds ( PatSynBind(..) )
33 import Name
34 import RdrName ( lookupGlobalRdrEnv, lookupGRE_Name, GlobalRdrEnv
35 , mkRdrUnqual, isLocalGRE, greSrcSpan )
36 import PrelNames ( typeableClassName, hasKey, liftedRepDataConKey )
37 import Id
38 import Var
39 import VarSet
40 import VarEnv
41 import NameSet
42 import Bag
43 import ErrUtils ( ErrMsg, errDoc, pprLocErrMsg )
44 import BasicTypes
45 import ConLike ( ConLike(..) )
46 import Util
47 import FastString
48 import Outputable
49 import SrcLoc
50 import DynFlags
51 import ListSetOps ( equivClasses )
52 import Maybes
53 import qualified GHC.LanguageExtensions as LangExt
54 import FV ( fvVarList, unionFV )
55
56 import Control.Monad ( when )
57 import Data.List ( partition, mapAccumL, nub, sortBy, unfoldr )
58 import qualified Data.Set as Set
59
60 #if __GLASGOW_HASKELL__ > 710
61 import Data.Semigroup ( Semigroup )
62 import qualified Data.Semigroup as Semigroup
63 #endif
64
65
66 {-
67 ************************************************************************
68 * *
69 \section{Errors and contexts}
70 * *
71 ************************************************************************
72
73 ToDo: for these error messages, should we note the location as coming
74 from the insts, or just whatever seems to be around in the monad just
75 now?
76
77 Note [Deferring coercion errors to runtime]
78 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
79 While developing, sometimes it is desirable to allow compilation to succeed even
80 if there are type errors in the code. Consider the following case:
81
82 module Main where
83
84 a :: Int
85 a = 'a'
86
87 main = print "b"
88
89 Even though `a` is ill-typed, it is not used in the end, so if all that we're
90 interested in is `main` it is handy to be able to ignore the problems in `a`.
91
92 Since we treat type equalities as evidence, this is relatively simple. Whenever
93 we run into a type mismatch in TcUnify, we normally just emit an error. But it
94 is always safe to defer the mismatch to the main constraint solver. If we do
95 that, `a` will get transformed into
96
97 co :: Int ~ Char
98 co = ...
99
100 a :: Int
101 a = 'a' `cast` co
102
103 The constraint solver would realize that `co` is an insoluble constraint, and
104 emit an error with `reportUnsolved`. But we can also replace the right-hand side
105 of `co` with `error "Deferred type error: Int ~ Char"`. This allows the program
106 to compile, and it will run fine unless we evaluate `a`. This is what
107 `deferErrorsToRuntime` does.
108
109 It does this by keeping track of which errors correspond to which coercion
110 in TcErrors. TcErrors.reportTidyWanteds does not print the errors
111 and does not fail if -fdefer-type-errors is on, so that we can continue
112 compilation. The errors are turned into warnings in `reportUnsolved`.
113 -}
114
115 -- | Report unsolved goals as errors or warnings. We may also turn some into
116 -- deferred run-time errors if `-fdefer-type-errors` is on.
117 reportUnsolved :: WantedConstraints -> TcM (Bag EvBind)
118 reportUnsolved wanted
119 = do { binds_var <- newTcEvBinds
120 ; defer_errors <- goptM Opt_DeferTypeErrors
121 ; warn_errors <- woptM Opt_WarnDeferredTypeErrors -- implement #10283
122 ; let type_errors | not defer_errors = TypeError
123 | warn_errors = TypeWarn
124 | otherwise = TypeDefer
125
126 ; defer_holes <- goptM Opt_DeferTypedHoles
127 ; warn_holes <- woptM Opt_WarnTypedHoles
128 ; let expr_holes | not defer_holes = HoleError
129 | warn_holes = HoleWarn
130 | otherwise = HoleDefer
131
132 ; partial_sigs <- xoptM LangExt.PartialTypeSignatures
133 ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures
134 ; let type_holes | not partial_sigs = HoleError
135 | warn_partial_sigs = HoleWarn
136 | otherwise = HoleDefer
137
138 ; defer_out_of_scope <- goptM Opt_DeferOutOfScopeVariables
139 ; warn_out_of_scope <- woptM Opt_WarnDeferredOutOfScopeVariables
140 ; let out_of_scope_holes | not defer_out_of_scope = HoleError
141 | warn_out_of_scope = HoleWarn
142 | otherwise = HoleDefer
143
144 ; report_unsolved binds_var False type_errors expr_holes
145 type_holes out_of_scope_holes wanted
146
147 ; ev_binds <- getTcEvBindsMap binds_var
148 ; return (evBindMapBinds ev_binds)}
149
150 -- | Report *all* unsolved goals as errors, even if -fdefer-type-errors is on
151 -- However, do not make any evidence bindings, because we don't
152 -- have any convenient place to put them.
153 -- See Note [Deferring coercion errors to runtime]
154 -- Used by solveEqualities for kind equalities
155 -- (see Note [Fail fast on kind errors] in TcSimplify]
156 -- and for simplifyDefault.
157 reportAllUnsolved :: WantedConstraints -> TcM ()
158 reportAllUnsolved wanted
159 = do { ev_binds <- newTcEvBinds
160 ; report_unsolved ev_binds False TypeError
161 HoleError HoleError HoleError wanted }
162
163 -- | Report all unsolved goals as warnings (but without deferring any errors to
164 -- run-time). See Note [Safe Haskell Overlapping Instances Implementation] in
165 -- TcSimplify
166 warnAllUnsolved :: WantedConstraints -> TcM ()
167 warnAllUnsolved wanted
168 = do { ev_binds <- newTcEvBinds
169 ; report_unsolved ev_binds True TypeWarn
170 HoleWarn HoleWarn HoleWarn wanted }
171
172 -- | Report unsolved goals as errors or warnings.
173 report_unsolved :: EvBindsVar -- cec_binds
174 -> Bool -- Errors as warnings
175 -> TypeErrorChoice -- Deferred type errors
176 -> HoleChoice -- Expression holes
177 -> HoleChoice -- Type holes
178 -> HoleChoice -- Out of scope holes
179 -> WantedConstraints -> TcM ()
180 report_unsolved mb_binds_var err_as_warn type_errors expr_holes
181 type_holes out_of_scope_holes wanted
182 | isEmptyWC wanted
183 = return ()
184 | otherwise
185 = do { traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted)
186
187 ; wanted <- zonkWC wanted -- Zonk to reveal all information
188 ; env0 <- tcInitTidyEnv
189 -- If we are deferring we are going to need /all/ evidence around,
190 -- including the evidence produced by unflattening (zonkWC)
191 ; let tidy_env = tidyFreeTyCoVars env0 free_tvs
192 free_tvs = tyCoVarsOfWCList wanted
193
194 ; traceTc "reportUnsolved (after zonking):" $
195 vcat [ text "Free tyvars:" <+> pprTyVars free_tvs
196 , text "Wanted:" <+> ppr wanted ]
197
198 ; warn_redundant <- woptM Opt_WarnRedundantConstraints
199 ; let err_ctxt = CEC { cec_encl = []
200 , cec_tidy = tidy_env
201 , cec_defer_type_errors = type_errors
202 , cec_errors_as_warns = err_as_warn
203 , cec_expr_holes = expr_holes
204 , cec_type_holes = type_holes
205 , cec_out_of_scope_holes = out_of_scope_holes
206 , cec_suppress = False -- See Note [Suppressing error messages]
207 , cec_warn_redundant = warn_redundant
208 , cec_binds = mb_binds_var }
209
210 ; tc_lvl <- getTcLevel
211 ; reportWanteds err_ctxt tc_lvl wanted }
212
213 --------------------------------------------
214 -- Internal functions
215 --------------------------------------------
216
217 -- | An error Report collects messages categorised by their importance.
218 -- See Note [Error report] for details.
219 data Report
220 = Report { report_important :: [SDoc]
221 , report_relevant_bindings :: [SDoc]
222 }
223
224 instance Outputable Report where -- Debugging only
225 ppr (Report { report_important = imp, report_relevant_bindings = rel })
226 = vcat [ text "important:" <+> vcat imp
227 , text "relevant:" <+> vcat rel ]
228
229 {- Note [Error report]
230 The idea is that error msgs are divided into three parts: the main msg, the
231 context block (\"In the second argument of ...\"), and the relevant bindings
232 block, which are displayed in that order, with a mark to divide them. The
233 idea is that the main msg ('report_important') varies depending on the error
234 in question, but context and relevant bindings are always the same, which
235 should simplify visual parsing.
236
237 The context is added when the the Report is passed off to 'mkErrorReport'.
238 Unfortunately, unlike the context, the relevant bindings are added in
239 multiple places so they have to be in the Report.
240 -}
241
242 #if __GLASGOW_HASKELL__ > 710
243 instance Semigroup Report where
244 Report a1 b1 <> Report a2 b2 = Report (a1 ++ a2) (b1 ++ b2)
245 #endif
246
247 instance Monoid Report where
248 mempty = Report [] []
249 mappend (Report a1 b1) (Report a2 b2) = Report (a1 ++ a2) (b1 ++ b2)
250
251 -- | Put a doc into the important msgs block.
252 important :: SDoc -> Report
253 important doc = mempty { report_important = [doc] }
254
255 -- | Put a doc into the relevant bindings block.
256 relevant_bindings :: SDoc -> Report
257 relevant_bindings doc = mempty { report_relevant_bindings = [doc] }
258
259 data TypeErrorChoice -- What to do for type errors found by the type checker
260 = TypeError -- A type error aborts compilation with an error message
261 | TypeWarn -- A type error is deferred to runtime, plus a compile-time warning
262 | TypeDefer -- A type error is deferred to runtime; no error or warning at compile time
263
264 data HoleChoice
265 = HoleError -- A hole is a compile-time error
266 | HoleWarn -- Defer to runtime, emit a compile-time warning
267 | HoleDefer -- Defer to runtime, no warning
268
269 instance Outputable HoleChoice where
270 ppr HoleError = text "HoleError"
271 ppr HoleWarn = text "HoleWarn"
272 ppr HoleDefer = text "HoleDefer"
273
274 instance Outputable TypeErrorChoice where
275 ppr TypeError = text "TypeError"
276 ppr TypeWarn = text "TypeWarn"
277 ppr TypeDefer = text "TypeDefer"
278
279 data ReportErrCtxt
280 = CEC { cec_encl :: [Implication] -- Enclosing implications
281 -- (innermost first)
282 -- ic_skols and givens are tidied, rest are not
283 , cec_tidy :: TidyEnv
284
285 , cec_binds :: EvBindsVar -- Make some errors (depending on cec_defer)
286 -- into warnings, and emit evidence bindings
287 -- into 'cec_binds' for unsolved constraints
288
289 , cec_errors_as_warns :: Bool -- Turn all errors into warnings
290 -- (except for Holes, which are
291 -- controlled by cec_type_holes and
292 -- cec_expr_holes)
293 , cec_defer_type_errors :: TypeErrorChoice -- Defer type errors until runtime
294
295 -- cec_expr_holes is a union of:
296 -- cec_type_holes - a set of typed holes: '_', '_a', '_foo'
297 -- cec_out_of_scope_holes - a set of variables which are
298 -- out of scope: 'x', 'y', 'bar'
299 , cec_expr_holes :: HoleChoice -- Holes in expressions
300 , cec_type_holes :: HoleChoice -- Holes in types
301 , cec_out_of_scope_holes :: HoleChoice -- Out of scope holes
302
303 , cec_warn_redundant :: Bool -- True <=> -Wredundant-constraints
304
305 , cec_suppress :: Bool -- True <=> More important errors have occurred,
306 -- so create bindings if need be, but
307 -- don't issue any more errors/warnings
308 -- See Note [Suppressing error messages]
309 }
310
311 {-
312 Note [Suppressing error messages]
313 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
314 The cec_suppress flag says "don't report any errors". Instead, just create
315 evidence bindings (as usual). It's used when more important errors have occurred.
316
317 Specifically (see reportWanteds)
318 * If there are insoluble Givens, then we are in unreachable code and all bets
319 are off. So don't report any further errors.
320 * If there are any insolubles (eg Int~Bool), here or in a nested implication,
321 then suppress errors from the simple constraints here. Sometimes the
322 simple-constraint errors are a knock-on effect of the insolubles.
323 -}
324
325 reportImplic :: ReportErrCtxt -> Implication -> TcM ()
326 reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given
327 , ic_wanted = wanted, ic_binds = evb
328 , ic_status = status, ic_info = info
329 , ic_env = tcl_env, ic_tclvl = tc_lvl })
330 | BracketSkol <- info
331 , not insoluble
332 = return () -- For Template Haskell brackets report only
333 -- definite errors. The whole thing will be re-checked
334 -- later when we plug it in, and meanwhile there may
335 -- certainly be un-satisfied constraints
336
337 | otherwise
338 = do { traceTc "reportImplic" (ppr implic')
339 ; reportWanteds ctxt' tc_lvl wanted
340 ; when (cec_warn_redundant ctxt) $
341 warnRedundantConstraints ctxt' tcl_env info' dead_givens }
342 where
343 insoluble = isInsolubleStatus status
344 (env1, tvs') = mapAccumL tidyTyCoVarBndr (cec_tidy ctxt) tvs
345 info' = tidySkolemInfo env1 info
346 implic' = implic { ic_skols = tvs'
347 , ic_given = map (tidyEvVar env1) given
348 , ic_info = info' }
349 ctxt' = ctxt { cec_tidy = env1
350 , cec_encl = implic' : cec_encl ctxt
351
352 , cec_suppress = insoluble || cec_suppress ctxt
353 -- Suppress inessential errors if there
354 -- are are insolubles anywhere in the
355 -- tree rooted here, or we've come across
356 -- a suppress-worthy constraint higher up (Trac #11541)
357
358 , cec_binds = evb }
359
360 dead_givens = case status of
361 IC_Solved { ics_dead = dead } -> dead
362 _ -> []
363
364 warnRedundantConstraints :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [EvVar] -> TcM ()
365 -- See Note [Tracking redundant constraints] in TcSimplify
366 warnRedundantConstraints ctxt env info ev_vars
367 | null redundant_evs
368 = return ()
369
370 | SigSkol {} <- info
371 = setLclEnv env $ -- We want to add "In the type signature for f"
372 -- to the error context, which is a bit tiresome
373 addErrCtxt (text "In" <+> ppr info) $
374 do { env <- getLclEnv
375 ; msg <- mkErrorReport ctxt env (important doc)
376 ; reportWarning (Reason Opt_WarnRedundantConstraints) msg }
377
378 | otherwise -- But for InstSkol there already *is* a surrounding
379 -- "In the instance declaration for Eq [a]" context
380 -- and we don't want to say it twice. Seems a bit ad-hoc
381 = do { msg <- mkErrorReport ctxt env (important doc)
382 ; reportWarning (Reason Opt_WarnRedundantConstraints) msg }
383 where
384 doc = text "Redundant constraint" <> plural redundant_evs <> colon
385 <+> pprEvVarTheta redundant_evs
386
387 redundant_evs = case info of -- See Note [Redundant constraints in instance decls]
388 InstSkol -> filterOut improving ev_vars
389 _ -> ev_vars
390
391 improving ev_var = any isImprovementPred $
392 transSuperClasses (idType ev_var)
393
394 {- Note [Redundant constraints in instance decls]
395 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
396 For instance declarations, we don't report unused givens if
397 they can give rise to improvement. Example (Trac #10100):
398 class Add a b ab | a b -> ab, a ab -> b
399 instance Add Zero b b
400 instance Add a b ab => Add (Succ a) b (Succ ab)
401 The context (Add a b ab) for the instance is clearly unused in terms
402 of evidence, since the dictionary has no feilds. But it is still
403 needed! With the context, a wanted constraint
404 Add (Succ Zero) beta (Succ Zero)
405 we will reduce to (Add Zero beta Zero), and thence we get beta := Zero.
406 But without the context we won't find beta := Zero.
407
408 This only matters in instance declarations..
409 -}
410
411 reportWanteds :: ReportErrCtxt -> TcLevel -> WantedConstraints -> TcM ()
412 reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_insol = insols, wc_impl = implics })
413 = do { traceTc "reportWanteds" (vcat [ text "Simples =" <+> ppr simples
414 , text "Suppress =" <+> ppr (cec_suppress ctxt)])
415 ; let tidy_cts = bagToList (mapBag (tidyCt env) (insols `unionBags` simples))
416
417 -- First deal with things that are utterly wrong
418 -- Like Int ~ Bool (incl nullary TyCons)
419 -- or Int ~ t a (AppTy on one side)
420 -- These ones are not suppressed by the incoming context
421 ; let ctxt_for_insols = ctxt { cec_suppress = False }
422 ; (ctxt1, cts1) <- tryReporters ctxt_for_insols report1 tidy_cts
423
424 -- Now all the other constraints. We suppress errors here if
425 -- any of the first batch failed, or if the enclosing context
426 -- says to suppress
427 ; let ctxt2 = ctxt { cec_suppress = cec_suppress ctxt || cec_suppress ctxt1 }
428 ; (_, leftovers) <- tryReporters ctxt2 report2 cts1
429 ; MASSERT2( null leftovers, ppr leftovers )
430
431 -- All the Derived ones have been filtered out of simples
432 -- by the constraint solver. This is ok; we don't want
433 -- to report unsolved Derived goals as errors
434 -- See Note [Do not report derived but soluble errors]
435
436 ; mapBagM_ (reportImplic ctxt2) implics }
437 -- NB ctxt1: don't suppress inner insolubles if there's only a
438 -- wanted insoluble here; but do suppress inner insolubles
439 -- if there's a *given* insoluble here (= inaccessible code)
440 where
441 env = cec_tidy ctxt
442
443 -- report1: ones that should *not* be suppresed by
444 -- an insoluble somewhere else in the tree
445 -- It's crucial that anything that is considered insoluble
446 -- (see TcRnTypes.trulyInsoluble) is caught here, otherwise
447 -- we might suppress its error message, and proceed on past
448 -- type checking to get a Lint error later
449 report1 = [ ("custom_error", is_user_type_error,
450 True, mkUserTypeErrorReporter)
451 , ("insoluble1", is_given_eq, True, mkGivenErrorReporter)
452 , ("insoluble2", utterly_wrong, True, mkGroupReporter mkEqErr)
453 , ("skolem eq1", very_wrong, True, mkSkolReporter)
454 , ("skolem eq2", skolem_eq, True, mkSkolReporter)
455 , ("non-tv eq", non_tv_eq, True, mkSkolReporter)
456 , ("Out of scope", is_out_of_scope, True, mkHoleReporter)
457 , ("Holes", is_hole, False, mkHoleReporter)
458
459 -- The only remaining equalities are alpha ~ ty,
460 -- where alpha is untouchable; and representational equalities
461 , ("Other eqs", is_equality, False, mkGroupReporter mkEqErr) ]
462
463 -- report2: we suppress these if there are insolubles elsewhere in the tree
464 report2 = [ ("Implicit params", is_ip, False, mkGroupReporter mkIPErr)
465 , ("Irreds", is_irred, False, mkGroupReporter mkIrredErr)
466 , ("Dicts", is_dict, False, mkGroupReporter mkDictErr) ]
467
468 -- rigid_nom_eq, rigid_nom_tv_eq,
469 is_hole, is_dict,
470 is_equality, is_ip, is_irred :: Ct -> PredTree -> Bool
471
472 is_given_eq ct pred
473 | EqPred {} <- pred = arisesFromGivens ct
474 | otherwise = False
475 -- I think all given residuals are equalities
476
477 -- Things like (Int ~N Bool)
478 utterly_wrong _ (EqPred NomEq ty1 ty2) = isRigidTy ty1 && isRigidTy ty2
479 utterly_wrong _ _ = False
480
481 -- Things like (a ~N Int)
482 very_wrong _ (EqPred NomEq ty1 ty2) = isSkolemTy tc_lvl ty1 && isRigidTy ty2
483 very_wrong _ _ = False
484
485 -- Things like (a ~N b) or (a ~N F Bool)
486 skolem_eq _ (EqPred NomEq ty1 _) = isSkolemTy tc_lvl ty1
487 skolem_eq _ _ = False
488
489 -- Things like (F a ~N Int)
490 non_tv_eq _ (EqPred NomEq ty1 _) = not (isTyVarTy ty1)
491 non_tv_eq _ _ = False
492
493 -- rigid_nom_eq _ pred = isRigidEqPred tc_lvl pred
494 --
495 -- rigid_nom_tv_eq _ pred
496 -- | EqPred _ ty1 _ <- pred = isRigidEqPred tc_lvl pred && isTyVarTy ty1
497 -- | otherwise = False
498
499 is_out_of_scope ct _ = isOutOfScopeCt ct
500 is_hole ct _ = isHoleCt ct
501
502 is_user_type_error ct _ = isUserTypeErrorCt ct
503
504 is_equality _ (EqPred {}) = True
505 is_equality _ _ = False
506
507 is_dict _ (ClassPred {}) = True
508 is_dict _ _ = False
509
510 is_ip _ (ClassPred cls _) = isIPClass cls
511 is_ip _ _ = False
512
513 is_irred _ (IrredPred {}) = True
514 is_irred _ _ = False
515
516
517 ---------------
518 isSkolemTy :: TcLevel -> Type -> Bool
519 -- The type is a skolem tyvar
520 isSkolemTy tc_lvl ty
521 | Just tv <- getTyVar_maybe ty
522 = isSkolemTyVar tv
523 || (isSigTyVar tv && isTouchableMetaTyVar tc_lvl tv)
524 -- The last case is for touchable SigTvs
525 -- we postpone untouchables to a latter test (too obscure)
526
527 | otherwise
528 = False
529
530 isTyFun_maybe :: Type -> Maybe TyCon
531 isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of
532 Just (tc,_) | isTypeFamilyTyCon tc -> Just tc
533 _ -> Nothing
534
535 --------------------------------------------
536 -- Reporters
537 --------------------------------------------
538
539 type Reporter
540 = ReportErrCtxt -> [Ct] -> TcM ()
541 type ReporterSpec
542 = ( String -- Name
543 , Ct -> PredTree -> Bool -- Pick these ones
544 , Bool -- True <=> suppress subsequent reporters
545 , Reporter) -- The reporter itself
546
547 mkSkolReporter :: Reporter
548 -- Suppress duplicates with either the same LHS, or same location
549 mkSkolReporter ctxt cts
550 = mapM_ (reportGroup mkEqErr ctxt) (group cts)
551 where
552 group [] = []
553 group (ct:cts) = (ct : yeses) : group noes
554 where
555 (yeses, noes) = partition (group_with ct) cts
556
557 group_with ct1 ct2
558 | EQ <- cmp_loc ct1 ct2 = True
559 | eq_lhs_type ct1 ct2 = True
560 | otherwise = False
561
562 mkHoleReporter :: Reporter
563 -- Reports errors one at a time
564 mkHoleReporter ctxt
565 = mapM_ $ \ct -> do { err <- mkHoleError ctxt ct
566 ; maybeReportHoleError ctxt ct err
567 ; maybeAddDeferredHoleBinding ctxt err ct }
568
569 mkUserTypeErrorReporter :: Reporter
570 mkUserTypeErrorReporter ctxt
571 = mapM_ $ \ct -> do { err <- mkUserTypeError ctxt ct
572 ; maybeReportError ctxt err }
573
574 mkUserTypeError :: ReportErrCtxt -> Ct -> TcM ErrMsg
575 mkUserTypeError ctxt ct = mkErrorMsgFromCt ctxt ct
576 $ important
577 $ pprUserTypeErrorTy
578 $ case getUserTypeErrorMsg ct of
579 Just msg -> msg
580 Nothing -> pprPanic "mkUserTypeError" (ppr ct)
581
582
583 mkGivenErrorReporter :: Reporter
584 -- See Note [Given errors]
585 mkGivenErrorReporter ctxt cts
586 | Just implic <- find_gadt_match (cec_encl ctxt)
587 = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct
588 ; dflags <- getDynFlags
589 ; let ct' = setCtLoc ct (setCtLocEnv (ctLoc ct) (ic_env implic))
590 -- For given constraints we overwrite the env (and hence src-loc)
591 -- with one from the implication. See Note [Inaccessible code]
592
593 inaccessible_msg = hang (text "Inaccessible code in")
594 2 (ppr (ic_info implic))
595 report = important inaccessible_msg `mappend`
596 relevant_bindings binds_msg
597
598 ; err <- mkEqErr_help dflags ctxt report ct'
599 Nothing ty1 ty2
600
601 ; traceTc "mkGivenErrorRporter" (ppr ct)
602 ; maybeReportError ctxt err }
603
604 | otherwise -- Discard Given errors that don't come from
605 -- a pattern match; maybe we should warn instead?
606 = do { traceTc "mkGivenErrorRporter no" (ppr ct $$ ppr (cec_encl ctxt))
607 ; return () }
608 where
609 (ct : _ ) = cts -- Never empty
610 (ty1, ty2) = getEqPredTys (ctPred ct)
611
612 find_gadt_match [] = Nothing
613 find_gadt_match (implic : implics)
614 | PatSkol {} <- ic_info implic
615 , not (ic_no_eqs implic)
616 = Just implic
617 | otherwise
618 = find_gadt_match implics
619
620 {- Note [Given errors]
621 ~~~~~~~~~~~~~~~~~~~~~~
622 Given constraints represent things for which we have (or will have)
623 evidence, so they aren't errors. But if a Given constraint is
624 insoluble, this code is inaccessible, and we might want to at least
625 warn about that. A classic case is
626
627 data T a where
628 T1 :: T Int
629 T2 :: T a
630 T3 :: T Bool
631
632 f :: T Int -> Bool
633 f T1 = ...
634 f T2 = ...
635 f T3 = ... -- We want to report this case as inaccessible
636
637 We'd like to point out that the T3 match is inaccessible. It
638 will have a Given constraint [G] Int ~ Bool.
639
640 But we don't want to report ALL insoluble Given constraints. See Trac
641 #12466 for a long discussion on. For example, if we aren't careful
642 we'll complain about
643 f :: ((Int ~ Bool) => a -> a) -> Int
644 which arguably is OK. It's more debatable for
645 g :: (Int ~ Bool) => Int -> Int
646 but it's tricky to distinguish these cases to we don't report
647 either.
648
649 The bottom line is this: find_gadt_match looks for an encosing
650 pattern match which binds some equality constraints. If we
651 find one, we report the insoluble Given.
652 -}
653
654 mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg)
655 -- Make error message for a group
656 -> Reporter -- Deal with lots of constraints
657 -- Group together errors from same location,
658 -- and report only the first (to avoid a cascade)
659 mkGroupReporter mk_err ctxt cts
660 = mapM_ (reportGroup mk_err ctxt) (equivClasses cmp_loc cts)
661
662 eq_lhs_type :: Ct -> Ct -> Bool
663 eq_lhs_type ct1 ct2
664 = case (classifyPredType (ctPred ct1), classifyPredType (ctPred ct2)) of
665 (EqPred eq_rel1 ty1 _, EqPred eq_rel2 ty2 _) ->
666 (eq_rel1 == eq_rel2) && (ty1 `eqType` ty2)
667 _ -> pprPanic "mkSkolReporter" (ppr ct1 $$ ppr ct2)
668
669 cmp_loc :: Ct -> Ct -> Ordering
670 cmp_loc ct1 ct2 = ctLocSpan (ctLoc ct1) `compare` ctLocSpan (ctLoc ct2)
671
672 reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> ReportErrCtxt
673 -> [Ct] -> TcM ()
674 reportGroup mk_err ctxt cts =
675 case partition isMonadFailInstanceMissing cts of
676 -- Only warn about missing MonadFail constraint when
677 -- there are no other missing constraints!
678 (monadFailCts, []) ->
679 do { err <- mk_err ctxt monadFailCts
680 ; reportWarning (Reason Opt_WarnMissingMonadFailInstances) err }
681
682 (_, cts') -> do { err <- mk_err ctxt cts'
683 ; maybeReportError ctxt err
684 -- But see Note [Always warn with -fdefer-type-errors]
685 ; traceTc "reportGroup" (ppr cts')
686 ; mapM_ (addDeferredBinding ctxt err) cts' }
687 -- Add deferred bindings for all
688 -- Redundant if we are going to abort compilation,
689 -- but that's hard to know for sure, and if we don't
690 -- abort, we need bindings for all (e.g. Trac #12156)
691 where
692 isMonadFailInstanceMissing ct =
693 case ctLocOrigin (ctLoc ct) of
694 FailablePattern _pat -> True
695 _otherwise -> False
696
697 maybeReportHoleError :: ReportErrCtxt -> Ct -> ErrMsg -> TcM ()
698 maybeReportHoleError ctxt ct err
699 -- When -XPartialTypeSignatures is on, warnings (instead of errors) are
700 -- generated for holes in partial type signatures.
701 -- Unless -fwarn_partial_type_signatures is not on,
702 -- in which case the messages are discarded.
703 | isTypeHoleCt ct
704 = -- For partial type signatures, generate warnings only, and do that
705 -- only if -fwarn_partial_type_signatures is on
706 case cec_type_holes ctxt of
707 HoleError -> reportError err
708 HoleWarn -> reportWarning (Reason Opt_WarnPartialTypeSignatures) err
709 HoleDefer -> return ()
710
711 -- Always report an error for out-of-scope variables
712 -- Unless -fdefer-out-of-scope-variables is on,
713 -- in which case the messages are discarded.
714 -- See Trac #12170, #12406
715 | isOutOfScopeCt ct
716 = -- If deferring, report a warning only if -Wout-of-scope-variables is on
717 case cec_out_of_scope_holes ctxt of
718 HoleError -> reportError err
719 HoleWarn ->
720 reportWarning (Reason Opt_WarnDeferredOutOfScopeVariables) err
721 HoleDefer -> return ()
722
723 -- Otherwise this is a typed hole in an expression,
724 -- but not for an out-of-scope variable
725 | otherwise
726 = -- If deferring, report a warning only if -Wtyped-holes is on
727 case cec_expr_holes ctxt of
728 HoleError -> reportError err
729 HoleWarn -> reportWarning (Reason Opt_WarnTypedHoles) err
730 HoleDefer -> return ()
731
732 maybeReportError :: ReportErrCtxt -> ErrMsg -> TcM ()
733 -- Report the error and/or make a deferred binding for it
734 maybeReportError ctxt err
735 | cec_suppress ctxt -- Some worse error has occurred;
736 = return () -- so suppress this error/warning
737
738 | cec_errors_as_warns ctxt
739 = reportWarning NoReason err
740
741 | otherwise
742 = case cec_defer_type_errors ctxt of
743 TypeDefer -> return ()
744 TypeWarn -> reportWarning (Reason Opt_WarnDeferredTypeErrors) err
745 TypeError -> reportError err
746
747 addDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
748 -- See Note [Deferring coercion errors to runtime]
749 addDeferredBinding ctxt err ct
750 | CtWanted { ctev_pred = pred, ctev_dest = dest } <- ctEvidence ct
751 -- Only add deferred bindings for Wanted constraints
752 = do { dflags <- getDynFlags
753 ; let err_msg = pprLocErrMsg err
754 err_fs = mkFastString $ showSDoc dflags $
755 err_msg $$ text "(deferred type error)"
756 err_tm = EvDelayedError pred err_fs
757 ev_binds_var = cec_binds ctxt
758
759 ; case dest of
760 EvVarDest evar
761 -> addTcEvBind ev_binds_var $ mkWantedEvBind evar err_tm
762 HoleDest hole
763 -> do { -- See Note [Deferred errors for coercion holes]
764 evar <- newEvVar pred
765 ; addTcEvBind ev_binds_var $ mkWantedEvBind evar err_tm
766 ; fillCoercionHole hole (mkTcCoVarCo evar) }}
767
768 | otherwise -- Do not set any evidence for Given/Derived
769 = return ()
770
771 maybeAddDeferredHoleBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
772 maybeAddDeferredHoleBinding ctxt err ct
773 | isExprHoleCt ct
774 = addDeferredBinding ctxt err ct -- Only add bindings for holes in expressions
775 | otherwise -- not for holes in partial type signatures
776 = return ()
777
778 tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct])
779 -- Use the first reporter in the list whose predicate says True
780 tryReporters ctxt reporters cts
781 = do { traceTc "tryReporters {" (ppr cts)
782 ; (ctxt', cts') <- go ctxt reporters cts
783 ; traceTc "tryReporters }" (ppr cts')
784 ; return (ctxt', cts') }
785 where
786 go ctxt [] cts
787 = return (ctxt, cts)
788
789 go ctxt (r : rs) cts
790 = do { (ctxt', cts') <- tryReporter ctxt r cts
791 ; go ctxt' rs cts' }
792 -- Carry on with the rest, because we must make
793 -- deferred bindings for them if we have -fdefer-type-errors
794 -- But suppress their error messages
795
796 tryReporter :: ReportErrCtxt -> ReporterSpec -> [Ct] -> TcM (ReportErrCtxt, [Ct])
797 tryReporter ctxt (str, keep_me, suppress_after, reporter) cts
798 | null yeses = return (ctxt, cts)
799 | otherwise = do { traceTc "tryReporter{ " (text str <+> ppr yeses)
800 ; reporter ctxt yeses
801 ; let ctxt' = ctxt { cec_suppress = suppress_after || cec_suppress ctxt }
802 ; traceTc "tryReporter end }" (text str <+> ppr (cec_suppress ctxt) <+> ppr suppress_after)
803 ; return (ctxt', nos) }
804 where
805 (yeses, nos) = partition (\ct -> keep_me ct (classifyPredType (ctPred ct))) cts
806
807
808 pprArising :: CtOrigin -> SDoc
809 -- Used for the main, top-level error message
810 -- We've done special processing for TypeEq, KindEq, Given
811 pprArising (TypeEqOrigin {}) = empty
812 pprArising (KindEqOrigin {}) = empty
813 pprArising (GivenOrigin {}) = empty
814 pprArising orig = pprCtOrigin orig
815
816 -- Add the "arising from..." part to a message about bunch of dicts
817 addArising :: CtOrigin -> SDoc -> SDoc
818 addArising orig msg = hang msg 2 (pprArising orig)
819
820 pprWithArising :: [Ct] -> (CtLoc, SDoc)
821 -- Print something like
822 -- (Eq a) arising from a use of x at y
823 -- (Show a) arising from a use of p at q
824 -- Also return a location for the error message
825 -- Works for Wanted/Derived only
826 pprWithArising []
827 = panic "pprWithArising"
828 pprWithArising (ct:cts)
829 | null cts
830 = (loc, addArising (ctLocOrigin loc)
831 (pprTheta [ctPred ct]))
832 | otherwise
833 = (loc, vcat (map ppr_one (ct:cts)))
834 where
835 loc = ctLoc ct
836 ppr_one ct' = hang (parens (pprType (ctPred ct')))
837 2 (pprCtLoc (ctLoc ct'))
838
839 mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> Report -> TcM ErrMsg
840 mkErrorMsgFromCt ctxt ct report
841 = mkErrorReport ctxt (ctLocEnv (ctLoc ct)) report
842
843 mkErrorReport :: ReportErrCtxt -> TcLclEnv -> Report -> TcM ErrMsg
844 mkErrorReport ctxt tcl_env (Report important relevant_bindings)
845 = do { context <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)
846 ; mkErrDocAt (RealSrcSpan (tcl_loc tcl_env))
847 (errDoc important [context] relevant_bindings)
848 }
849
850 type UserGiven = Implication
851
852 getUserGivens :: ReportErrCtxt -> [UserGiven]
853 -- One item for each enclosing implication
854 getUserGivens (CEC {cec_encl = implics}) = getUserGivensFromImplics implics
855
856 getUserGivensFromImplics :: [Implication] -> [UserGiven]
857 getUserGivensFromImplics implics
858 = reverse (filterOut (null . ic_given) implics)
859
860 {-
861 Note [Always warn with -fdefer-type-errors]
862 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
863 When -fdefer-type-errors is on we warn about *all* type errors, even
864 if cec_suppress is on. This can lead to a lot more warnings than you
865 would get errors without -fdefer-type-errors, but if we suppress any of
866 them you might get a runtime error that wasn't warned about at compile
867 time.
868
869 This is an easy design choice to change; just flip the order of the
870 first two equations for maybeReportError
871
872 To be consistent, we should also report multiple warnings from a single
873 location in mkGroupReporter, when -fdefer-type-errors is on. But that
874 is perhaps a bit *over*-consistent! Again, an easy choice to change.
875
876 With #10283, you can now opt out of deferred type error warnings.
877
878 Note [Deferred errors for coercion holes]
879 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
880 Suppose we need to defer a type error where the destination for the evidence
881 is a coercion hole. We can't just put the error in the hole, because we can't
882 make an erroneous coercion. (Remember that coercions are erased for runtime.)
883 Instead, we invent a new EvVar, bind it to an error and then make a coercion
884 from that EvVar, filling the hole with that coercion. Because coercions'
885 types are unlifted, the error is guaranteed to be hit before we get to the
886 coercion.
887
888 Note [Do not report derived but soluble errors]
889 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
890 The wc_simples include Derived constraints that have not been solved, but are
891 not insoluble (in that case they'd be in wc_insols). We do not want to report
892 these as errors:
893
894 * Superclass constraints. If we have an unsolved [W] Ord a, we'll also have
895 an unsolved [D] Eq a, and we do not want to report that; it's just noise.
896
897 * Functional dependencies. For givens, consider
898 class C a b | a -> b
899 data T a where
900 MkT :: C a d => [d] -> T a
901 f :: C a b => T a -> F Int
902 f (MkT xs) = length xs
903 Then we get a [D] b~d. But there *is* a legitimate call to
904 f, namely f (MkT [True]) :: T Bool, in which b=d. So we should
905 not reject the program.
906
907 For wanteds, something similar
908 data T a where
909 MkT :: C Int b => a -> b -> T a
910 g :: C Int c => c -> ()
911 f :: T a -> ()
912 f (MkT x y) = g x
913 Here we get [G] C Int b, [W] C Int a, hence [D] a~b.
914 But again f (MkT True True) is a legitimate call.
915
916 (We leave the Deriveds in wc_simple until reportErrors, so that we don't lose
917 derived superclasses between iterations of the solver.)
918
919 For functional dependencies, here is a real example,
920 stripped off from libraries/utf8-string/Codec/Binary/UTF8/Generic.hs
921
922 class C a b | a -> b
923 g :: C a b => a -> b -> ()
924 f :: C a b => a -> b -> ()
925 f xa xb =
926 let loop = g xa
927 in loop xb
928
929 We will first try to infer a type for loop, and we will succeed:
930 C a b' => b' -> ()
931 Subsequently, we will type check (loop xb) and all is good. But,
932 recall that we have to solve a final implication constraint:
933 C a b => (C a b' => .... cts from body of loop .... ))
934 And now we have a problem as we will generate an equality b ~ b' and fail to
935 solve it.
936
937
938 ************************************************************************
939 * *
940 Irreducible predicate errors
941 * *
942 ************************************************************************
943 -}
944
945 mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
946 mkIrredErr ctxt cts
947 = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1
948 ; let orig = ctOrigin ct1
949 msg = couldNotDeduce (getUserGivens ctxt) (map ctPred cts, orig)
950 ; mkErrorMsgFromCt ctxt ct1 $
951 important msg `mappend` relevant_bindings binds_msg }
952 where
953 (ct1:_) = cts
954
955 ----------------
956 mkHoleError :: ReportErrCtxt -> Ct -> TcM ErrMsg
957 mkHoleError _ctxt ct@(CHoleCan { cc_hole = ExprHole (OutOfScope occ rdr_env0) })
958 -- Out-of-scope variables, like 'a', where 'a' isn't bound; suggest possible
959 -- in-scope variables in the message, and note inaccessible exact matches
960 = do { dflags <- getDynFlags
961 ; imp_info <- getImports
962 ; let suggs_msg = unknownNameSuggestions dflags rdr_env0
963 (tcl_rdr lcl_env) imp_info rdr
964 ; rdr_env <- getGlobalRdrEnv
965 ; splice_locs <- getTopLevelSpliceLocs
966 ; let match_msgs = mk_match_msgs rdr_env splice_locs
967 ; mkErrDocAt (RealSrcSpan err_loc) $
968 errDoc [out_of_scope_msg] [] (match_msgs ++ [suggs_msg]) }
969
970 where
971 rdr = mkRdrUnqual occ
972 ct_loc = ctLoc ct
973 lcl_env = ctLocEnv ct_loc
974 err_loc = tcl_loc lcl_env
975 hole_ty = ctEvPred (ctEvidence ct)
976 boring_type = isTyVarTy hole_ty
977
978 out_of_scope_msg -- Print v :: ty only if the type has structure
979 | boring_type = hang herald 2 (ppr occ)
980 | otherwise = hang herald 2 (pp_with_type occ hole_ty)
981
982 herald | isDataOcc occ = text "Data constructor not in scope:"
983 | otherwise = text "Variable not in scope:"
984
985 -- Indicate if the out-of-scope variable exactly (and unambiguously) matches
986 -- a top-level binding in a later inter-splice group; see Note [OutOfScope
987 -- exact matches]
988 mk_match_msgs rdr_env splice_locs
989 = let gres = filter isLocalGRE (lookupGlobalRdrEnv rdr_env occ)
990 in case gres of
991 [gre]
992 | RealSrcSpan bind_loc <- greSrcSpan gre
993 -- Find splice between the unbound variable and the match; use
994 -- lookupLE, not lookupLT, since match could be in the splice
995 , Just th_loc <- Set.lookupLE bind_loc splice_locs
996 , err_loc < th_loc
997 -> [mk_bind_scope_msg bind_loc th_loc]
998 _ -> []
999
1000 mk_bind_scope_msg bind_loc th_loc
1001 | is_th_bind
1002 = hang (quotes (ppr occ) <+> parens (text "splice on" <+> th_rng))
1003 2 (text "is not in scope before line" <+> int th_start_ln)
1004 | otherwise
1005 = hang (quotes (ppr occ) <+> bind_rng <+> text "is not in scope")
1006 2 (text "before the splice on" <+> th_rng)
1007 where
1008 bind_rng = parens (text "line" <+> int bind_ln)
1009 th_rng
1010 | th_start_ln == th_end_ln = single
1011 | otherwise = multi
1012 single = text "line" <+> int th_start_ln
1013 multi = text "lines" <+> int th_start_ln <> text "-" <> int th_end_ln
1014 bind_ln = srcSpanStartLine bind_loc
1015 th_start_ln = srcSpanStartLine th_loc
1016 th_end_ln = srcSpanEndLine th_loc
1017 is_th_bind = th_loc `containsSpan` bind_loc
1018
1019 mkHoleError ctxt ct@(CHoleCan { cc_hole = hole })
1020 -- Explicit holes, like "_" or "_f"
1021 = do { (ctxt, binds_msg, ct) <- relevantBindings False ctxt ct
1022 -- The 'False' means "don't filter the bindings"; see Trac #8191
1023
1024 ; show_hole_constraints <- goptM Opt_ShowHoleConstraints
1025 ; let constraints_msg
1026 | isExprHoleCt ct, show_hole_constraints
1027 = givenConstraintsMsg ctxt
1028 | otherwise = empty
1029
1030 ; mkErrorMsgFromCt ctxt ct $
1031 important hole_msg `mappend`
1032 relevant_bindings (binds_msg $$ constraints_msg) }
1033
1034 where
1035 occ = holeOcc hole
1036 hole_ty = ctEvPred (ctEvidence ct)
1037 tyvars = tyCoVarsOfTypeList hole_ty
1038
1039 hole_msg = case hole of
1040 ExprHole {} -> vcat [ hang (text "Found hole:")
1041 2 (pp_with_type occ hole_ty)
1042 , tyvars_msg, expr_hole_hint ]
1043 TypeHole {} -> vcat [ hang (text "Found type wildcard" <+>
1044 quotes (ppr occ))
1045 2 (text "standing for" <+>
1046 quotes (pprType hole_ty))
1047 , tyvars_msg, type_hole_hint ]
1048
1049 tyvars_msg = ppUnless (null tyvars) $
1050 text "Where:" <+> vcat (map loc_msg tyvars)
1051
1052 type_hole_hint
1053 | HoleError <- cec_type_holes ctxt
1054 = text "To use the inferred type, enable PartialTypeSignatures"
1055 | otherwise
1056 = empty
1057
1058 expr_hole_hint -- Give hint for, say, f x = _x
1059 | lengthFS (occNameFS occ) > 1 -- Don't give this hint for plain "_"
1060 = text "Or perhaps" <+> quotes (ppr occ)
1061 <+> text "is mis-spelled, or not in scope"
1062 | otherwise
1063 = empty
1064
1065 loc_msg tv
1066 | isTyVar tv
1067 = case tcTyVarDetails tv of
1068 MetaTv {} -> quotes (ppr tv) <+> text "is an ambiguous type variable"
1069 _ -> extraTyVarInfo ctxt tv
1070 | otherwise
1071 = sdocWithDynFlags $ \dflags ->
1072 if gopt Opt_PrintExplicitCoercions dflags
1073 then quotes (ppr tv) <+> text "is a coercion variable"
1074 else empty
1075
1076 mkHoleError _ ct = pprPanic "mkHoleError" (ppr ct)
1077
1078
1079 -- See Note [Constraints include ...]
1080 givenConstraintsMsg :: ReportErrCtxt -> SDoc
1081 givenConstraintsMsg ctxt =
1082 let constraints :: [(Type, RealSrcSpan)]
1083 constraints =
1084 do { Implic{ ic_given = given, ic_env = env } <- cec_encl ctxt
1085 ; constraint <- given
1086 ; return (varType constraint, tcl_loc env) }
1087
1088 pprConstraint (constraint, loc) =
1089 ppr constraint <+> nest 2 (parens (text "from" <+> ppr loc))
1090
1091 in ppUnless (null constraints) $
1092 hang (text "Constraints include")
1093 2 (vcat $ map pprConstraint constraints)
1094
1095 pp_with_type :: OccName -> Type -> SDoc
1096 pp_with_type occ ty = hang (pprPrefixOcc occ) 2 (dcolon <+> pprType ty)
1097
1098 ----------------
1099 mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
1100 mkIPErr ctxt cts
1101 = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1
1102 ; let orig = ctOrigin ct1
1103 preds = map ctPred cts
1104 givens = getUserGivens ctxt
1105 msg | null givens
1106 = addArising orig $
1107 sep [ text "Unbound implicit parameter" <> plural cts
1108 , nest 2 (pprTheta preds) ]
1109 | otherwise
1110 = couldNotDeduce givens (preds, orig)
1111
1112 ; mkErrorMsgFromCt ctxt ct1 $
1113 important msg `mappend` relevant_bindings binds_msg }
1114 where
1115 (ct1:_) = cts
1116
1117 {-
1118 Note [Constraints include ...]
1119 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1120 'givenConstraintsMsg' returns the "Constraints include ..." message enabled by
1121 -fshow-hole-constraints. For example, the following hole:
1122
1123 foo :: (Eq a, Show a) => a -> String
1124 foo x = _
1125
1126 would generate the message:
1127
1128 Constraints include
1129 Eq a (from foo.hs:1:1-36)
1130 Show a (from foo.hs:1:1-36)
1131
1132 Constraints are displayed in order from innermost (closest to the hole) to
1133 outermost. There's currently no filtering or elimination of duplicates.
1134
1135
1136 Note [OutOfScope exact matches]
1137 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1138 When constructing an out-of-scope error message, we not only generate a list of
1139 possible in-scope alternatives but also search for an exact, unambiguous match
1140 in a later inter-splice group. If we find such a match, we report its presence
1141 (and indirectly, its scope) in the message. For example, if a module A contains
1142 the following declarations,
1143
1144 foo :: Int
1145 foo = x
1146
1147 $(return []) -- Empty top-level splice
1148
1149 x :: Int
1150 x = 23
1151
1152 we will issue an error similar to
1153
1154 A.hs:6:7: error:
1155 • Variable not in scope: x :: Int
1156 • ‘x’ (line 11) is not in scope before the splice on line 8
1157
1158 By providing information about the match, we hope to clarify why declaring a
1159 variable after a top-level splice but using it before the splice generates an
1160 out-of-scope error (a situation which is often confusing to Haskell newcomers).
1161
1162 Note that if we find multiple exact matches to the out-of-scope variable
1163 (hereafter referred to as x), we report nothing. Such matches can only be
1164 duplicate record fields, as the presence of any other duplicate top-level
1165 declarations would have already halted compilation. But if these record fields
1166 are declared in a later inter-splice group, then so too are their corresponding
1167 types. Thus, these types must not occur in the inter-splice group containing x
1168 (any unknown types would have already been reported), and so the matches to the
1169 record fields are most likely coincidental.
1170
1171 One oddity of the exact match portion of the error message is that we specify
1172 where the match to x is NOT in scope. Why not simply state where the match IS
1173 in scope? It most cases, this would be just as easy and perhaps a little
1174 clearer for the user. But now consider the following example:
1175
1176 {-# LANGUAGE TemplateHaskell #-}
1177
1178 module A where
1179
1180 import Language.Haskell.TH
1181 import Language.Haskell.TH.Syntax
1182
1183 foo = x
1184
1185 $(do -------------------------------------------------
1186 ds <- [d| ok1 = x
1187 |]
1188 addTopDecls ds
1189 return [])
1190
1191 bar = $(do
1192 ds <- [d| x = 23
1193 ok2 = x
1194 |]
1195 addTopDecls ds
1196 litE $ stringL "hello")
1197
1198 $(return []) -----------------------------------------
1199
1200 ok3 = x
1201
1202 Here, x is out-of-scope in the declaration of foo, and so we report
1203
1204 A.hs:8:7: error:
1205 • Variable not in scope: x
1206 • ‘x’ (line 16) is not in scope before the splice on lines 10-14
1207
1208 If we instead reported where x IS in scope, we would have to state that it is in
1209 scope after the second top-level splice as well as among all the top-level
1210 declarations added by both calls to addTopDecls. But doing so would not only
1211 add complexity to the code but also overwhelm the user with unneeded
1212 information.
1213
1214 The logic which determines where x is not in scope is straightforward: it simply
1215 finds the last top-level splice which occurs after x but before (or at) the
1216 match to x (assuming such a splice exists). In most cases, the check that the
1217 splice occurs after x acts only as a sanity check. For example, when the match
1218 to x is a non-TH top-level declaration and a splice S occurs before the match,
1219 then x must precede S; otherwise, it would be in scope. But when dealing with
1220 addTopDecls, this check serves a practical purpose. Consider the following
1221 declarations:
1222
1223 $(do
1224 ds <- [d| ok = x
1225 x = 23
1226 |]
1227 addTopDecls ds
1228 return [])
1229
1230 foo = x
1231
1232 In this case, x is not in scope in the declaration for foo. Since x occurs
1233 AFTER the splice containing the match, the logic does not find any splices after
1234 x but before or at its match, and so we report nothing about x's scope. If we
1235 had not checked whether x occurs before the splice, we would have instead
1236 reported that x is not in scope before the splice. While correct, such an error
1237 message is more likely to confuse than to enlighten.
1238 -}
1239
1240 {-
1241 ************************************************************************
1242 * *
1243 Equality errors
1244 * *
1245 ************************************************************************
1246
1247 Note [Inaccessible code]
1248 ~~~~~~~~~~~~~~~~~~~~~~~~
1249 Consider
1250 data T a where
1251 T1 :: T a
1252 T2 :: T Bool
1253
1254 f :: (a ~ Int) => T a -> Int
1255 f T1 = 3
1256 f T2 = 4 -- Unreachable code
1257
1258 Here the second equation is unreachable. The original constraint
1259 (a~Int) from the signature gets rewritten by the pattern-match to
1260 (Bool~Int), so the danger is that we report the error as coming from
1261 the *signature* (Trac #7293). So, for Given errors we replace the
1262 env (and hence src-loc) on its CtLoc with that from the immediately
1263 enclosing implication.
1264
1265 Note [Error messages for untouchables]
1266 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1267 Consider (Trac #9109)
1268 data G a where { GBool :: G Bool }
1269 foo x = case x of GBool -> True
1270
1271 Here we can't solve (t ~ Bool), where t is the untouchable result
1272 meta-var 't', because of the (a ~ Bool) from the pattern match.
1273 So we infer the type
1274 f :: forall a t. G a -> t
1275 making the meta-var 't' into a skolem. So when we come to report
1276 the unsolved (t ~ Bool), t won't look like an untouchable meta-var
1277 any more. So we don't assert that it is.
1278 -}
1279
1280 mkEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
1281 -- Don't have multiple equality errors from the same location
1282 -- E.g. (Int,Bool) ~ (Bool,Int) one error will do!
1283 mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct
1284 mkEqErr _ [] = panic "mkEqErr"
1285
1286 mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg
1287 mkEqErr1 ctxt ct -- Wanted or derived;
1288 -- givens handled in mkGivenErrorReporter
1289 = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct
1290 ; rdr_env <- getGlobalRdrEnv
1291 ; fam_envs <- tcGetFamInstEnvs
1292 ; exp_syns <- goptM Opt_PrintExpandedSynonyms
1293 ; let (keep_going, is_oriented, wanted_msg)
1294 = mk_wanted_extra (ctLoc ct) exp_syns
1295 coercible_msg = case ctEqRel ct of
1296 NomEq -> empty
1297 ReprEq -> mkCoercibleExplanation rdr_env fam_envs ty1 ty2
1298 ; dflags <- getDynFlags
1299 ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctOrigin ct))
1300 ; let report = mconcat [important wanted_msg, important coercible_msg,
1301 relevant_bindings binds_msg]
1302 ; if keep_going
1303 then mkEqErr_help dflags ctxt report ct is_oriented ty1 ty2
1304 else mkErrorMsgFromCt ctxt ct report }
1305 where
1306 (ty1, ty2) = getEqPredTys (ctPred ct)
1307
1308 -- If the types in the error message are the same as the types
1309 -- we are unifying, don't add the extra expected/actual message
1310 mk_wanted_extra :: CtLoc -> Bool -> (Bool, Maybe SwapFlag, SDoc)
1311 mk_wanted_extra loc expandSyns
1312 = case ctLocOrigin loc of
1313 orig@TypeEqOrigin {} -> mkExpectedActualMsg ty1 ty2 orig
1314 t_or_k expandSyns
1315 where
1316 t_or_k = ctLocTypeOrKind_maybe loc
1317
1318 KindEqOrigin cty1 mb_cty2 sub_o sub_t_or_k
1319 -> (True, Nothing, msg1 $$ msg2)
1320 where
1321 sub_what = case sub_t_or_k of Just KindLevel -> text "kinds"
1322 _ -> text "types"
1323 msg1 = sdocWithDynFlags $ \dflags ->
1324 case mb_cty2 of
1325 Just cty2
1326 | gopt Opt_PrintExplicitCoercions dflags
1327 || not (cty1 `pickyEqType` cty2)
1328 -> hang (text "When matching" <+> sub_what)
1329 2 (vcat [ ppr cty1 <+> dcolon <+>
1330 ppr (typeKind cty1)
1331 , ppr cty2 <+> dcolon <+>
1332 ppr (typeKind cty2) ])
1333 _ -> text "When matching the kind of" <+> quotes (ppr cty1)
1334 msg2 = case sub_o of
1335 TypeEqOrigin {}
1336 | Just cty2 <- mb_cty2 ->
1337 thdOf3 (mkExpectedActualMsg cty1 cty2 sub_o sub_t_or_k
1338 expandSyns)
1339 _ -> empty
1340 _ -> (True, Nothing, empty)
1341
1342 -- | This function tries to reconstruct why a "Coercible ty1 ty2" constraint
1343 -- is left over.
1344 mkCoercibleExplanation :: GlobalRdrEnv -> FamInstEnvs
1345 -> TcType -> TcType -> SDoc
1346 mkCoercibleExplanation rdr_env fam_envs ty1 ty2
1347 | Just (tc, tys) <- tcSplitTyConApp_maybe ty1
1348 , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys
1349 , Just msg <- coercible_msg_for_tycon rep_tc
1350 = msg
1351 | Just (tc, tys) <- splitTyConApp_maybe ty2
1352 , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys
1353 , Just msg <- coercible_msg_for_tycon rep_tc
1354 = msg
1355 | Just (s1, _) <- tcSplitAppTy_maybe ty1
1356 , Just (s2, _) <- tcSplitAppTy_maybe ty2
1357 , s1 `eqType` s2
1358 , has_unknown_roles s1
1359 = hang (text "NB: We cannot know what roles the parameters to" <+>
1360 quotes (ppr s1) <+> text "have;")
1361 2 (text "we must assume that the role is nominal")
1362 | otherwise
1363 = empty
1364 where
1365 coercible_msg_for_tycon tc
1366 | isAbstractTyCon tc
1367 = Just $ hsep [ text "NB: The type constructor"
1368 , quotes (pprSourceTyCon tc)
1369 , text "is abstract" ]
1370 | isNewTyCon tc
1371 , [data_con] <- tyConDataCons tc
1372 , let dc_name = dataConName data_con
1373 , isNothing (lookupGRE_Name rdr_env dc_name)
1374 = Just $ hang (text "The data constructor" <+> quotes (ppr dc_name))
1375 2 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc)
1376 , text "is not in scope" ])
1377 | otherwise = Nothing
1378
1379 has_unknown_roles ty
1380 | Just (tc, tys) <- tcSplitTyConApp_maybe ty
1381 = length tys >= tyConArity tc -- oversaturated tycon
1382 | Just (s, _) <- tcSplitAppTy_maybe ty
1383 = has_unknown_roles s
1384 | isTyVarTy ty
1385 = True
1386 | otherwise
1387 = False
1388
1389 {-
1390 -- | Make a listing of role signatures for all the parameterised tycons
1391 -- used in the provided types
1392
1393
1394 -- SLPJ Jun 15: I could not convince myself that these hints were really
1395 -- useful. Maybe they are, but I think we need more work to make them
1396 -- actually helpful.
1397 mkRoleSigs :: Type -> Type -> SDoc
1398 mkRoleSigs ty1 ty2
1399 = ppUnless (null role_sigs) $
1400 hang (text "Relevant role signatures:")
1401 2 (vcat role_sigs)
1402 where
1403 tcs = nameEnvElts $ tyConsOfType ty1 `plusNameEnv` tyConsOfType ty2
1404 role_sigs = mapMaybe ppr_role_sig tcs
1405
1406 ppr_role_sig tc
1407 | null roles -- if there are no parameters, don't bother printing
1408 = Nothing
1409 | isBuiltInSyntax (tyConName tc) -- don't print roles for (->), etc.
1410 = Nothing
1411 | otherwise
1412 = Just $ hsep $ [text "type role", ppr tc] ++ map ppr roles
1413 where
1414 roles = tyConRoles tc
1415 -}
1416
1417 mkEqErr_help :: DynFlags -> ReportErrCtxt -> Report
1418 -> Ct
1419 -> Maybe SwapFlag -- Nothing <=> not sure
1420 -> TcType -> TcType -> TcM ErrMsg
1421 mkEqErr_help dflags ctxt report ct oriented ty1 ty2
1422 | Just tv1 <- tcGetTyVar_maybe ty1 = mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2
1423 | Just tv2 <- tcGetTyVar_maybe ty2 = mkTyVarEqErr dflags ctxt report ct swapped tv2 ty1
1424 | otherwise = reportEqErr ctxt report ct oriented ty1 ty2
1425 where
1426 swapped = fmap flipSwap oriented
1427
1428 reportEqErr :: ReportErrCtxt -> Report
1429 -> Ct
1430 -> Maybe SwapFlag -- Nothing <=> not sure
1431 -> TcType -> TcType -> TcM ErrMsg
1432 reportEqErr ctxt report ct oriented ty1 ty2
1433 = mkErrorMsgFromCt ctxt ct (mconcat [misMatch, report, eqInfo])
1434 where misMatch = important $ misMatchOrCND ctxt ct oriented ty1 ty2
1435 eqInfo = important $ mkEqInfoMsg ct ty1 ty2
1436
1437 mkTyVarEqErr :: DynFlags -> ReportErrCtxt -> Report -> Ct
1438 -> Maybe SwapFlag -> TcTyVar -> TcType -> TcM ErrMsg
1439 -- tv1 and ty2 are already tidied
1440 mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2
1441 | isUserSkolem ctxt tv1 -- ty2 won't be a meta-tyvar, or else the thing would
1442 -- be oriented the other way round;
1443 -- see TcCanonical.canEqTyVarTyVar
1444 || isSigTyVar tv1 && not (isTyVarTy ty2)
1445 || ctEqRel ct == ReprEq && not (isTyVarUnderDatatype tv1 ty2)
1446 -- the cases below don't really apply to ReprEq (except occurs check)
1447 = mkErrorMsgFromCt ctxt ct $ mconcat
1448 [ important $ misMatchOrCND ctxt ct oriented ty1 ty2
1449 , important $ extraTyVarEqInfo ctxt tv1 ty2
1450 , report
1451 ]
1452
1453 -- So tv is a meta tyvar (or started that way before we
1454 -- generalised it). So presumably it is an *untouchable*
1455 -- meta tyvar or a SigTv, else it'd have been unified
1456 | OC_Occurs <- occ_check_expand
1457 , ctEqRel ct == NomEq || isTyVarUnderDatatype tv1 ty2
1458 -- See Note [Occurs check error] in TcCanonical
1459 = do { let occCheckMsg = important $ addArising (ctOrigin ct) $
1460 hang (text "Occurs check: cannot construct the infinite" <+> what <> colon)
1461 2 (sep [ppr ty1, char '~', ppr ty2])
1462 extra2 = important $ mkEqInfoMsg ct ty1 ty2
1463
1464 interesting_tyvars
1465 = filter (not . noFreeVarsOfType . tyVarKind) $
1466 filter isTyVar $
1467 fvVarList $
1468 tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2
1469 extra3 = relevant_bindings $
1470 ppWhen (not (null interesting_tyvars)) $
1471 hang (text "Type variable kinds:") 2 $
1472 vcat (map (tyvar_binding . tidyTyVarOcc (cec_tidy ctxt))
1473 interesting_tyvars)
1474
1475 tyvar_binding tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv)
1476 ; mkErrorMsgFromCt ctxt ct $ mconcat [occCheckMsg, extra2, extra3, report] }
1477
1478 | OC_Bad <- occ_check_expand
1479 = do { let msg = vcat [ text "Cannot instantiate unification variable"
1480 <+> quotes (ppr tv1)
1481 , hang (text "with a" <+> what <+> text "involving foralls:") 2 (ppr ty2)
1482 , nest 2 (text "GHC doesn't yet support impredicative polymorphism") ]
1483 -- Unlike the other reports, this discards the old 'report_important'
1484 -- instead of augmenting it. This is because the details are not likely
1485 -- to be helpful since this is just an unimplemented feature.
1486 ; mkErrorMsgFromCt ctxt ct $ report { report_important = [msg] } }
1487
1488 -- If the immediately-enclosing implication has 'tv' a skolem, and
1489 -- we know by now its an InferSkol kind of skolem, then presumably
1490 -- it started life as a SigTv, else it'd have been unified, given
1491 -- that there's no occurs-check or forall problem
1492 | (implic:_) <- cec_encl ctxt
1493 , Implic { ic_skols = skols } <- implic
1494 , tv1 `elem` skols
1495 = mkErrorMsgFromCt ctxt ct $ mconcat
1496 [ important $ misMatchMsg ct oriented ty1 ty2
1497 , important $ extraTyVarEqInfo ctxt tv1 ty2
1498 , report
1499 ]
1500
1501 -- Check for skolem escape
1502 | (implic:_) <- cec_encl ctxt -- Get the innermost context
1503 , Implic { ic_env = env, ic_skols = skols, ic_info = skol_info } <- implic
1504 , let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols
1505 , not (null esc_skols)
1506 = do { let msg = important $ misMatchMsg ct oriented ty1 ty2
1507 esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols
1508 <+> pprQuotedList esc_skols
1509 , text "would escape" <+>
1510 if isSingleton esc_skols then text "its scope"
1511 else text "their scope" ]
1512 tv_extra = important $
1513 vcat [ nest 2 $ esc_doc
1514 , sep [ (if isSingleton esc_skols
1515 then text "This (rigid, skolem)" <+>
1516 what <+> text "variable is"
1517 else text "These (rigid, skolem)" <+>
1518 what <+> text "variables are")
1519 <+> text "bound by"
1520 , nest 2 $ ppr skol_info
1521 , nest 2 $ text "at" <+> ppr (tcl_loc env) ] ]
1522 ; mkErrorMsgFromCt ctxt ct (mconcat [msg, tv_extra, report]) }
1523
1524 -- Nastiest case: attempt to unify an untouchable variable
1525 -- See Note [Error messages for untouchables]
1526 | (implic:_) <- cec_encl ctxt -- Get the innermost context
1527 , Implic { ic_env = env, ic_given = given
1528 , ic_tclvl = lvl, ic_info = skol_info } <- implic
1529 = ASSERT2( not (isTouchableMetaTyVar lvl tv1)
1530 , ppr tv1 ) -- See Note [Error messages for untouchables]
1531 do { let msg = important $ misMatchMsg ct oriented ty1 ty2
1532 tclvl_extra = important $
1533 nest 2 $
1534 sep [ quotes (ppr tv1) <+> text "is untouchable"
1535 , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given
1536 , nest 2 $ text "bound by" <+> ppr skol_info
1537 , nest 2 $ text "at" <+> ppr (tcl_loc env) ]
1538 tv_extra = important $ extraTyVarEqInfo ctxt tv1 ty2
1539 add_sig = important $ suggestAddSig ctxt ty1 ty2
1540 ; mkErrorMsgFromCt ctxt ct $ mconcat
1541 [msg, tclvl_extra, tv_extra, add_sig, report] }
1542
1543 | otherwise
1544 = reportEqErr ctxt report ct oriented (mkTyVarTy tv1) ty2
1545 -- This *can* happen (Trac #6123, and test T2627b)
1546 -- Consider an ambiguous top-level constraint (a ~ F a)
1547 -- Not an occurs check, because F is a type function.
1548 where
1549 ty1 = mkTyVarTy tv1
1550 occ_check_expand = occCheckForErrors dflags tv1 ty2
1551
1552 what = case ctLocTypeOrKind_maybe (ctLoc ct) of
1553 Just KindLevel -> text "kind"
1554 _ -> text "type"
1555
1556 mkEqInfoMsg :: Ct -> TcType -> TcType -> SDoc
1557 -- Report (a) ambiguity if either side is a type function application
1558 -- e.g. F a0 ~ Int
1559 -- (b) warning about injectivity if both sides are the same
1560 -- type function application F a ~ F b
1561 -- See Note [Non-injective type functions]
1562 -- (c) warning about -fprint-explicit-kinds if that might be helpful
1563 mkEqInfoMsg ct ty1 ty2
1564 = tyfun_msg $$ ambig_msg $$ invis_msg
1565 where
1566 mb_fun1 = isTyFun_maybe ty1
1567 mb_fun2 = isTyFun_maybe ty2
1568
1569 ambig_msg | isJust mb_fun1 || isJust mb_fun2
1570 = snd (mkAmbigMsg False ct)
1571 | otherwise = empty
1572
1573 -- better to check the exp/act types in the CtOrigin than the actual
1574 -- mismatched types for suggestion about -fprint-explicit-kinds
1575 (act_ty, exp_ty) = case ctOrigin ct of
1576 TypeEqOrigin { uo_actual = act
1577 , uo_expected = exp } -> (act, exp)
1578 _ -> (ty1, ty2)
1579
1580 invis_msg | Just vis <- tcEqTypeVis act_ty exp_ty
1581 , not vis
1582 = ppSuggestExplicitKinds
1583 | otherwise
1584 = empty
1585
1586 tyfun_msg | Just tc1 <- mb_fun1
1587 , Just tc2 <- mb_fun2
1588 , tc1 == tc2
1589 = text "NB:" <+> quotes (ppr tc1)
1590 <+> text "is a type function, and may not be injective"
1591 | otherwise = empty
1592
1593 isUserSkolem :: ReportErrCtxt -> TcTyVar -> Bool
1594 -- See Note [Reporting occurs-check errors]
1595 isUserSkolem ctxt tv
1596 = isSkolemTyVar tv && any is_user_skol_tv (cec_encl ctxt)
1597 where
1598 is_user_skol_tv (Implic { ic_skols = sks, ic_info = skol_info })
1599 = tv `elem` sks && is_user_skol_info skol_info
1600
1601 is_user_skol_info (InferSkol {}) = False
1602 is_user_skol_info _ = True
1603
1604 misMatchOrCND :: ReportErrCtxt -> Ct
1605 -> Maybe SwapFlag -> TcType -> TcType -> SDoc
1606 -- If oriented then ty1 is actual, ty2 is expected
1607 misMatchOrCND ctxt ct oriented ty1 ty2
1608 | null givens ||
1609 (isRigidTy ty1 && isRigidTy ty2) ||
1610 isGivenCt ct
1611 -- If the equality is unconditionally insoluble
1612 -- or there is no context, don't report the context
1613 = misMatchMsg ct oriented ty1 ty2
1614 | otherwise
1615 = couldNotDeduce givens ([eq_pred], orig)
1616 where
1617 ev = ctEvidence ct
1618 eq_pred = ctEvPred ev
1619 orig = ctEvOrigin ev
1620 givens = [ given | given <- getUserGivens ctxt, not (ic_no_eqs given)]
1621 -- Keep only UserGivens that have some equalities
1622
1623 couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc
1624 couldNotDeduce givens (wanteds, orig)
1625 = vcat [ addArising orig (text "Could not deduce:" <+> pprTheta wanteds)
1626 , vcat (pp_givens givens)]
1627
1628 pp_givens :: [UserGiven] -> [SDoc]
1629 pp_givens givens
1630 = case givens of
1631 [] -> []
1632 (g:gs) -> ppr_given (text "from the context:") g
1633 : map (ppr_given (text "or from:")) gs
1634 where
1635 ppr_given herald (Implic { ic_given = gs, ic_info = skol_info
1636 , ic_env = env })
1637 = hang (herald <+> pprEvVarTheta gs)
1638 2 (sep [ text "bound by" <+> ppr skol_info
1639 , text "at" <+> ppr (tcl_loc env) ])
1640
1641 extraTyVarEqInfo :: ReportErrCtxt -> TcTyVar -> TcType -> SDoc
1642 -- Add on extra info about skolem constants
1643 -- NB: The types themselves are already tidied
1644 extraTyVarEqInfo ctxt tv1 ty2
1645 = extraTyVarInfo ctxt tv1 $$ ty_extra ty2
1646 where
1647 ty_extra ty = case tcGetTyVar_maybe ty of
1648 Just tv -> extraTyVarInfo ctxt tv
1649 Nothing -> empty
1650
1651 extraTyVarInfo :: ReportErrCtxt -> TcTyVar -> SDoc
1652 extraTyVarInfo ctxt tv
1653 = ASSERT2( isTyVar tv, ppr tv )
1654 case tcTyVarDetails tv of
1655 SkolemTv {} -> pprSkol implics tv
1656 FlatSkol {} -> pp_tv <+> text "is a flattening type variable"
1657 RuntimeUnk {} -> pp_tv <+> text "is an interactive-debugger skolem"
1658 MetaTv {} -> empty
1659 where
1660 implics = cec_encl ctxt
1661 pp_tv = quotes (ppr tv)
1662
1663 suggestAddSig :: ReportErrCtxt -> TcType -> TcType -> SDoc
1664 -- See Note [Suggest adding a type signature]
1665 suggestAddSig ctxt ty1 ty2
1666 | null inferred_bndrs
1667 = empty
1668 | [bndr] <- inferred_bndrs
1669 = text "Possible fix: add a type signature for" <+> quotes (ppr bndr)
1670 | otherwise
1671 = text "Possible fix: add type signatures for some or all of" <+> (ppr inferred_bndrs)
1672 where
1673 inferred_bndrs = nub (get_inf ty1 ++ get_inf ty2)
1674 get_inf ty | Just tv <- tcGetTyVar_maybe ty
1675 , isSkolemTyVar tv
1676 , InferSkol prs <- ic_info (getSkolemInfo (cec_encl ctxt) tv)
1677 = map fst prs
1678 | otherwise
1679 = []
1680
1681 --------------------
1682 misMatchMsg :: Ct -> Maybe SwapFlag -> TcType -> TcType -> SDoc
1683 -- Types are already tidy
1684 -- If oriented then ty1 is actual, ty2 is expected
1685 misMatchMsg ct oriented ty1 ty2
1686 | Just NotSwapped <- oriented
1687 = misMatchMsg ct (Just IsSwapped) ty2 ty1
1688
1689 -- These next two cases are when we're about to report, e.g., that
1690 -- 'LiftedRep doesn't match 'VoidRep. Much better just to say
1691 -- lifted vs. unlifted
1692 | Just (tc1, []) <- splitTyConApp_maybe ty1
1693 , tc1 `hasKey` liftedRepDataConKey
1694 = lifted_vs_unlifted
1695
1696 | Just (tc2, []) <- splitTyConApp_maybe ty2
1697 , tc2 `hasKey` liftedRepDataConKey
1698 = lifted_vs_unlifted
1699
1700 | otherwise -- So now we have Nothing or (Just IsSwapped)
1701 -- For some reason we treat Nothing like IsSwapped
1702 = addArising orig $
1703 sep [ text herald1 <+> quotes (ppr ty1)
1704 , nest padding $
1705 text herald2 <+> quotes (ppr ty2)
1706 , sameOccExtra ty2 ty1 ]
1707 where
1708 herald1 = conc [ "Couldn't match"
1709 , if is_repr then "representation of" else ""
1710 , if is_oriented then "expected" else ""
1711 , what ]
1712 herald2 = conc [ "with"
1713 , if is_repr then "that of" else ""
1714 , if is_oriented then ("actual " ++ what) else "" ]
1715 padding = length herald1 - length herald2
1716
1717 is_repr = case ctEqRel ct of { ReprEq -> True; NomEq -> False }
1718 is_oriented = isJust oriented
1719
1720 orig = ctOrigin ct
1721 what = case ctLocTypeOrKind_maybe (ctLoc ct) of
1722 Just KindLevel -> "kind"
1723 _ -> "type"
1724
1725 conc :: [String] -> String
1726 conc = foldr1 add_space
1727
1728 add_space :: String -> String -> String
1729 add_space s1 s2 | null s1 = s2
1730 | null s2 = s1
1731 | otherwise = s1 ++ (' ' : s2)
1732
1733 lifted_vs_unlifted
1734 = addArising orig $
1735 text "Couldn't match a lifted type with an unlifted type"
1736
1737 mkExpectedActualMsg :: Type -> Type -> CtOrigin -> Maybe TypeOrKind -> Bool
1738 -> (Bool, Maybe SwapFlag, SDoc)
1739 -- NotSwapped means (actual, expected), IsSwapped is the reverse
1740 -- First return val is whether or not to print a herald above this msg
1741 mkExpectedActualMsg ty1 ty2 (TypeEqOrigin { uo_actual = act
1742 , uo_expected = exp
1743 , uo_thing = maybe_thing })
1744 m_level printExpanded
1745 | KindLevel <- level, occurs_check_error = (True, Nothing, empty)
1746 | isUnliftedTypeKind act, isLiftedTypeKind exp = (False, Nothing, msg2)
1747 | isLiftedTypeKind act, isUnliftedTypeKind exp = (False, Nothing, msg3)
1748 | isLiftedTypeKind exp && not (isConstraintKind exp)
1749 = (False, Nothing, msg4)
1750 | Just msg <- num_args_msg = (False, Nothing, msg $$ msg1)
1751 | KindLevel <- level, Just th <- maybe_thing = (False, Nothing, msg5 th)
1752 | act `pickyEqType` ty1, exp `pickyEqType` ty2 = (True, Just NotSwapped, empty)
1753 | exp `pickyEqType` ty1, act `pickyEqType` ty2 = (True, Just IsSwapped, empty)
1754 | otherwise = (True, Nothing, msg1)
1755 where
1756 level = m_level `orElse` TypeLevel
1757
1758 occurs_check_error
1759 | Just act_tv <- tcGetTyVar_maybe act
1760 , act_tv `elemVarSet` tyCoVarsOfType exp
1761 = True
1762 | Just exp_tv <- tcGetTyVar_maybe exp
1763 , exp_tv `elemVarSet` tyCoVarsOfType act
1764 = True
1765 | otherwise
1766 = False
1767
1768 sort = case level of
1769 TypeLevel -> text "type"
1770 KindLevel -> text "kind"
1771
1772 msg1 = case level of
1773 KindLevel
1774 | Just th <- maybe_thing
1775 -> msg5 th
1776
1777 _ | not (act `pickyEqType` exp)
1778 -> vcat [ text "Expected" <+> sort <> colon <+> ppr exp
1779 , text " Actual" <+> sort <> colon <+> ppr act
1780 , if printExpanded then expandedTys else empty ]
1781
1782 | otherwise
1783 -> empty
1784
1785 thing_msg = case maybe_thing of
1786 Just thing -> \_ -> quotes (ppr thing) <+> text "is"
1787 Nothing -> \vowel -> text "got a" <>
1788 if vowel then char 'n' else empty
1789 msg2 = sep [ text "Expecting a lifted type, but"
1790 , thing_msg True, text "unlifted" ]
1791 msg3 = sep [ text "Expecting an unlifted type, but"
1792 , thing_msg False, text "lifted" ]
1793 msg4 = maybe_num_args_msg $$
1794 sep [ text "Expected a type, but"
1795 , maybe (text "found something with kind")
1796 (\thing -> quotes (ppr thing) <+> text "has kind")
1797 maybe_thing
1798 , quotes (ppr act) ]
1799
1800 msg5 th = hang (text "Expected" <+> kind_desc <> comma)
1801 2 (text "but" <+> quotes (ppr th) <+> text "has kind" <+>
1802 quotes (ppr act))
1803 where
1804 kind_desc | isConstraintKind exp = text "a constraint"
1805 | otherwise = text "kind" <+> quotes (ppr exp)
1806
1807 num_args_msg = case level of
1808 TypeLevel -> Nothing
1809 KindLevel
1810 -> let n_act = count_args act
1811 n_exp = count_args exp in
1812 case n_act - n_exp of
1813 n | n /= 0
1814 , Just thing <- maybe_thing
1815 , case errorThingNumArgs_maybe thing of
1816 Nothing -> n > 0
1817 Just num_act_args -> num_act_args >= -n
1818 -- don't report to strip off args that aren't there
1819 -> Just $ text "Expecting" <+> speakN (abs n) <+>
1820 more_or_fewer <+> quotes (ppr thing)
1821 where
1822 more_or_fewer
1823 | n < 0 = text "fewer arguments to"
1824 | n == 1 = text "more argument to"
1825 | otherwise = text "more arguments to" -- n > 1
1826 _ -> Nothing
1827
1828 maybe_num_args_msg = case num_args_msg of
1829 Nothing -> empty
1830 Just m -> m
1831
1832 count_args ty = count isVisibleBinder $ fst $ splitPiTys ty
1833
1834 expandedTys =
1835 ppUnless (expTy1 `pickyEqType` exp && expTy2 `pickyEqType` act) $ vcat
1836 [ text "Type synonyms expanded:"
1837 , text "Expected type:" <+> ppr expTy1
1838 , text " Actual type:" <+> ppr expTy2
1839 ]
1840
1841 (expTy1, expTy2) = expandSynonymsToMatch exp act
1842
1843 mkExpectedActualMsg _ _ _ _ _ = panic "mkExpectedAcutalMsg"
1844
1845 {-
1846 Note [Expanding type synonyms to make types similar]
1847 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1848
1849 In type error messages, if -fprint-expanded-types is used, we want to expand
1850 type synonyms to make expected and found types as similar as possible, but we
1851 shouldn't expand types too much to make type messages even more verbose and
1852 harder to understand. The whole point here is to make the difference in expected
1853 and found types clearer.
1854
1855 `expandSynonymsToMatch` does this, it takes two types, and expands type synonyms
1856 only as much as necessary. Given two types t1 and t2:
1857
1858 * If they're already same, it just returns the types.
1859
1860 * If they're in form `C1 t1_1 .. t1_n` and `C2 t2_1 .. t2_m` (C1 and C2 are
1861 type constructors), it expands C1 and C2 if they're different type synonyms.
1862 Then it recursively does the same thing on expanded types. If C1 and C2 are
1863 same, then it applies the same procedure to arguments of C1 and arguments of
1864 C2 to make them as similar as possible.
1865
1866 Most important thing here is to keep number of synonym expansions at
1867 minimum. For example, if t1 is `T (T3, T5, Int)` and t2 is `T (T5, T3,
1868 Bool)` where T5 = T4, T4 = T3, ..., T1 = X, it returns `T (T3, T3, Int)` and
1869 `T (T3, T3, Bool)`.
1870
1871 * Otherwise types don't have same shapes and so the difference is clearly
1872 visible. It doesn't do any expansions and show these types.
1873
1874 Note that we only expand top-layer type synonyms. Only when top-layer
1875 constructors are the same we start expanding inner type synonyms.
1876
1877 Suppose top-layer type synonyms of t1 and t2 can expand N and M times,
1878 respectively. If their type-synonym-expanded forms will meet at some point (i.e.
1879 will have same shapes according to `sameShapes` function), it's possible to find
1880 where they meet in O(N+M) top-layer type synonym expansions and O(min(N,M))
1881 comparisons. We first collect all the top-layer expansions of t1 and t2 in two
1882 lists, then drop the prefix of the longer list so that they have same lengths.
1883 Then we search through both lists in parallel, and return the first pair of
1884 types that have same shapes. Inner types of these two types with same shapes
1885 are then expanded using the same algorithm.
1886
1887 In case they don't meet, we return the last pair of types in the lists, which
1888 has top-layer type synonyms completely expanded. (in this case the inner types
1889 are not expanded at all, as the current form already shows the type error)
1890 -}
1891
1892 -- | Expand type synonyms in given types only enough to make them as similar as
1893 -- possible. Returned types are the same in terms of used type synonyms.
1894 --
1895 -- To expand all synonyms, see 'Type.expandTypeSynonyms'.
1896 --
1897 -- See `ExpandSynsFail` tests in tests testsuite/tests/typecheck/should_fail for
1898 -- some examples of how this should work.
1899 expandSynonymsToMatch :: Type -> Type -> (Type, Type)
1900 expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret)
1901 where
1902 (ty1_ret, ty2_ret) = go ty1 ty2
1903
1904 -- | Returns (type synonym expanded version of first type,
1905 -- type synonym expanded version of second type)
1906 go :: Type -> Type -> (Type, Type)
1907 go t1 t2
1908 | t1 `pickyEqType` t2 =
1909 -- Types are same, nothing to do
1910 (t1, t2)
1911
1912 go (TyConApp tc1 tys1) (TyConApp tc2 tys2)
1913 | tc1 == tc2 =
1914 -- Type constructors are same. They may be synonyms, but we don't
1915 -- expand further.
1916 let (tys1', tys2') =
1917 unzip (zipWith (\ty1 ty2 -> go ty1 ty2) tys1 tys2)
1918 in (TyConApp tc1 tys1', TyConApp tc2 tys2')
1919
1920 go (AppTy t1_1 t1_2) (AppTy t2_1 t2_2) =
1921 let (t1_1', t2_1') = go t1_1 t2_1
1922 (t1_2', t2_2') = go t1_2 t2_2
1923 in (mkAppTy t1_1' t1_2', mkAppTy t2_1' t2_2')
1924
1925 go (FunTy t1_1 t1_2) (FunTy t2_1 t2_2) =
1926 let (t1_1', t2_1') = go t1_1 t2_1
1927 (t1_2', t2_2') = go t1_2 t2_2
1928 in (mkFunTy t1_1' t1_2', mkFunTy t2_1' t2_2')
1929
1930 go (ForAllTy b1 t1) (ForAllTy b2 t2) =
1931 -- NOTE: We may have a bug here, but we just can't reproduce it easily.
1932 -- See D1016 comments for details and our attempts at producing a test
1933 -- case. Short version: We probably need RnEnv2 to really get this right.
1934 let (t1', t2') = go t1 t2
1935 in (ForAllTy b1 t1', ForAllTy b2 t2')
1936
1937 go (CastTy ty1 _) ty2 = go ty1 ty2
1938 go ty1 (CastTy ty2 _) = go ty1 ty2
1939
1940 go t1 t2 =
1941 -- See Note [Expanding type synonyms to make types similar] for how this
1942 -- works
1943 let
1944 t1_exp_tys = t1 : tyExpansions t1
1945 t2_exp_tys = t2 : tyExpansions t2
1946 t1_exps = length t1_exp_tys
1947 t2_exps = length t2_exp_tys
1948 dif = abs (t1_exps - t2_exps)
1949 in
1950 followExpansions $
1951 zipEqual "expandSynonymsToMatch.go"
1952 (if t1_exps > t2_exps then drop dif t1_exp_tys else t1_exp_tys)
1953 (if t2_exps > t1_exps then drop dif t2_exp_tys else t2_exp_tys)
1954
1955 -- | Expand the top layer type synonyms repeatedly, collect expansions in a
1956 -- list. The list does not include the original type.
1957 --
1958 -- Example, if you have:
1959 --
1960 -- type T10 = T9
1961 -- type T9 = T8
1962 -- ...
1963 -- type T0 = Int
1964 --
1965 -- `tyExpansions T10` returns [T9, T8, T7, ... Int]
1966 --
1967 -- This only expands the top layer, so if you have:
1968 --
1969 -- type M a = Maybe a
1970 --
1971 -- `tyExpansions (M T10)` returns [Maybe T10] (T10 is not expanded)
1972 tyExpansions :: Type -> [Type]
1973 tyExpansions = unfoldr (\t -> (\x -> (x, x)) `fmap` coreView t)
1974
1975 -- | Drop the type pairs until types in a pair look alike (i.e. the outer
1976 -- constructors are the same).
1977 followExpansions :: [(Type, Type)] -> (Type, Type)
1978 followExpansions [] = pprPanic "followExpansions" empty
1979 followExpansions [(t1, t2)]
1980 | sameShapes t1 t2 = go t1 t2 -- expand subtrees
1981 | otherwise = (t1, t2) -- the difference is already visible
1982 followExpansions ((t1, t2) : tss)
1983 -- Traverse subtrees when the outer shapes are the same
1984 | sameShapes t1 t2 = go t1 t2
1985 -- Otherwise follow the expansions until they look alike
1986 | otherwise = followExpansions tss
1987
1988 sameShapes :: Type -> Type -> Bool
1989 sameShapes AppTy{} AppTy{} = True
1990 sameShapes (TyConApp tc1 _) (TyConApp tc2 _) = tc1 == tc2
1991 sameShapes (FunTy {}) (FunTy {}) = True
1992 sameShapes (ForAllTy {}) (ForAllTy {}) = True
1993 sameShapes (CastTy ty1 _) ty2 = sameShapes ty1 ty2
1994 sameShapes ty1 (CastTy ty2 _) = sameShapes ty1 ty2
1995 sameShapes _ _ = False
1996
1997 sameOccExtra :: TcType -> TcType -> SDoc
1998 -- See Note [Disambiguating (X ~ X) errors]
1999 sameOccExtra ty1 ty2
2000 | Just (tc1, _) <- tcSplitTyConApp_maybe ty1
2001 , Just (tc2, _) <- tcSplitTyConApp_maybe ty2
2002 , let n1 = tyConName tc1
2003 n2 = tyConName tc2
2004 same_occ = nameOccName n1 == nameOccName n2
2005 same_pkg = moduleUnitId (nameModule n1) == moduleUnitId (nameModule n2)
2006 , n1 /= n2 -- Different Names
2007 , same_occ -- but same OccName
2008 = text "NB:" <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2)
2009 | otherwise
2010 = empty
2011 where
2012 ppr_from same_pkg nm
2013 | isGoodSrcSpan loc
2014 = hang (quotes (ppr nm) <+> text "is defined at")
2015 2 (ppr loc)
2016 | otherwise -- Imported things have an UnhelpfulSrcSpan
2017 = hang (quotes (ppr nm))
2018 2 (sep [ text "is defined in" <+> quotes (ppr (moduleName mod))
2019 , ppUnless (same_pkg || pkg == mainUnitId) $
2020 nest 4 $ text "in package" <+> quotes (ppr pkg) ])
2021 where
2022 pkg = moduleUnitId mod
2023 mod = nameModule nm
2024 loc = nameSrcSpan nm
2025
2026 {-
2027 Note [Suggest adding a type signature]
2028 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2029 The OutsideIn algorithm rejects GADT programs that don't have a principal
2030 type, and indeed some that do. Example:
2031 data T a where
2032 MkT :: Int -> T Int
2033
2034 f (MkT n) = n
2035
2036 Does this have type f :: T a -> a, or f :: T a -> Int?
2037 The error that shows up tends to be an attempt to unify an
2038 untouchable type variable. So suggestAddSig sees if the offending
2039 type variable is bound by an *inferred* signature, and suggests
2040 adding a declared signature instead.
2041
2042 This initially came up in Trac #8968, concerning pattern synonyms.
2043
2044 Note [Disambiguating (X ~ X) errors]
2045 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2046 See Trac #8278
2047
2048 Note [Reporting occurs-check errors]
2049 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2050 Given (a ~ [a]), if 'a' is a rigid type variable bound by a user-supplied
2051 type signature, then the best thing is to report that we can't unify
2052 a with [a], because a is a skolem variable. That avoids the confusing
2053 "occur-check" error message.
2054
2055 But nowadays when inferring the type of a function with no type signature,
2056 even if there are errors inside, we still generalise its signature and
2057 carry on. For example
2058 f x = x:x
2059 Here we will infer something like
2060 f :: forall a. a -> [a]
2061 with a deferred error of (a ~ [a]). So in the deferred unsolved constraint
2062 'a' is now a skolem, but not one bound by the programmer in the context!
2063 Here we really should report an occurs check.
2064
2065 So isUserSkolem distinguishes the two.
2066
2067 Note [Non-injective type functions]
2068 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2069 It's very confusing to get a message like
2070 Couldn't match expected type `Depend s'
2071 against inferred type `Depend s1'
2072 so mkTyFunInfoMsg adds:
2073 NB: `Depend' is type function, and hence may not be injective
2074
2075 Warn of loopy local equalities that were dropped.
2076
2077
2078 ************************************************************************
2079 * *
2080 Type-class errors
2081 * *
2082 ************************************************************************
2083 -}
2084
2085 mkDictErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
2086 mkDictErr ctxt cts
2087 = ASSERT( not (null cts) )
2088 do { inst_envs <- tcGetInstEnvs
2089 ; let (ct1:_) = cts -- ct1 just for its location
2090 min_cts = elim_superclasses cts
2091 lookups = map (lookup_cls_inst inst_envs) min_cts
2092 (no_inst_cts, overlap_cts) = partition is_no_inst lookups
2093
2094 -- Report definite no-instance errors,
2095 -- or (iff there are none) overlap errors
2096 -- But we report only one of them (hence 'head') because they all
2097 -- have the same source-location origin, to try avoid a cascade
2098 -- of error from one location
2099 ; (ctxt, err) <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts))
2100 ; mkErrorMsgFromCt ctxt ct1 (important err) }
2101 where
2102 no_givens = null (getUserGivens ctxt)
2103
2104 is_no_inst (ct, (matches, unifiers, _))
2105 = no_givens
2106 && null matches
2107 && (null unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfCtList ct))
2108
2109 lookup_cls_inst inst_envs ct
2110 -- Note [Flattening in error message generation]
2111 = (ct, lookupInstEnv True inst_envs clas (flattenTys emptyInScopeSet tys))
2112 where
2113 (clas, tys) = getClassPredTys (ctPred ct)
2114
2115
2116 -- When simplifying [W] Ord (Set a), we need
2117 -- [W] Eq a, [W] Ord a
2118 -- but we really only want to report the latter
2119 elim_superclasses cts
2120 = filter (\ct -> any (eqType (ctPred ct)) min_preds) cts
2121 where
2122 min_preds = mkMinimalBySCs (map ctPred cts)
2123
2124 mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult)
2125 -> TcM (ReportErrCtxt, SDoc)
2126 -- Report an overlap error if this class constraint results
2127 -- from an overlap (returning Left clas), otherwise return (Right pred)
2128 mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_overlapped))
2129 | null matches -- No matches but perhaps several unifiers
2130 = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct
2131 ; candidate_insts <- get_candidate_instances
2132 ; return (ctxt, cannot_resolve_msg ct candidate_insts binds_msg) }
2133
2134 | null unsafe_overlapped -- Some matches => overlap errors
2135 = return (ctxt, overlap_msg)
2136
2137 | otherwise
2138 = return (ctxt, safe_haskell_msg)
2139 where
2140 orig = ctOrigin ct
2141 pred = ctPred ct
2142 (clas, tys) = getClassPredTys pred
2143 ispecs = [ispec | (ispec, _) <- matches]
2144 unsafe_ispecs = [ispec | (ispec, _) <- unsafe_overlapped]
2145 useful_givens = discardProvCtxtGivens orig (getUserGivensFromImplics implics)
2146 -- useful_givens are the enclosing implications with non-empty givens,
2147 -- modulo the horrid discardProvCtxtGivens
2148
2149 get_candidate_instances :: TcM [ClsInst]
2150 -- See Note [Report candidate instances]
2151 get_candidate_instances
2152 | [ty] <- tys -- Only try for single-parameter classes
2153 = do { instEnvs <- tcGetInstEnvs
2154 ; return (filter (is_candidate_inst ty)
2155 (classInstances instEnvs clas)) }
2156 | otherwise = return []
2157
2158 is_candidate_inst ty inst -- See Note [Report candidate instances]
2159 | [other_ty] <- is_tys inst
2160 , Just (tc1, _) <- tcSplitTyConApp_maybe ty
2161 , Just (tc2, _) <- tcSplitTyConApp_maybe other_ty
2162 = let n1 = tyConName tc1
2163 n2 = tyConName tc2
2164 different_names = n1 /= n2
2165 same_occ_names = nameOccName n1 == nameOccName n2
2166 in different_names && same_occ_names
2167 | otherwise = False
2168
2169 cannot_resolve_msg :: Ct -> [ClsInst] -> SDoc -> SDoc
2170 cannot_resolve_msg ct candidate_insts binds_msg
2171 = vcat [ no_inst_msg
2172 , nest 2 extra_note
2173 , vcat (pp_givens useful_givens)
2174 , mb_patsyn_prov `orElse` empty
2175 , ppWhen (has_ambig_tvs && not (null unifiers && null useful_givens))
2176 (vcat [ ppUnless lead_with_ambig ambig_msg, binds_msg, potential_msg ])
2177
2178 , ppWhen (isNothing mb_patsyn_prov) $
2179 -- Don't suggest fixes for the provided context of a pattern
2180 -- synonym; the right fix is to bind more in the pattern
2181 show_fixes (ctxtFixes has_ambig_tvs pred implics
2182 ++ drv_fixes)
2183 , ppWhen (not (null candidate_insts))
2184 (hang (text "There are instances for similar types:")
2185 2 (vcat (map ppr candidate_insts))) ]
2186 -- See Note [Report candidate instances]
2187 where
2188 orig = ctOrigin ct
2189 -- See Note [Highlighting ambiguous type variables]
2190 lead_with_ambig = has_ambig_tvs && not (any isRuntimeUnkSkol ambig_tvs)
2191 && not (null unifiers) && null useful_givens
2192
2193 (has_ambig_tvs, ambig_msg) = mkAmbigMsg lead_with_ambig ct
2194 ambig_tvs = uncurry (++) (getAmbigTkvs ct)
2195
2196 no_inst_msg
2197 | lead_with_ambig
2198 = ambig_msg <+> pprArising orig
2199 $$ text "prevents the constraint" <+> quotes (pprParendType pred)
2200 <+> text "from being solved."
2201
2202 | null useful_givens
2203 = addArising orig $ text "No instance for"
2204 <+> pprParendType pred
2205
2206 | otherwise
2207 = addArising orig $ text "Could not deduce"
2208 <+> pprParendType pred
2209
2210 potential_msg
2211 = ppWhen (not (null unifiers) && want_potential orig) $
2212 sdocWithDynFlags $ \dflags ->
2213 getPprStyle $ \sty ->
2214 pprPotentials dflags sty potential_hdr unifiers
2215
2216 potential_hdr
2217 = vcat [ ppWhen lead_with_ambig $
2218 text "Probable fix: use a type annotation to specify what"
2219 <+> pprQuotedList ambig_tvs <+> text "should be."
2220 , text "These potential instance" <> plural unifiers
2221 <+> text "exist:"]
2222
2223 mb_patsyn_prov :: Maybe SDoc
2224 mb_patsyn_prov
2225 | not lead_with_ambig
2226 , ProvCtxtOrigin PSB{ psb_def = L _ pat } <- orig
2227 = Just (vcat [ text "In other words, a successful match on the pattern"
2228 , nest 2 $ ppr pat
2229 , text "does not provide the constraint" <+> pprParendType pred ])
2230 | otherwise = Nothing
2231
2232 -- Report "potential instances" only when the constraint arises
2233 -- directly from the user's use of an overloaded function
2234 want_potential (TypeEqOrigin {}) = False
2235 want_potential _ = True
2236
2237 extra_note | any isFunTy (filterOutInvisibleTypes (classTyCon clas) tys)
2238 = text "(maybe you haven't applied a function to enough arguments?)"
2239 | className clas == typeableClassName -- Avoid mysterious "No instance for (Typeable T)
2240 , [_,ty] <- tys -- Look for (Typeable (k->*) (T k))
2241 , Just (tc,_) <- tcSplitTyConApp_maybe ty
2242 , not (isTypeFamilyTyCon tc)
2243 = hang (text "GHC can't yet do polykinded")
2244 2 (text "Typeable" <+>
2245 parens (ppr ty <+> dcolon <+> ppr (typeKind ty)))
2246 | otherwise
2247 = empty
2248
2249 drv_fixes = case orig of
2250 DerivOrigin -> [drv_fix]
2251 DerivOriginDC {} -> [drv_fix]
2252 DerivOriginCoerce {} -> [drv_fix]
2253 _ -> []
2254
2255 drv_fix = hang (text "use a standalone 'deriving instance' declaration,")
2256 2 (text "so you can specify the instance context yourself")
2257
2258 -- Normal overlap error
2259 overlap_msg
2260 = ASSERT( not (null matches) )
2261 vcat [ addArising orig (text "Overlapping instances for"
2262 <+> pprType (mkClassPred clas tys))
2263
2264 , ppUnless (null matching_givens) $
2265 sep [text "Matching givens (or their superclasses):"
2266 , nest 2 (vcat matching_givens)]
2267
2268 , sdocWithDynFlags $ \dflags ->
2269 getPprStyle $ \sty ->
2270 pprPotentials dflags sty (text "Matching instances:") $
2271 ispecs ++ unifiers
2272
2273 , ppWhen (null matching_givens && isSingleton matches && null unifiers) $
2274 -- Intuitively, some given matched the wanted in their
2275 -- flattened or rewritten (from given equalities) form
2276 -- but the matcher can't figure that out because the
2277 -- constraints are non-flat and non-rewritten so we
2278 -- simply report back the whole given
2279 -- context. Accelerate Smart.hs showed this problem.
2280 sep [ text "There exists a (perhaps superclass) match:"
2281 , nest 2 (vcat (pp_givens useful_givens))]
2282
2283 , ppWhen (isSingleton matches) $
2284 parens (vcat [ text "The choice depends on the instantiation of" <+>
2285 quotes (pprWithCommas ppr (tyCoVarsOfTypesList tys))
2286 , ppWhen (null (matching_givens)) $
2287 vcat [ text "To pick the first instance above, use IncoherentInstances"
2288 , text "when compiling the other instance declarations"]
2289 ])]
2290
2291 matching_givens = mapMaybe matchable useful_givens
2292
2293 matchable (Implic { ic_given = evvars, ic_info = skol_info, ic_env = env })
2294 = case ev_vars_matching of
2295 [] -> Nothing
2296 _ -> Just $ hang (pprTheta ev_vars_matching)
2297 2 (sep [ text "bound by" <+> ppr skol_info
2298 , text "at" <+> ppr (tcl_loc env) ])
2299 where ev_vars_matching = filter ev_var_matches (map evVarPred evvars)
2300 ev_var_matches ty = case getClassPredTys_maybe ty of
2301 Just (clas', tys')
2302 | clas' == clas
2303 , Just _ <- tcMatchTys tys tys'
2304 -> True
2305 | otherwise
2306 -> any ev_var_matches (immSuperClasses clas' tys')
2307 Nothing -> False
2308
2309 -- Overlap error because of Safe Haskell (first
2310 -- match should be the most specific match)
2311 safe_haskell_msg
2312 = ASSERT( length matches == 1 && not (null unsafe_ispecs) )
2313 vcat [ addArising orig (text "Unsafe overlapping instances for"
2314 <+> pprType (mkClassPred clas tys))
2315 , sep [text "The matching instance is:",
2316 nest 2 (pprInstance $ head ispecs)]
2317 , vcat [ text "It is compiled in a Safe module and as such can only"
2318 , text "overlap instances from the same module, however it"
2319 , text "overlaps the following instances from different" <+>
2320 text "modules:"
2321 , nest 2 (vcat [pprInstances $ unsafe_ispecs])
2322 ]
2323 ]
2324
2325
2326 ctxtFixes :: Bool -> PredType -> [Implication] -> [SDoc]
2327 ctxtFixes has_ambig_tvs pred implics
2328 | not has_ambig_tvs
2329 , isTyVarClassPred pred
2330 , (skol:skols) <- usefulContext implics pred
2331 , let what | null skols
2332 , SigSkol (PatSynCtxt {}) _ <- skol
2333 = text "\"required\""
2334 | otherwise
2335 = empty
2336 = [sep [ text "add" <+> pprParendType pred
2337 <+> text "to the" <+> what <+> text "context of"
2338 , nest 2 $ ppr_skol skol $$
2339 vcat [ text "or" <+> ppr_skol skol
2340 | skol <- skols ] ] ]
2341 | otherwise = []
2342 where
2343 ppr_skol (PatSkol (RealDataCon dc) _) = text "the data constructor" <+> quotes (ppr dc)
2344 ppr_skol (PatSkol (PatSynCon ps) _) = text "the pattern synonym" <+> quotes (ppr ps)
2345 ppr_skol skol_info = ppr skol_info
2346
2347 discardProvCtxtGivens :: CtOrigin -> [UserGiven] -> [UserGiven]
2348 discardProvCtxtGivens orig givens -- See Note [discardProvCtxtGivens]
2349 | ProvCtxtOrigin (PSB {psb_id = L _ name}) <- orig
2350 = filterOut (discard name) givens
2351 | otherwise
2352 = givens
2353 where
2354 discard n (Implic { ic_info = SigSkol (PatSynCtxt n') _ }) = n == n'
2355 discard _ _ = False
2356
2357 usefulContext :: [Implication] -> PredType -> [SkolemInfo]
2358 -- usefulContext picks out the implications whose context
2359 -- the programmer might plausibly augment to solve 'pred'
2360 usefulContext implics pred
2361 = go implics
2362 where
2363 pred_tvs = tyCoVarsOfType pred
2364 go [] = []
2365 go (ic : ics)
2366 | implausible ic = rest
2367 | otherwise = ic_info ic : rest
2368 where
2369 -- Stop when the context binds a variable free in the predicate
2370 rest | any (`elemVarSet` pred_tvs) (ic_skols ic) = []
2371 | otherwise = go ics
2372
2373 implausible ic
2374 | null (ic_skols ic) = True
2375 | implausible_info (ic_info ic) = True
2376 | otherwise = False
2377
2378 implausible_info (SigSkol (InfSigCtxt {}) _) = True
2379 implausible_info _ = False
2380 -- Do not suggest adding constraints to an *inferred* type signature
2381
2382 {- Note [Report candidate instances]
2383 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2384 If we have an unsolved (Num Int), where `Int` is not the Prelude Int,
2385 but comes from some other module, then it may be helpful to point out
2386 that there are some similarly named instances elsewhere. So we get
2387 something like
2388 No instance for (Num Int) arising from the literal ‘3’
2389 There are instances for similar types:
2390 instance Num GHC.Types.Int -- Defined in ‘GHC.Num’
2391 Discussion in Trac #9611.
2392
2393 Note [Highlighting ambiguous type variables]
2394 ~-------------------------------------------
2395 When we encounter ambiguous type variables (i.e. type variables
2396 that remain metavariables after type inference), we need a few more
2397 conditions before we can reason that *ambiguity* prevents constraints
2398 from being solved:
2399 - We can't have any givens, as encountering a typeclass error
2400 with given constraints just means we couldn't deduce
2401 a solution satisfying those constraints and as such couldn't
2402 bind the type variable to a known type.
2403 - If we don't have any unifiers, we don't even have potential
2404 instances from which an ambiguity could arise.
2405 - Lastly, I don't want to mess with error reporting for
2406 unknown runtime types so we just fall back to the old message there.
2407 Once these conditions are satisfied, we can safely say that ambiguity prevents
2408 the constraint from being solved.
2409
2410 Note [discardProvCtxtGivens]
2411 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
2412 In most situations we call all enclosing implications "useful". There is one
2413 exception, and that is when the constraint that causes the error is from the
2414 "provided" context of a pattern synonym declaration:
2415
2416 pattern Pat :: (Num a, Eq a) => Show a => a -> Maybe a
2417 -- required => provided => type
2418 pattern Pat x <- (Just x, 4)
2419
2420 When checking the pattern RHS we must check that it does actually bind all
2421 the claimed "provided" constraints; in this case, does the pattern (Just x, 4)
2422 bind the (Show a) constraint. Answer: no!
2423
2424 But the implication we generate for this will look like
2425 forall a. (Num a, Eq a) => [W] Show a
2426 because when checking the pattern we must make the required
2427 constraints available, since they are needed to match the pattern (in
2428 this case the literal '4' needs (Num a, Eq a)).
2429
2430 BUT we don't want to suggest adding (Show a) to the "required" constraints
2431 of the pattern synonym, thus:
2432 pattern Pat :: (Num a, Eq a, Show a) => Show a => a -> Maybe a
2433 It would then typecheck but it's silly. We want the /pattern/ to bind
2434 the alleged "provided" constraints, Show a.
2435
2436 So we suppress that Implication in discardProvCtxtGivens. It's
2437 painfully ad-hoc but the truth is that adding it to the "required"
2438 constraints would work. Suprressing it solves two problems. First,
2439 we never tell the user that we could not deduce a "provided"
2440 constraint from the "required" context. Second, we never give a
2441 possible fix that suggests to add a "provided" constraint to the
2442 "required" context.
2443
2444 For example, without this distinction the above code gives a bad error
2445 message (showing both problems):
2446
2447 error: Could not deduce (Show a) ... from the context: (Eq a)
2448 ... Possible fix: add (Show a) to the context of
2449 the signature for pattern synonym `Pat' ...
2450
2451 -}
2452
2453 show_fixes :: [SDoc] -> SDoc
2454 show_fixes [] = empty
2455 show_fixes (f:fs) = sep [ text "Possible fix:"
2456 , nest 2 (vcat (f : map (text "or" <+>) fs))]
2457
2458 pprPotentials :: DynFlags -> PprStyle -> SDoc -> [ClsInst] -> SDoc
2459 -- See Note [Displaying potential instances]
2460 pprPotentials dflags sty herald insts
2461 | null insts
2462 = empty
2463
2464 | null show_these
2465 = hang herald
2466 2 (vcat [ not_in_scope_msg empty
2467 , flag_hint ])
2468
2469 | otherwise
2470 = hang herald
2471 2 (vcat [ pprInstances show_these
2472 , ppWhen (n_in_scope_hidden > 0) $
2473 text "...plus"
2474 <+> speakNOf n_in_scope_hidden (text "other")
2475 , not_in_scope_msg (text "...plus")
2476 , flag_hint ])
2477 where
2478 n_show = 3 :: Int
2479 show_potentials = gopt Opt_PrintPotentialInstances dflags
2480
2481 (in_scope, not_in_scope) = partition inst_in_scope insts
2482 sorted = sortBy fuzzyClsInstCmp in_scope
2483 show_these | show_potentials = sorted
2484 | otherwise = take n_show sorted
2485 n_in_scope_hidden = length sorted - length show_these
2486
2487 -- "in scope" means that all the type constructors
2488 -- are lexically in scope; these instances are likely
2489 -- to be more useful
2490 inst_in_scope :: ClsInst -> Bool
2491 inst_in_scope cls_inst = nameSetAll name_in_scope $
2492 orphNamesOfTypes (is_tys cls_inst)
2493
2494 name_in_scope name
2495 | isBuiltInSyntax name
2496 = True -- E.g. (->)
2497 | Just mod <- nameModule_maybe name
2498 = qual_in_scope (qualName sty mod (nameOccName name))
2499 | otherwise
2500 = True
2501
2502 qual_in_scope :: QualifyName -> Bool
2503 qual_in_scope NameUnqual = True
2504 qual_in_scope (NameQual {}) = True
2505 qual_in_scope _ = False
2506
2507 not_in_scope_msg herald
2508 | null not_in_scope
2509 = empty
2510 | otherwise
2511 = hang (herald <+> speakNOf (length not_in_scope) (text "instance")
2512 <+> text "involving out-of-scope types")
2513 2 (ppWhen show_potentials (pprInstances not_in_scope))
2514
2515 flag_hint = ppUnless (show_potentials || length show_these == length insts) $
2516 text "(use -fprint-potential-instances to see them all)"
2517
2518 {- Note [Displaying potential instances]
2519 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2520 When showing a list of instances for
2521 - overlapping instances (show ones that match)
2522 - no such instance (show ones that could match)
2523 we want to give it a bit of structure. Here's the plan
2524
2525 * Say that an instance is "in scope" if all of the
2526 type constructors it mentions are lexically in scope.
2527 These are the ones most likely to be useful to the programmer.
2528
2529 * Show at most n_show in-scope instances,
2530 and summarise the rest ("plus 3 others")
2531
2532 * Summarise the not-in-scope instances ("plus 4 not in scope")
2533
2534 * Add the flag -fshow-potential-instances which replaces the
2535 summary with the full list
2536 -}
2537
2538 {-
2539 Note [Flattening in error message generation]
2540 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2541 Consider (C (Maybe (F x))), where F is a type function, and we have
2542 instances
2543 C (Maybe Int) and C (Maybe a)
2544 Since (F x) might turn into Int, this is an overlap situation, and
2545 indeed (because of flattening) the main solver will have refrained
2546 from solving. But by the time we get to error message generation, we've
2547 un-flattened the constraint. So we must *re*-flatten it before looking
2548 up in the instance environment, lest we only report one matching
2549 instance when in fact there are two.
2550
2551 Re-flattening is pretty easy, because we don't need to keep track of
2552 evidence. We don't re-use the code in TcCanonical because that's in
2553 the TcS monad, and we are in TcM here.
2554
2555 Note [Suggest -fprint-explicit-kinds]
2556 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2557 It can be terribly confusing to get an error message like (Trac #9171)
2558 Couldn't match expected type ‘GetParam Base (GetParam Base Int)’
2559 with actual type ‘GetParam Base (GetParam Base Int)’
2560 The reason may be that the kinds don't match up. Typically you'll get
2561 more useful information, but not when it's as a result of ambiguity.
2562 This test suggests -fprint-explicit-kinds when all the ambiguous type
2563 variables are kind variables.
2564 -}
2565
2566 mkAmbigMsg :: Bool -- True when message has to be at beginning of sentence
2567 -> Ct -> (Bool, SDoc)
2568 mkAmbigMsg prepend_msg ct
2569 | null ambig_kvs && null ambig_tvs = (False, empty)
2570 | otherwise = (True, msg)
2571 where
2572 (ambig_kvs, ambig_tvs) = getAmbigTkvs ct
2573
2574 msg | any isRuntimeUnkSkol ambig_kvs -- See Note [Runtime skolems]
2575 || any isRuntimeUnkSkol ambig_tvs
2576 = vcat [ text "Cannot resolve unknown runtime type"
2577 <> plural ambig_tvs <+> pprQuotedList ambig_tvs
2578 , text "Use :print or :force to determine these types"]
2579
2580 | not (null ambig_tvs)
2581 = pp_ambig (text "type") ambig_tvs
2582
2583 | otherwise -- All ambiguous kind variabes; suggest -fprint-explicit-kinds
2584 -- See Note [Suggest -fprint-explicit-kinds]
2585 = vcat [ pp_ambig (text "kind") ambig_kvs
2586 , ppSuggestExplicitKinds ]
2587
2588 pp_ambig what tkvs
2589 | prepend_msg -- "Ambiguous type variable 't0'"
2590 = text "Ambiguous" <+> what <+> text "variable"
2591 <> plural tkvs <+> pprQuotedList tkvs
2592
2593 | otherwise -- "The type variable 't0' is ambiguous"
2594 = text "The" <+> what <+> text "variable" <> plural tkvs
2595 <+> pprQuotedList tkvs <+> is_or_are tkvs <+> text "ambiguous"
2596
2597 is_or_are [_] = text "is"
2598 is_or_are _ = text "are"
2599
2600 pprSkol :: [Implication] -> TcTyVar -> SDoc
2601 pprSkol implics tv
2602 = case skol_info of
2603 UnkSkol -> quotes (ppr tv) <+> text "is an unknown type variable"
2604 SigSkol ctxt ty -> ppr_rigid (pprSigSkolInfo ctxt
2605 (mkSpecForAllTys skol_tvs ty))
2606 _ -> ppr_rigid (pprSkolInfo skol_info)
2607 where
2608 Implic { ic_skols = skol_tvs, ic_info = skol_info }
2609 = getSkolemInfo implics tv
2610 ppr_rigid pp_info
2611 = hang (quotes (ppr tv) <+> text "is a rigid type variable bound by")
2612 2 (sep [ pp_info
2613 , text "at" <+> ppr (getSrcSpan tv) ])
2614
2615 getAmbigTkvs :: Ct -> ([Var],[Var])
2616 getAmbigTkvs ct
2617 = partition (`elemVarSet` dep_tkv_set) ambig_tkvs
2618 where
2619 tkvs = tyCoVarsOfCtList ct
2620 ambig_tkvs = filter isAmbiguousTyVar tkvs
2621 dep_tkv_set = tyCoVarsOfTypes (map tyVarKind tkvs)
2622
2623 getSkolemInfo :: [Implication] -> TcTyVar -> Implication
2624 -- Get the skolem info for a type variable
2625 -- from the implication constraint that binds it
2626 getSkolemInfo [] tv
2627 = pprPanic "No skolem info:" (ppr tv)
2628
2629 getSkolemInfo (implic:implics) tv
2630 | tv `elem` ic_skols implic = implic
2631 | otherwise = getSkolemInfo implics tv
2632
2633 -----------------------
2634 -- relevantBindings looks at the value environment and finds values whose
2635 -- types mention any of the offending type variables. It has to be
2636 -- careful to zonk the Id's type first, so it has to be in the monad.
2637 -- We must be careful to pass it a zonked type variable, too.
2638 --
2639 -- We always remove closed top-level bindings, though,
2640 -- since they are never relevant (cf Trac #8233)
2641
2642 relevantBindings :: Bool -- True <=> filter by tyvar; False <=> no filtering
2643 -- See Trac #8191
2644 -> ReportErrCtxt -> Ct
2645 -> TcM (ReportErrCtxt, SDoc, Ct)
2646 -- Also returns the zonked and tidied CtOrigin of the constraint
2647 relevantBindings want_filtering ctxt ct
2648 = do { dflags <- getDynFlags
2649 ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc)
2650 ; let ct_tvs = tyCoVarsOfCt ct `unionVarSet` extra_tvs
2651
2652 -- For *kind* errors, report the relevant bindings of the
2653 -- enclosing *type* equality, because that's more useful for the programmer
2654 extra_tvs = case tidy_orig of
2655 KindEqOrigin t1 m_t2 _ _ -> tyCoVarsOfTypes $
2656 t1 : maybeToList m_t2
2657 _ -> emptyVarSet
2658 ; traceTc "relevantBindings" $
2659 vcat [ ppr ct
2660 , pprCtOrigin (ctLocOrigin loc)
2661 , ppr ct_tvs
2662 , pprWithCommas id [ ppr id <+> dcolon <+> ppr (idType id)
2663 | TcIdBndr id _ <- tcl_bndrs lcl_env ]
2664 , pprWithCommas id
2665 [ ppr id | TcIdBndr_ExpType id _ _ <- tcl_bndrs lcl_env ] ]
2666
2667 ; (tidy_env', docs, discards)
2668 <- go dflags env1 ct_tvs (maxRelevantBinds dflags)
2669 emptyVarSet [] False
2670 (remove_shadowing $ tcl_bndrs lcl_env)
2671 -- tcl_bndrs has the innermost bindings first,
2672 -- which are probably the most relevant ones
2673
2674 ; let doc = ppUnless (null docs) $
2675 hang (text "Relevant bindings include")
2676 2 (vcat docs $$ ppWhen discards discardMsg)
2677
2678 -- Put a zonked, tidied CtOrigin into the Ct
2679 loc' = setCtLocOrigin loc tidy_orig
2680 ct' = setCtLoc ct loc'
2681 ctxt' = ctxt { cec_tidy = tidy_env' }
2682
2683 ; return (ctxt', doc, ct') }
2684 where
2685 ev = ctEvidence ct
2686 loc = ctEvLoc ev
2687 lcl_env = ctLocEnv loc
2688
2689 run_out :: Maybe Int -> Bool
2690 run_out Nothing = False
2691 run_out (Just n) = n <= 0
2692
2693 dec_max :: Maybe Int -> Maybe Int
2694 dec_max = fmap (\n -> n - 1)
2695
2696 ---- fixes #12177
2697 ---- builds up a list of bindings whose OccName has not been seen before
2698 remove_shadowing :: [TcIdBinder] -> [TcIdBinder]
2699 remove_shadowing bindings = reverse $ fst $ foldl
2700 (\(bindingAcc, seenNames) binding ->
2701 if (occName binding) `elemOccSet` seenNames -- if we've seen it
2702 then (bindingAcc, seenNames) -- skip it
2703 else (binding:bindingAcc, extendOccSet seenNames (occName binding)))
2704 ([], emptyOccSet) bindings
2705
2706 go :: DynFlags -> TidyEnv -> TcTyVarSet -> Maybe Int -> TcTyVarSet -> [SDoc]
2707 -> Bool -- True <=> some filtered out due to lack of fuel
2708 -> [TcIdBinder]
2709 -> TcM (TidyEnv, [SDoc], Bool) -- The bool says if we filtered any out
2710 -- because of lack of fuel
2711 go _ tidy_env _ _ _ docs discards []
2712 = return (tidy_env, reverse docs, discards)
2713 go dflags tidy_env ct_tvs n_left tvs_seen docs discards (tc_bndr : tc_bndrs)
2714 = case tc_bndr of
2715 TcIdBndr id top_lvl -> go2 (idName id) (idType id) top_lvl
2716 TcIdBndr_ExpType name et top_lvl ->
2717 do { mb_ty <- readExpType_maybe et
2718 -- et really should be filled in by now. But there's a chance
2719 -- it hasn't, if, say, we're reporting a kind error en route to
2720 -- checking a term. See test indexed-types/should_fail/T8129
2721 -- Or we are reporting errors from the ambiguity check on
2722 -- a local type signature
2723 ; case mb_ty of
2724 Just ty -> go2 name ty top_lvl
2725 Nothing -> discard_it -- No info; discard
2726 }
2727 where
2728 discard_it = go dflags tidy_env ct_tvs n_left tvs_seen docs
2729 discards tc_bndrs
2730 go2 id_name id_type top_lvl
2731 = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env id_type
2732 ; traceTc "relevantBindings 1" (ppr id_name <+> dcolon <+> ppr tidy_ty)
2733 ; let id_tvs = tyCoVarsOfType tidy_ty
2734 doc = sep [ pprPrefixOcc id_name <+> dcolon <+> ppr tidy_ty
2735 , nest 2 (parens (text "bound at"
2736 <+> ppr (getSrcLoc id_name)))]
2737 new_seen = tvs_seen `unionVarSet` id_tvs
2738
2739 ; if (want_filtering && not (hasPprDebug dflags)
2740 && id_tvs `disjointVarSet` ct_tvs)
2741 -- We want to filter out this binding anyway
2742 -- so discard it silently
2743 then discard_it
2744
2745 else if isTopLevel top_lvl && not (isNothing n_left)
2746 -- It's a top-level binding and we have not specified
2747 -- -fno-max-relevant-bindings, so discard it silently
2748 then discard_it
2749
2750 else if run_out n_left && id_tvs `subVarSet` tvs_seen
2751 -- We've run out of n_left fuel and this binding only
2752 -- mentions already-seen type variables, so discard it
2753 then go dflags tidy_env ct_tvs n_left tvs_seen docs
2754 True -- Record that we have now discarded something
2755 tc_bndrs
2756
2757 -- Keep this binding, decrement fuel
2758 else go dflags tidy_env' ct_tvs (dec_max n_left) new_seen
2759 (doc:docs) discards tc_bndrs }
2760
2761 discardMsg :: SDoc
2762 discardMsg = text "(Some bindings suppressed;" <+>
2763 text "use -fmax-relevant-binds=N or -fno-max-relevant-binds)"
2764
2765 -----------------------
2766 warnDefaulting :: [Ct] -> Type -> TcM ()
2767 warnDefaulting wanteds default_ty
2768 = do { warn_default <- woptM Opt_WarnTypeDefaults
2769 ; env0 <- tcInitTidyEnv
2770 ; let tidy_env = tidyFreeTyCoVars env0 $
2771 tyCoVarsOfCtsList (listToBag wanteds)
2772 tidy_wanteds = map (tidyCt tidy_env) wanteds
2773 (loc, ppr_wanteds) = pprWithArising tidy_wanteds
2774 warn_msg =
2775 hang (hsep [ text "Defaulting the following"
2776 , text "constraint" <> plural tidy_wanteds
2777 , text "to type"
2778 , quotes (ppr default_ty) ])
2779 2
2780 ppr_wanteds
2781 ; setCtLocM loc $ warnTc (Reason Opt_WarnTypeDefaults) warn_default warn_msg }
2782
2783 {-
2784 Note [Runtime skolems]
2785 ~~~~~~~~~~~~~~~~~~~~~~
2786 We want to give a reasonably helpful error message for ambiguity
2787 arising from *runtime* skolems in the debugger. These
2788 are created by in RtClosureInspect.zonkRTTIType.
2789
2790 ************************************************************************
2791 * *
2792 Error from the canonicaliser
2793 These ones are called *during* constraint simplification
2794 * *
2795 ************************************************************************
2796 -}
2797
2798 solverDepthErrorTcS :: CtLoc -> TcType -> TcM a
2799 solverDepthErrorTcS loc ty
2800 = setCtLocM loc $
2801 do { ty <- zonkTcType ty
2802 ; env0 <- tcInitTidyEnv
2803 ; let tidy_env = tidyFreeTyCoVars env0 (tyCoVarsOfTypeList ty)
2804 tidy_ty = tidyType tidy_env ty
2805 msg
2806 = vcat [ text "Reduction stack overflow; size =" <+> ppr depth
2807 , hang (text "When simplifying the following type:")
2808 2 (ppr tidy_ty)
2809 , note ]
2810 ; failWithTcM (tidy_env, msg) }
2811 where
2812 depth = ctLocDepth loc
2813 note = vcat
2814 [ text "Use -freduction-depth=0 to disable this check"
2815 , text "(any upper bound you could choose might fail unpredictably with"
2816 , text " minor updates to GHC, so disabling the check is recommended if"
2817 , text " you're sure that type checking should terminate)" ]