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