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