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