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