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