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