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