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