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