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