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