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