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