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