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