cd5879c7bf2af9e4f701255043113cd128f093f1
[ghc.git] / compiler / typecheck / TcErrors.lhs
1 \begin{code}
2 {-# LANGUAGE CPP, ScopedTypeVariables #-}
3
4 module TcErrors(
5        reportUnsolved, reportAllUnsolved,
6        warnDefaulting,
7
8        solverDepthErrorTcS
9   ) where
10
11 #include "HsVersions.h"
12
13 import TcRnTypes
14 import TcRnMonad
15 import TcMType
16 import TcType
17 import TypeRep
18 import Type
19 import Kind ( isKind )
20 import Unify            ( tcMatchTys )
21 import Module
22 import FamInst          ( FamInstEnvs, tcGetFamInstEnvs, tcLookupDataFamInst )
23 import Inst
24 import InstEnv
25 import TyCon
26 import DataCon
27 import TcEvidence
28 import TysWiredIn       ( coercibleClass )
29 import Name
30 import RdrName          ( lookupGRE_Name )
31 import Id
32 import Var
33 import VarSet
34 import VarEnv
35 import Bag
36 import ErrUtils         ( ErrMsg, makeIntoWarning, pprLocErrMsg )
37 import BasicTypes
38 import Util
39 import FastString
40 import Outputable
41 import SrcLoc
42 import DynFlags
43 import StaticFlags      ( opt_PprStyle_Debug )
44 import ListSetOps       ( equivClasses )
45
46 import Control.Monad    ( when )
47 import Data.Maybe
48 import Data.List        ( partition, mapAccumL, zip4, nub, sortBy )
49 \end{code}
50
51 %************************************************************************
52 %*                                                                      *
53 \section{Errors and contexts}
54 %*                                                                      *
55 %************************************************************************
56
57 ToDo: for these error messages, should we note the location as coming
58 from the insts, or just whatever seems to be around in the monad just
59 now?
60
61 Note [Deferring coercion errors to runtime]
62 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
63 While developing, sometimes it is desirable to allow compilation to succeed even
64 if there are type errors in the code. Consider the following case:
65
66   module Main where
67
68   a :: Int
69   a = 'a'
70
71   main = print "b"
72
73 Even though `a` is ill-typed, it is not used in the end, so if all that we're
74 interested in is `main` it is handy to be able to ignore the problems in `a`.
75
76 Since we treat type equalities as evidence, this is relatively simple. Whenever
77 we run into a type mismatch in TcUnify, we normally just emit an error. But it
78 is always safe to defer the mismatch to the main constraint solver. If we do
79 that, `a` will get transformed into
80
81   co :: Int ~ Char
82   co = ...
83
84   a :: Int
85   a = 'a' `cast` co
86
87 The constraint solver would realize that `co` is an insoluble constraint, and
88 emit an error with `reportUnsolved`. But we can also replace the right-hand side
89 of `co` with `error "Deferred type error: Int ~ Char"`. This allows the program
90 to compile, and it will run fine unless we evaluate `a`. This is what
91 `deferErrorsToRuntime` does.
92
93 It does this by keeping track of which errors correspond to which coercion
94 in TcErrors. TcErrors.reportTidyWanteds does not print the errors
95 and does not fail if -fdefer-type-errors is on, so that we can continue
96 compilation. The errors are turned into warnings in `reportUnsolved`.
97
98 \begin{code}
99 reportUnsolved :: WantedConstraints -> TcM (Bag EvBind)
100 reportUnsolved wanted
101   = do { binds_var <- newTcEvBinds
102        ; defer_errors <- goptM Opt_DeferTypeErrors
103        ; defer_holes <- goptM Opt_DeferTypedHoles
104        ; warn_holes <- woptM Opt_WarnTypedHoles
105        ; report_unsolved (Just binds_var) defer_errors defer_holes
106              warn_holes wanted
107        ; getTcEvBinds binds_var }
108
109 reportAllUnsolved :: WantedConstraints -> TcM ()
110 -- Report all unsolved goals, even if -fdefer-type-errors is on
111 -- See Note [Deferring coercion errors to runtime]
112 reportAllUnsolved wanted = do
113     warn_holes <- woptM Opt_WarnTypedHoles
114     report_unsolved Nothing False False warn_holes wanted
115
116 report_unsolved :: Maybe EvBindsVar  -- cec_binds
117                 -> Bool              -- cec_defer_type_errors
118                 -> Bool              -- cec_defer_holes
119                 -> Bool              -- cec_warn_holes
120                 -> WantedConstraints -> TcM ()
121 -- Important precondition:
122 -- WantedConstraints are fully zonked and unflattened, that is,
123 -- zonkWC has already been applied to these constraints.
124 report_unsolved mb_binds_var defer_errors defer_holes  warn_holes wanted
125   | isEmptyWC wanted
126   = return ()
127   | otherwise
128   = do { traceTc "reportUnsolved (before unflattening)" (ppr wanted)
129
130        ; env0 <- tcInitTidyEnv
131
132             -- If we are deferring we are going to need /all/ evidence around,
133             -- including the evidence produced by unflattening (zonkWC)
134        ; let tidy_env = tidyFreeTyVars env0 free_tvs
135              free_tvs = tyVarsOfWC wanted
136              err_ctxt = CEC { cec_encl  = []
137                             , cec_tidy  = tidy_env
138                             , cec_defer_type_errors = defer_errors
139                             , cec_defer_holes = defer_holes
140                             , cec_warn_holes = warn_holes
141                             , cec_suppress = False -- See Note [Suppressing error messages]
142                             , cec_binds    = mb_binds_var }
143
144        ; traceTc "reportUnsolved (after unflattening):" $
145          vcat [ pprTvBndrs (varSetElems free_tvs)
146               , ppr wanted ]
147
148        ; reportWanteds err_ctxt wanted }
149
150 --------------------------------------------
151 --      Internal functions
152 --------------------------------------------
153
154 data ReportErrCtxt
155     = CEC { cec_encl :: [Implication]  -- Enclosing implications
156                                        --   (innermost first)
157                                        -- ic_skols and givens are tidied, rest are not
158           , cec_tidy  :: TidyEnv
159           , cec_binds :: Maybe EvBindsVar
160                          -- Nothinng <=> Report all errors, including holes; no bindings
161                          -- Just ev  <=> make some errors (depending on cec_defer)
162                          --              into warnings, and emit evidence bindings
163                          --              into 'ev' for unsolved constraints
164
165           , cec_defer_type_errors :: Bool -- True <=> -fdefer-type-errors
166                                           -- Defer type errors until runtime
167                                           -- Irrelevant if cec_binds = Nothing
168
169           , cec_defer_holes :: Bool     -- True <=> -fdefer-typed-holes
170                                         -- Turn typed holes into runtime errors
171                                         -- Irrelevant if cec_binds = Nothing
172
173           , cec_warn_holes :: Bool  -- True <=> -fwarn-typed-holes
174                                     -- Controls whether holes produce warnings
175           , cec_suppress :: Bool    -- True <=> More important errors have occurred,
176                                     --          so create bindings if need be, but
177                                     --          don't issue any more errors/warnings
178                                     -- See Note [Suppressing error messages]
179       }
180 \end{code}
181
182 Note [Suppressing error messages]
183 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
184 The cec_suppress flag says "don't report any errors.  Instead, just create
185 evidence bindings (as usual).  It's used when more important errors have occurred.
186 Specifically (see reportWanteds)
187   * If there are insoluble Givens, then we are in unreachable code and all bets
188     are off.  So don't report any further errors.
189   * If there are any insolubles (eg Int~Bool), here or in a nested implication,
190     then suppress errors from the flat constraints here.  Sometimes the
191     flat-constraint errors are a knock-on effect of the insolubles.
192
193
194 \begin{code}
195 reportImplic :: ReportErrCtxt -> Implication -> TcM ()
196 reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given
197                                  , ic_wanted = wanted, ic_binds = evb
198                                  , ic_insol = ic_insoluble, ic_info = info })
199   | BracketSkol <- info
200   , not ic_insoluble -- For Template Haskell brackets report only
201   = return ()        -- definite errors. The whole thing will be re-checked
202                      -- later when we plug it in, and meanwhile there may
203                      -- certainly be un-satisfied constraints
204
205   | otherwise
206   = reportWanteds ctxt' wanted
207   where
208     (env1, tvs') = mapAccumL tidyTyVarBndr (cec_tidy ctxt) tvs
209     (env2, info') = tidySkolemInfo env1 info
210     implic' = implic { ic_skols = tvs'
211                      , ic_given = map (tidyEvVar env2) given
212                      , ic_info  = info' }
213     ctxt' = ctxt { cec_tidy  = env2
214                  , cec_encl  = implic' : cec_encl ctxt
215                  , cec_binds = case cec_binds ctxt of
216                                  Nothing -> Nothing
217                                  Just {} -> Just evb }
218
219 reportWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
220 reportWanteds ctxt wanted@(WC { wc_flat = flats, wc_insol = insols, wc_impl = implics })
221   = do { reportFlats ctxt  (mapBag (tidyCt env) insol_given)
222        ; reportFlats ctxt1 (mapBag (tidyCt env) insol_wanted)
223        ; reportFlats ctxt2 (mapBag (tidyCt env) flats)
224             -- All the Derived ones have been filtered out of flats
225             -- by the constraint solver. This is ok; we don't want
226             -- to report unsolved Derived goals as errors
227             -- See Note [Do not report derived but soluble errors]
228        ; mapBagM_ (reportImplic ctxt1) implics }
229             -- NB ctxt1: don't suppress inner insolubles if there's only a
230             -- wanted insoluble here; but do suppress inner insolubles
231             -- if there's a given insoluble here (= inaccessible code)
232  where
233     (insol_given, insol_wanted) = partitionBag isGivenCt insols
234     env = cec_tidy ctxt
235
236       -- See Note [Suppressing error messages]
237     suppress0 = cec_suppress ctxt
238     suppress1 = suppress0 || not (isEmptyBag insol_given)
239     suppress2 = suppress0 || insolubleWC wanted
240     ctxt1     = ctxt { cec_suppress = suppress1 }
241     ctxt2     = ctxt { cec_suppress = suppress2 }
242
243 reportFlats :: ReportErrCtxt -> Cts -> TcM ()
244 reportFlats ctxt flats    -- Here 'flats' includes insolble goals
245   =  traceTc "reportFlats" (vcat [ ptext (sLit "Flats =") <+> ppr flats
246                                  , ptext (sLit "Suppress =") <+> ppr (cec_suppress ctxt)])
247   >> tryReporters
248       [ -- First deal with things that are utterly wrong
249         -- Like Int ~ Bool (incl nullary TyCons)
250         -- or  Int ~ t a   (AppTy on one side)
251         ("Utterly wrong",  utterly_wrong,   True, mkGroupReporter mkEqErr)
252       , ("Holes",          is_hole,         True, mkHoleReporter mkHoleError)
253
254         -- Report equalities of form (a~ty).  They are usually
255         -- skolem-equalities, and they cause confusing knock-on
256         -- effects in other errors; see test T4093b.
257       , ("Skolem equalities", skolem_eq,  True,  mkSkolReporter)
258
259         -- Other equalities; also confusing knock on effects
260       , ("Equalities",      is_equality, True,  mkGroupReporter mkEqErr)
261
262       , ("Implicit params", is_ip,       False, mkGroupReporter mkIPErr)
263       , ("Irreds",          is_irred,    False, mkGroupReporter mkIrredErr)
264       , ("Dicts",           is_dict,     False, mkGroupReporter mkDictErr)
265       ]
266       panicReporter ctxt (bagToList flats)
267           -- TuplePreds should have been expanded away by the constraint
268           -- simplifier, so they shouldn't show up at this point
269   where
270     utterly_wrong, skolem_eq, is_hole, is_dict,
271       is_equality, is_ip, is_irred :: Ct -> PredTree -> Bool
272
273     utterly_wrong _ (EqPred ty1 ty2) = isRigid ty1 && isRigid ty2
274     utterly_wrong _ _ = False
275
276     is_hole ct _ = isHoleCt ct
277
278     skolem_eq _ (EqPred ty1 ty2) = isRigidOrSkol ty1 && isRigidOrSkol ty2
279     skolem_eq _ _ = False
280
281     is_equality _ (EqPred {}) = True
282     is_equality _ _           = False
283
284     is_dict _ (ClassPred {}) = True
285     is_dict _ _              = False
286
287     is_ip _ (ClassPred cls _) = isIPClass cls
288     is_ip _ _                 = False
289
290     is_irred _ (IrredPred {}) = True
291     is_irred _ _              = False
292
293
294 ---------------
295 isRigid, isRigidOrSkol :: Type -> Bool
296 isRigid ty
297   | Just (tc,_) <- tcSplitTyConApp_maybe ty = isDecomposableTyCon tc
298   | Just {} <- tcSplitAppTy_maybe ty        = True
299   | isForAllTy ty                           = True
300   | otherwise                               = False
301
302 isRigidOrSkol ty
303   | Just tv <- getTyVar_maybe ty = isSkolemTyVar tv
304   | otherwise                    = isRigid ty
305
306 isTyFun_maybe :: Type -> Maybe TyCon
307 isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of
308                       Just (tc,_) | isTypeFamilyTyCon tc -> Just tc
309                       _ -> Nothing
310
311
312 --------------------------------------------
313 --      Reporters
314 --------------------------------------------
315
316 type Reporter
317   = ReportErrCtxt -> [Ct] -> TcM ()
318 type ReporterSpec
319   = ( String                     -- Name
320     , Ct -> PredTree -> Bool     -- Pick these ones
321     , Bool                       -- True <=> suppress subsequent reporters
322     , Reporter)                  -- The reporter itself
323
324 panicReporter :: Reporter
325 panicReporter _ cts
326   | null cts  = return ()
327   | otherwise =  pprPanic "reportFlats" (ppr cts)
328
329 mkSkolReporter :: Reporter
330 -- Suppress duplicates with the same LHS
331 mkSkolReporter ctxt cts
332   = mapM_ (reportGroup mkEqErr ctxt) (equivClasses cmp_lhs_type cts)
333   where
334     cmp_lhs_type ct1 ct2
335       = case (classifyPredType (ctPred ct1), classifyPredType (ctPred ct2)) of
336            (EqPred ty1 _, EqPred ty2 _) -> ty1 `cmpType` ty2
337            _ -> pprPanic "mkSkolReporter" (ppr ct1 $$ ppr ct2)
338
339 mkHoleReporter :: (ReportErrCtxt -> Ct -> TcM ErrMsg) -> Reporter
340 -- Reports errors one at a time
341 mkHoleReporter mk_err ctxt
342   = mapM_ $ \ct ->
343     do { err <- mk_err ctxt ct
344        ; maybeReportHoleError ctxt err
345        ; maybeAddDeferredHoleBinding ctxt err ct }
346
347 mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg)
348                              -- Make error message for a group
349                 -> Reporter  -- Deal with lots of constraints
350 -- Group together errors from same location,
351 -- and report only the first (to avoid a cascade)
352 mkGroupReporter mk_err ctxt cts
353   = mapM_ (reportGroup mk_err ctxt) (equivClasses cmp_loc cts)
354   where
355     cmp_loc ct1 ct2 = ctLocSpan (ctLoc ct1) `compare` ctLocSpan (ctLoc ct2)
356
357 reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> ReportErrCtxt
358             -> [Ct] -> TcM ()
359 reportGroup mk_err ctxt cts
360   = do { err <- mk_err ctxt cts
361        ; maybeReportError ctxt err
362        ; mapM_ (maybeAddDeferredBinding ctxt err) cts }
363                -- Add deferred bindings for all
364                -- But see Note [Always warn with -fdefer-type-errors]
365
366 maybeReportHoleError :: ReportErrCtxt -> ErrMsg -> TcM ()
367 maybeReportHoleError ctxt err
368   | cec_defer_holes ctxt
369   = when (cec_warn_holes ctxt)
370             (reportWarning (makeIntoWarning err))
371   | otherwise
372   = reportError err
373
374 maybeReportError :: ReportErrCtxt -> ErrMsg -> TcM ()
375 -- Report the error and/or make a deferred binding for it
376 maybeReportError ctxt err
377   -- See Note [Always warn with -fdefer-type-errors]
378   | cec_defer_type_errors ctxt
379   = reportWarning (makeIntoWarning err)
380   | cec_suppress ctxt
381   = return ()
382   | otherwise
383   = reportError err
384
385 addDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
386 -- See Note [Deferring coercion errors to runtime]
387 addDeferredBinding ctxt err ct
388   | CtWanted { ctev_pred = pred, ctev_evar = ev_id } <- ctEvidence ct
389     -- Only add deferred bindings for Wanted constraints
390   , Just ev_binds_var <- cec_binds ctxt  -- We have somewhere to put the bindings
391   = do { dflags <- getDynFlags
392        ; let err_msg = pprLocErrMsg err
393              err_fs  = mkFastString $ showSDoc dflags $
394                        err_msg $$ text "(deferred type error)"
395
396          -- Create the binding
397        ; addTcEvBind ev_binds_var ev_id (EvDelayedError pred err_fs) }
398
399   | otherwise   -- Do not set any evidence for Given/Derived
400   = return ()
401
402 maybeAddDeferredHoleBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
403 maybeAddDeferredHoleBinding ctxt err ct
404     | cec_defer_holes ctxt
405     = addDeferredBinding ctxt err ct
406     | otherwise
407     = return ()
408
409 maybeAddDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
410 maybeAddDeferredBinding ctxt err ct
411     | cec_defer_type_errors ctxt
412     = addDeferredBinding ctxt err ct
413     | otherwise
414     = return ()
415
416 tryReporters :: [ReporterSpec] -> Reporter -> Reporter
417 -- Use the first reporter in the list whose predicate says True
418 tryReporters reporters deflt ctxt cts
419   = do { traceTc "tryReporters {" (ppr cts)
420        ; go ctxt reporters cts
421        ; traceTc "tryReporters }" empty }
422   where
423     go ctxt [] cts = deflt ctxt cts
424     go ctxt ((str, pred, suppress_after, reporter) : rs) cts
425       | null yeses  = do { traceTc "tryReporters: no" (text str)
426                          ; go ctxt rs cts }
427       | otherwise   = do { traceTc "tryReporters: yes" (text str <+> ppr yeses)
428                          ; reporter ctxt yeses :: TcM ()
429                          ; let ctxt' = ctxt { cec_suppress = suppress_after || cec_suppress ctxt }
430                          ; go ctxt' rs nos }
431                          -- Carry on with the rest, because we must make
432                          -- deferred bindings for them if we have
433                          -- -fdefer-type-errors
434                          -- But suppress their error messages
435       where
436        (yeses, nos) = partition keep_me cts
437        keep_me ct = pred ct (classifyPredType (ctPred ct))
438
439 -- Add the "arising from..." part to a message about bunch of dicts
440 addArising :: CtOrigin -> SDoc -> SDoc
441 addArising orig msg = hang msg 2 (pprArising orig)
442
443 pprWithArising :: [Ct] -> (CtLoc, SDoc)
444 -- Print something like
445 --    (Eq a) arising from a use of x at y
446 --    (Show a) arising from a use of p at q
447 -- Also return a location for the error message
448 -- Works for Wanted/Derived only
449 pprWithArising []
450   = panic "pprWithArising"
451 pprWithArising (ct:cts)
452   | null cts
453   = (loc, addArising (ctLocOrigin loc)
454                      (pprTheta [ctPred ct]))
455   | otherwise
456   = (loc, vcat (map ppr_one (ct:cts)))
457   where
458     loc = ctLoc ct
459     ppr_one ct' = hang (parens (pprType (ctPred ct')))
460                      2 (pprArisingAt (ctLoc ct'))
461
462 mkErrorMsg :: ReportErrCtxt -> Ct -> SDoc -> TcM ErrMsg
463 mkErrorMsg ctxt ct msg
464   = do { let tcl_env = ctLocEnv (ctLoc ct)
465        ; err_info <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)
466        ; mkLongErrAt (tcl_loc tcl_env) msg err_info }
467
468 type UserGiven = ([EvVar], SkolemInfo, Bool, SrcSpan)
469
470 getUserGivens :: ReportErrCtxt -> [UserGiven]
471 -- One item for each enclosing implication
472 getUserGivens (CEC {cec_encl = ctxt})
473   = reverse $
474     [ (givens, info, no_eqs, tcl_loc env)
475     | Implic { ic_given = givens, ic_env = env
476              , ic_no_eqs = no_eqs, ic_info = info } <- ctxt
477     , not (null givens) ]
478 \end{code}
479
480 Note [Always warn with -fdefer-type-errors]
481 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
482 When -fdefer-type-errors is on we warn about *all* type errors, even
483 if cec_suppress is on.  This can lead to a lot more warnings than you
484 would get errors without -fdefer-type-errors, but if we suppress any of
485 them you might get a runtime error that wasn't warned about at compile
486 time.
487
488 This is an easy design choice to change; just flip the order of the
489 first two equations for maybeReportError
490
491 To be consistent, we should also report multiple warnings from a single
492 location in mkGroupReporter, when -fdefer-type-errors is on.  But that
493 is perhaps a bit *over*-consistent! Again, an easy choice to change.
494
495
496 Note [Do not report derived but soluble errors]
497 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
498 The wc_flats include Derived constraints that have not been solved, but are
499 not insoluble (in that case they'd be in wc_insols).  We do not want to report
500 these as errors:
501
502 * Superclass constraints. If we have an unsolved [W] Ord a, we'll also have
503   an unsolved [D] Eq a, and we do not want to report that; it's just noise.
504
505 * Functional dependencies.  For givens, consider
506       class C a b | a -> b
507       data T a where
508          MkT :: C a d => [d] -> T a
509       f :: C a b => T a -> F Int
510       f (MkT xs) = length xs
511   Then we get a [D] b~d.  But there *is* a legitimate call to
512   f, namely   f (MkT [True]) :: T Bool, in which b=d.  So we should
513   not reject the program.
514
515   For wanteds, something similar
516       data T a where
517         MkT :: C Int b => a -> b -> T a
518       g :: C Int c => c -> ()
519       f :: T a -> ()
520       f (MkT x y) = g x
521   Here we get [G] C Int b, [W] C Int a, hence [D] a~b.
522   But again f (MkT True True) is a legitimate call.
523
524 (We leave the Deriveds in wc_flat until reportErrors, so that we don't lose
525 derived superclasses between iterations of the solver.)
526
527 For functional dependencies, here is a real example,
528 stripped off from libraries/utf8-string/Codec/Binary/UTF8/Generic.hs
529
530   class C a b | a -> b
531   g :: C a b => a -> b -> ()
532   f :: C a b => a -> b -> ()
533   f xa xb =
534       let loop = g xa
535       in loop xb
536
537 We will first try to infer a type for loop, and we will succeed:
538     C a b' => b' -> ()
539 Subsequently, we will type check (loop xb) and all is good. But,
540 recall that we have to solve a final implication constraint:
541     C a b => (C a b' => .... cts from body of loop .... ))
542 And now we have a problem as we will generate an equality b ~ b' and fail to
543 solve it.
544
545
546 %************************************************************************
547 %*                  *
548                 Irreducible predicate errors
549 %*                  *
550 %************************************************************************
551
552 \begin{code}
553 mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
554 mkIrredErr ctxt cts
555   = do { (ctxt, binds_msg) <- relevantBindings True ctxt ct1
556        ; mkErrorMsg ctxt ct1 (msg $$ binds_msg) }
557   where
558     (ct1:_) = cts
559     orig    = ctLocOrigin (ctLoc ct1)
560     givens  = getUserGivens ctxt
561     msg = couldNotDeduce givens (map ctPred cts, orig)
562
563 ----------------
564 mkHoleError :: ReportErrCtxt -> Ct -> TcM ErrMsg
565 mkHoleError ctxt ct@(CHoleCan { cc_occ = occ })
566   = do { let tyvars = varSetElems (tyVarsOfCt ct)
567              tyvars_msg = map loc_msg tyvars
568              msg = vcat [ hang (ptext (sLit "Found hole") <+> quotes (ppr occ))
569                              2 (ptext (sLit "with type:") <+> pprType (ctEvPred (ctEvidence ct)))
570                         , ppUnless (null tyvars_msg) (ptext (sLit "Where:") <+> vcat tyvars_msg) ]
571        ; (ctxt, binds_doc) <- relevantBindings False ctxt ct
572                -- The 'False' means "don't filter the bindings; see Trac #8191
573        ; mkErrorMsg ctxt ct (msg $$ binds_doc) }
574   where
575     loc_msg tv
576        = case tcTyVarDetails tv of
577           SkolemTv {} -> quotes (ppr tv) <+> skol_msg
578           MetaTv {}   -> quotes (ppr tv) <+> ptext (sLit "is an ambiguous type variable")
579           det -> pprTcTyVarDetails det
580        where
581           skol_msg = pprSkol (getSkolemInfo (cec_encl ctxt) tv) (getSrcLoc tv)
582
583 mkHoleError _ ct = pprPanic "mkHoleError" (ppr ct)
584
585 ----------------
586 mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
587 mkIPErr ctxt cts
588   = do { (ctxt, bind_msg) <- relevantBindings True ctxt ct1
589        ; mkErrorMsg ctxt ct1 (msg $$ bind_msg) }
590   where
591     (ct1:_) = cts
592     orig    = ctLocOrigin (ctLoc ct1)
593     preds   = map ctPred cts
594     givens  = getUserGivens ctxt
595     msg | null givens
596         = addArising orig $
597           sep [ ptext (sLit "Unbound implicit parameter") <> plural cts
598               , nest 2 (pprTheta preds) ]
599         | otherwise
600         = couldNotDeduce givens (preds, orig)
601 \end{code}
602
603
604 %************************************************************************
605 %*                                                                      *
606                 Equality errors
607 %*                                                                      *
608 %************************************************************************
609
610 Note [Inaccessible code]
611 ~~~~~~~~~~~~~~~~~~~~~~~~
612 Consider
613    data T a where
614      T1 :: T a
615      T2 :: T Bool
616
617    f :: (a ~ Int) => T a -> Int
618    f T1 = 3
619    f T2 = 4   -- Unreachable code
620
621 Here the second equation is unreachable. The original constraint
622 (a~Int) from the signature gets rewritten by the pattern-match to
623 (Bool~Int), so the danger is that we report the error as coming from
624 the *signature* (Trac #7293).  So, for Given errors we replace the
625 env (and hence src-loc) on its CtLoc with that from the immediately
626 enclosing implication.
627
628 \begin{code}
629 mkEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
630 -- Don't have multiple equality errors from the same location
631 -- E.g.   (Int,Bool) ~ (Bool,Int)   one error will do!
632 mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct
633 mkEqErr _ [] = panic "mkEqErr"
634
635 mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg
636 -- Wanted constraints only!
637 mkEqErr1 ctxt ct
638   | isGiven ev
639   = do { (ctxt, binds_msg) <- relevantBindings True ctxt ct
640        ; let (given_loc, given_msg) = mk_given (cec_encl ctxt)
641        ; dflags <- getDynFlags
642        ; mkEqErr_help dflags ctxt (given_msg $$ binds_msg)
643                       (ct { cc_ev = ev {ctev_loc = given_loc}}) -- Note [Inaccessible code]
644                       Nothing ty1 ty2 }
645
646   | otherwise   -- Wanted or derived
647   = do { (ctxt, binds_msg) <- relevantBindings True ctxt ct
648        ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc)
649        ; let (is_oriented, wanted_msg) = mk_wanted_extra tidy_orig
650        ; dflags <- getDynFlags
651        ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctLocOrigin loc) $$ pprCtOrigin tidy_orig) 
652        ; mkEqErr_help dflags (ctxt {cec_tidy = env1})
653                       (wanted_msg $$ binds_msg)
654                       ct is_oriented ty1 ty2 }
655   where
656     ev         = ctEvidence ct
657     loc        = ctEvLoc ev
658     (ty1, ty2) = getEqPredTys (ctEvPred ev)
659
660     mk_given :: [Implication] -> (CtLoc, SDoc)
661     -- For given constraints we overwrite the env (and hence src-loc)
662     -- with one from the implication.  See Note [Inaccessible code]
663     mk_given []           = (loc, empty)
664     mk_given (implic : _) = (setCtLocEnv loc (ic_env implic)
665                             , hang (ptext (sLit "Inaccessible code in"))
666                                  2 (ppr (ic_info implic)))
667
668        -- If the types in the error message are the same as the types
669        -- we are unifying, don't add the extra expected/actual message
670     mk_wanted_extra orig@(TypeEqOrigin {})
671       = mkExpectedActualMsg ty1 ty2 orig
672
673     mk_wanted_extra (KindEqOrigin cty1 cty2 sub_o)
674       = (Nothing, msg1 $$ msg2)
675       where
676         msg1 = hang (ptext (sLit "When matching types"))
677                   2 (vcat [ ppr cty1 <+> dcolon <+> ppr (typeKind cty1)
678                           , ppr cty2 <+> dcolon <+> ppr (typeKind cty2) ])
679         msg2 = case sub_o of
680                  TypeEqOrigin {} -> snd (mkExpectedActualMsg cty1 cty2 sub_o)
681                  _ -> empty
682
683     mk_wanted_extra orig@(FunDepOrigin1 {}) = (Nothing, pprArising orig)
684     mk_wanted_extra orig@(FunDepOrigin2 {}) = (Nothing, pprArising orig)
685     mk_wanted_extra _                       = (Nothing, empty)
686
687 mkEqErr_help :: DynFlags -> ReportErrCtxt -> SDoc
688              -> Ct
689              -> Maybe SwapFlag   -- Nothing <=> not sure
690              -> TcType -> TcType -> TcM ErrMsg
691 mkEqErr_help dflags ctxt extra ct oriented ty1 ty2
692   | Just tv1 <- tcGetTyVar_maybe ty1 = mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2
693   | Just tv2 <- tcGetTyVar_maybe ty2 = mkTyVarEqErr dflags ctxt extra ct swapped  tv2 ty1
694   | otherwise                        = reportEqErr  ctxt extra ct oriented ty1 ty2
695   where
696     swapped = fmap flipSwap oriented
697
698 reportEqErr :: ReportErrCtxt -> SDoc
699             -> Ct
700             -> Maybe SwapFlag   -- Nothing <=> not sure
701             -> TcType -> TcType -> TcM ErrMsg
702 reportEqErr ctxt extra1 ct oriented ty1 ty2
703   = do { let extra2 = mkEqInfoMsg ct ty1 ty2
704        ; mkErrorMsg ctxt ct (vcat [ misMatchOrCND ctxt ct oriented ty1 ty2
705                                    , extra2, extra1]) }
706
707 mkTyVarEqErr :: DynFlags -> ReportErrCtxt -> SDoc -> Ct
708              -> Maybe SwapFlag -> TcTyVar -> TcType -> TcM ErrMsg
709 -- tv1 and ty2 are already tidied
710 mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2
711   | isUserSkolem ctxt tv1   -- ty2 won't be a meta-tyvar, or else the thing would
712                             -- be oriented the other way round;
713                             -- see TcCanonical.canEqTyVarTyVar
714   || isSigTyVar tv1 && not (isTyVarTy ty2)
715   = mkErrorMsg ctxt ct (vcat [ misMatchOrCND ctxt ct oriented ty1 ty2
716                              , extraTyVarInfo ctxt tv1 ty2
717                              , extra ])
718
719   -- So tv is a meta tyvar (or started that way before we
720   -- generalised it).  So presumably it is an *untouchable*
721   -- meta tyvar or a SigTv, else it'd have been unified
722   | not (k2 `tcIsSubKind` k1)            -- Kind error
723   = mkErrorMsg ctxt ct $ (kindErrorMsg (mkTyVarTy tv1) ty2 $$ extra)
724
725   | OC_Occurs <- occ_check_expand
726   = do { let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:")
727                               2 (sep [ppr ty1, char '~', ppr ty2])
728              extra2 = mkEqInfoMsg ct ty1 ty2
729        ; mkErrorMsg ctxt ct (occCheckMsg $$ extra2 $$ extra) }
730
731   | OC_Forall <- occ_check_expand
732   = do { let msg = vcat [ ptext (sLit "Cannot instantiate unification variable")
733                           <+> quotes (ppr tv1)
734                         , hang (ptext (sLit "with a type involving foralls:")) 2 (ppr ty2)
735                         , nest 2 (ptext (sLit "Perhaps you want ImpredicativeTypes")) ]
736        ; mkErrorMsg ctxt ct msg }
737
738   -- If the immediately-enclosing implication has 'tv' a skolem, and
739   -- we know by now its an InferSkol kind of skolem, then presumably
740   -- it started life as a SigTv, else it'd have been unified, given
741   -- that there's no occurs-check or forall problem
742   | (implic:_) <- cec_encl ctxt
743   , Implic { ic_skols = skols } <- implic
744   , tv1 `elem` skols
745   = mkErrorMsg ctxt ct (vcat [ misMatchMsg oriented ty1 ty2
746                              , extraTyVarInfo ctxt tv1 ty2
747                              , extra ])
748
749   -- Check for skolem escape
750   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
751   , Implic { ic_env = env, ic_skols = skols, ic_info = skol_info } <- implic
752   , let esc_skols = filter (`elemVarSet` (tyVarsOfType ty2)) skols
753   , not (null esc_skols)
754   = do { let msg = misMatchMsg oriented ty1 ty2
755              esc_doc = sep [ ptext (sLit "because type variable") <> plural esc_skols
756                              <+> pprQuotedList esc_skols
757                            , ptext (sLit "would escape") <+>
758                              if isSingleton esc_skols then ptext (sLit "its scope")
759                                                       else ptext (sLit "their scope") ]
760              tv_extra = vcat [ nest 2 $ esc_doc
761                              , sep [ (if isSingleton esc_skols
762                                       then ptext (sLit "This (rigid, skolem) type variable is")
763                                       else ptext (sLit "These (rigid, skolem) type variables are"))
764                                <+> ptext (sLit "bound by")
765                              , nest 2 $ ppr skol_info
766                              , nest 2 $ ptext (sLit "at") <+> ppr (tcl_loc env) ] ]
767        ; mkErrorMsg ctxt ct (msg $$ tv_extra $$ extra) }
768
769   -- Nastiest case: attempt to unify an untouchable variable
770   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
771   , Implic { ic_env = env, ic_given = given, ic_info = skol_info } <- implic
772   = do { let msg = misMatchMsg oriented ty1 ty2
773              untch_extra
774                 = nest 2 $
775                   sep [ quotes (ppr tv1) <+> ptext (sLit "is untouchable")
776                       , nest 2 $ ptext (sLit "inside the constraints") <+> pprEvVarTheta given
777                       , nest 2 $ ptext (sLit "bound by") <+> ppr skol_info
778                       , nest 2 $ ptext (sLit "at") <+> ppr (tcl_loc env) ]
779              tv_extra = extraTyVarInfo ctxt tv1 ty2
780              add_sig  = suggestAddSig ctxt ty1 ty2
781        ; mkErrorMsg ctxt ct (vcat [msg, untch_extra, tv_extra, add_sig, extra]) }
782
783   | otherwise
784   = reportEqErr ctxt extra ct oriented (mkTyVarTy tv1) ty2
785         -- This *can* happen (Trac #6123, and test T2627b)
786         -- Consider an ambiguous top-level constraint (a ~ F a)
787         -- Not an occurs check, because F is a type function.
788   where
789     occ_check_expand = occurCheckExpand dflags tv1 ty2
790     k1  = tyVarKind tv1
791     k2  = typeKind ty2
792     ty1 = mkTyVarTy tv1
793
794 mkEqInfoMsg :: Ct -> TcType -> TcType -> SDoc
795 -- Report (a) ambiguity if either side is a type function application
796 --            e.g. F a0 ~ Int
797 --        (b) warning about injectivity if both sides are the same
798 --            type function application   F a ~ F b
799 --            See Note [Non-injective type functions]
800 mkEqInfoMsg ct ty1 ty2
801   = tyfun_msg $$ ambig_msg
802   where
803     mb_fun1 = isTyFun_maybe ty1
804     mb_fun2 = isTyFun_maybe ty2
805
806     ambig_msg | isJust mb_fun1 || isJust mb_fun2
807               = snd (mkAmbigMsg ct)
808               | otherwise = empty
809
810     tyfun_msg | Just tc1 <- mb_fun1
811               , Just tc2 <- mb_fun2
812               , tc1 == tc2
813               = ptext (sLit "NB:") <+> quotes (ppr tc1)
814                 <+> ptext (sLit "is a type function, and may not be injective")
815               | otherwise = empty
816
817 isUserSkolem :: ReportErrCtxt -> TcTyVar -> Bool
818 -- See Note [Reporting occurs-check errors]
819 isUserSkolem ctxt tv
820   = isSkolemTyVar tv && any is_user_skol_tv (cec_encl ctxt)
821   where
822     is_user_skol_tv (Implic { ic_skols = sks, ic_info = skol_info })
823       = tv `elem` sks && is_user_skol_info skol_info
824
825     is_user_skol_info (InferSkol {}) = False
826     is_user_skol_info _ = True
827
828 misMatchOrCND :: ReportErrCtxt -> Ct -> Maybe SwapFlag -> TcType -> TcType -> SDoc
829 -- If oriented then ty1 is actual, ty2 is expected
830 misMatchOrCND ctxt ct oriented ty1 ty2
831   | null givens ||
832     (isRigid ty1 && isRigid ty2) ||
833     isGivenCt ct
834        -- If the equality is unconditionally insoluble
835        -- or there is no context, don't report the context
836   = misMatchMsg oriented ty1 ty2
837   | otherwise
838   = couldNotDeduce givens ([mkTcEqPred ty1 ty2], orig)
839   where
840     givens = [ given | given@(_, _, no_eqs, _) <- getUserGivens ctxt, not no_eqs]
841              -- Keep only UserGivens that have some equalities
842     orig   = TypeEqOrigin { uo_actual = ty1, uo_expected = ty2 }
843
844 couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc
845 couldNotDeduce givens (wanteds, orig)
846   = vcat [ addArising orig (ptext (sLit "Could not deduce") <+> pprTheta wanteds)
847          , vcat (pp_givens givens)]
848
849 pp_givens :: [UserGiven] -> [SDoc]
850 pp_givens givens
851    = case givens of
852          []     -> []
853          (g:gs) ->      ppr_given (ptext (sLit "from the context")) g
854                  : map (ppr_given (ptext (sLit "or from"))) gs
855     where
856        ppr_given herald (gs, skol_info, _, loc)
857            = hang (herald <+> pprEvVarTheta gs)
858                 2 (sep [ ptext (sLit "bound by") <+> ppr skol_info
859                        , ptext (sLit "at") <+> ppr loc])
860
861 extraTyVarInfo :: ReportErrCtxt -> TcTyVar -> TcType -> SDoc
862 -- Add on extra info about skolem constants
863 -- NB: The types themselves are already tidied
864 extraTyVarInfo ctxt tv1 ty2
865   = nest 2 (tv_extra tv1 $$ ty_extra ty2)
866   where
867     implics = cec_encl ctxt
868     ty_extra ty = case tcGetTyVar_maybe ty of
869                     Just tv -> tv_extra tv
870                     Nothing -> empty
871
872     tv_extra tv | isTcTyVar tv, isSkolemTyVar tv
873                 , let pp_tv = quotes (ppr tv)
874                 = case tcTyVarDetails tv of
875                     SkolemTv {}   -> pp_tv <+> pprSkol (getSkolemInfo implics tv) (getSrcLoc tv)
876                     FlatSkol {}   -> pp_tv <+> ptext (sLit "is a flattening type variable")
877                     RuntimeUnk {} -> pp_tv <+> ptext (sLit "is an interactive-debugger skolem")
878                     MetaTv {}     -> empty
879
880                 | otherwise             -- Normal case
881                 = empty
882
883 suggestAddSig :: ReportErrCtxt -> TcType -> TcType -> SDoc
884 -- See Note [Suggest adding a type signature]
885 suggestAddSig ctxt ty1 ty2
886   | null inferred_bndrs
887   = empty
888   | [bndr] <- inferred_bndrs
889   = ptext (sLit "Possible fix: add a type signature for") <+> quotes (ppr bndr)
890   | otherwise
891   = ptext (sLit "Possible fix: add type signatures for some or all of") <+> (ppr inferred_bndrs)
892   where
893     inferred_bndrs = nub (get_inf ty1 ++ get_inf ty2)
894     get_inf ty | Just tv <- tcGetTyVar_maybe ty
895                , isTcTyVar tv, isSkolemTyVar tv
896                , InferSkol prs <- getSkolemInfo (cec_encl ctxt) tv
897                = map fst prs
898                | otherwise
899                = []
900
901 kindErrorMsg :: TcType -> TcType -> SDoc   -- Types are already tidy
902 kindErrorMsg ty1 ty2
903   = vcat [ ptext (sLit "Kind incompatibility when matching types:")
904          , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1
905                         , ppr ty2 <+> dcolon <+> ppr k2 ]) ]
906   where
907     k1 = typeKind ty1
908     k2 = typeKind ty2
909
910 --------------------
911 misMatchMsg :: Maybe SwapFlag -> TcType -> TcType -> SDoc          -- Types are already tidy
912 -- If oriented then ty1 is actual, ty2 is expected
913 misMatchMsg oriented ty1 ty2
914   | Just IsSwapped <- oriented
915   = misMatchMsg (Just NotSwapped) ty2 ty1
916   | Just NotSwapped <- oriented
917   = sep [ ptext (sLit "Couldn't match expected") <+> what <+> quotes (ppr ty2)
918         , nest 12 $   ptext (sLit "with actual") <+> what <+> quotes (ppr ty1)
919         , sameOccExtra ty2 ty1 ]
920   | otherwise
921   = sep [ ptext (sLit "Couldn't match") <+> what <+> quotes (ppr ty1)
922         , nest 14 $ ptext (sLit "with") <+> quotes (ppr ty2)
923         , sameOccExtra ty1 ty2 ]
924   where
925     what | isKind ty1 = ptext (sLit "kind")
926          | otherwise  = ptext (sLit "type")
927
928 mkExpectedActualMsg :: Type -> Type -> CtOrigin -> (Maybe SwapFlag, SDoc)
929 -- NotSwapped means (actual, expected), IsSwapped is the reverse
930 mkExpectedActualMsg ty1 ty2 (TypeEqOrigin { uo_actual = act, uo_expected = exp })
931   | act `pickyEqType` ty1, exp `pickyEqType` ty2 = (Just NotSwapped,  empty)
932   | exp `pickyEqType` ty1, act `pickyEqType` ty2 = (Just IsSwapped, empty)
933   | otherwise                                    = (Nothing, msg)
934   where
935     msg = vcat [ text "Expected type:" <+> ppr exp
936                , text "  Actual type:" <+> ppr act ]
937
938 mkExpectedActualMsg _ _ _ = panic "mkExprectedAcutalMsg"
939
940 sameOccExtra :: TcType -> TcType -> SDoc
941 -- See Note [Disambiguating (X ~ X) errors]
942 sameOccExtra ty1 ty2
943   | Just (tc1, _) <- tcSplitTyConApp_maybe ty1
944   , Just (tc2, _) <- tcSplitTyConApp_maybe ty2
945   , let n1 = tyConName tc1
946         n2 = tyConName tc2
947         same_occ = nameOccName n1                  == nameOccName n2
948         same_pkg = modulePackageKey (nameModule n1) == modulePackageKey (nameModule n2)
949   , n1 /= n2   -- Different Names
950   , same_occ   -- but same OccName
951   = ptext (sLit "NB:") <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2)
952   | otherwise
953   = empty
954   where
955     ppr_from same_pkg nm
956       | isGoodSrcSpan loc
957       = hang (quotes (ppr nm) <+> ptext (sLit "is defined at"))
958            2 (ppr loc)
959       | otherwise  -- Imported things have an UnhelpfulSrcSpan
960       = hang (quotes (ppr nm))
961            2 (sep [ ptext (sLit "is defined in") <+> quotes (ppr (moduleName mod))
962                   , ppUnless (same_pkg || pkg == mainPackageKey) $
963                     nest 4 $ ptext (sLit "in package") <+> quotes (ppr pkg) ])
964        where
965          pkg = modulePackageKey mod
966          mod = nameModule nm
967          loc = nameSrcSpan nm
968 \end{code}
969
970 Note [Suggest adding a type signature]
971 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
972 The OutsideIn algorithm rejects GADT programs that don't have a principal
973 type, and indeed some that do.  Example:
974    data T a where
975      MkT :: Int -> T Int
976
977    f (MkT n) = n
978
979 Does this have type f :: T a -> a, or f :: T a -> Int?
980 The error that shows up tends to be an attempt to unify an
981 untouchable type variable.  So suggestAddSig sees if the offending
982 type variable is bound by an *inferred* signature, and suggests
983 adding a declared signature instead.
984
985 This initially came up in Trac #8968, concerning pattern synonyms.
986
987 Note [Disambiguating (X ~ X) errors]
988 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
989 See Trac #8278
990
991 Note [Reporting occurs-check errors]
992 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
993 Given (a ~ [a]), if 'a' is a rigid type variable bound by a user-supplied
994 type signature, then the best thing is to report that we can't unify
995 a with [a], because a is a skolem variable.  That avoids the confusing
996 "occur-check" error message.
997
998 But nowadays when inferring the type of a function with no type signature,
999 even if there are errors inside, we still generalise its signature and
1000 carry on. For example
1001    f x = x:x
1002 Here we will infer somethiing like
1003    f :: forall a. a -> [a]
1004 with a suspended error of (a ~ [a]).  So 'a' is now a skolem, but not
1005 one bound by the programmer!  Here we really should report an occurs check.
1006
1007 So isUserSkolem distinguishes the two.
1008
1009 Note [Non-injective type functions]
1010 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1011 It's very confusing to get a message like
1012      Couldn't match expected type `Depend s'
1013             against inferred type `Depend s1'
1014 so mkTyFunInfoMsg adds:
1015        NB: `Depend' is type function, and hence may not be injective
1016
1017 Warn of loopy local equalities that were dropped.
1018
1019
1020 %************************************************************************
1021 %*                                                                      *
1022                  Type-class errors
1023 %*                                                                      *
1024 %************************************************************************
1025
1026 \begin{code}
1027 mkDictErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
1028 mkDictErr ctxt cts
1029   = ASSERT( not (null cts) )
1030     do { inst_envs <- tcGetInstEnvs
1031        ; fam_envs  <- tcGetFamInstEnvs
1032        ; let (ct1:_) = cts  -- ct1 just for its location
1033              min_cts = elim_superclasses cts
1034        ; lookups   <- mapM (lookup_cls_inst inst_envs) min_cts
1035        ; let (no_inst_cts, overlap_cts) = partition is_no_inst lookups
1036
1037        -- Report definite no-instance errors,
1038        -- or (iff there are none) overlap errors
1039        -- But we report only one of them (hence 'head') because they all
1040        -- have the same source-location origin, to try avoid a cascade
1041        -- of error from one location
1042        ; (ctxt, err) <- mk_dict_err fam_envs ctxt (head (no_inst_cts ++ overlap_cts))
1043        ; mkErrorMsg ctxt ct1 err }
1044   where
1045     no_givens = null (getUserGivens ctxt)
1046
1047     is_no_inst (ct, (matches, unifiers, _))
1048       =  no_givens
1049       && null matches
1050       && (null unifiers || all (not . isAmbiguousTyVar) (varSetElems (tyVarsOfCt ct)))
1051
1052     lookup_cls_inst inst_envs ct
1053       = do { tys_flat <- mapM quickFlattenTy tys
1054                 -- Note [Flattening in error message generation]
1055            ; return (ct, lookupInstEnv inst_envs clas tys_flat) }
1056       where
1057         (clas, tys) = getClassPredTys (ctPred ct)
1058
1059
1060     -- When simplifying [W] Ord (Set a), we need
1061     --    [W] Eq a, [W] Ord a
1062     -- but we really only want to report the latter
1063     elim_superclasses cts
1064       = filter (\ct -> any (eqPred (ctPred ct)) min_preds) cts
1065       where
1066         min_preds = mkMinimalBySCs (map ctPred cts)
1067
1068 mk_dict_err :: FamInstEnvs -> ReportErrCtxt -> (Ct, ClsInstLookupResult)
1069             -> TcM (ReportErrCtxt, SDoc)
1070 -- Report an overlap error if this class constraint results
1071 -- from an overlap (returning Left clas), otherwise return (Right pred)
1072 mk_dict_err fam_envs ctxt (ct, (matches, unifiers, safe_haskell))
1073   | null matches  -- No matches but perhaps several unifiers
1074   = do { let (is_ambig, ambig_msg) = mkAmbigMsg ct
1075        ; (ctxt, binds_msg) <- relevantBindings True ctxt ct
1076        ; traceTc "mk_dict_err" (ppr ct $$ ppr is_ambig $$ ambig_msg)
1077        ; rdr_env <- getGlobalRdrEnv
1078        ; return (ctxt, cannot_resolve_msg rdr_env is_ambig binds_msg ambig_msg) }
1079
1080   | not safe_haskell   -- Some matches => overlap errors
1081   = return (ctxt, overlap_msg)
1082
1083   | otherwise
1084   = return (ctxt, safe_haskell_msg)
1085   where
1086     orig        = ctLocOrigin (ctLoc ct)
1087     pred        = ctPred ct
1088     (clas, tys) = getClassPredTys pred
1089     ispecs      = [ispec | (ispec, _) <- matches]
1090     givens      = getUserGivens ctxt
1091     all_tyvars  = all isTyVarTy tys
1092
1093     cannot_resolve_msg rdr_env has_ambig_tvs binds_msg ambig_msg
1094       = vcat [ addArising orig (no_inst_msg $$ coercible_explanation rdr_env)
1095              , vcat (pp_givens givens)
1096              , ppWhen (has_ambig_tvs && not (null unifiers && null givens))
1097                (vcat [ ambig_msg, binds_msg, potential_msg ])
1098              , show_fixes (add_to_ctxt_fixes has_ambig_tvs ++ drv_fixes) ]
1099
1100     potential_msg
1101       = ppWhen (not (null unifiers) && want_potential orig) $
1102         hang (if isSingleton unifiers
1103               then ptext (sLit "Note: there is a potential instance available:")
1104               else ptext (sLit "Note: there are several potential instances:"))
1105            2 (ppr_insts (sortBy fuzzyClsInstCmp unifiers))
1106
1107     -- Report "potential instances" only when the constraint arises
1108     -- directly from the user's use of an overloaded function
1109     want_potential (TypeEqOrigin {}) = False
1110     want_potential _                 = True
1111
1112     add_to_ctxt_fixes has_ambig_tvs
1113       | not has_ambig_tvs && all_tyvars
1114       , (orig:origs) <- usefulContext ctxt pred 
1115       = [sep [ ptext (sLit "add") <+> pprParendType pred
1116                <+> ptext (sLit "to the context of")
1117              , nest 2 $ ppr_skol orig $$
1118                         vcat [ ptext (sLit "or") <+> ppr_skol orig
1119                              | orig <- origs ] ] ]
1120       | otherwise = []
1121
1122     ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc)
1123     ppr_skol skol_info      = ppr skol_info
1124
1125     no_inst_msg
1126       | clas == coercibleClass
1127       = let (ty1, ty2) = getEqPredTys pred
1128         in sep [ ptext (sLit "Could not coerce from") <+> quotes (ppr ty1)
1129                , nest 19 (ptext (sLit "to") <+> quotes (ppr ty2)) ]
1130                  -- The nesting makes the types line up
1131       | null givens && null matches
1132       = ptext (sLit "No instance for")
1133         <+> pprParendType pred
1134         $$ if type_has_arrow pred
1135             then nest 2 $ ptext (sLit "(maybe you haven't applied enough arguments to a function?)")
1136             else empty
1137
1138       | otherwise
1139       = ptext (sLit "Could not deduce") <+> pprParendType pred
1140
1141     type_has_arrow (TyVarTy _)      = False
1142     type_has_arrow (AppTy t1 t2)    = type_has_arrow t1 || type_has_arrow t2
1143     type_has_arrow (TyConApp _ ts)  = or $ map type_has_arrow ts
1144     type_has_arrow (FunTy _ _)      = True
1145     type_has_arrow (ForAllTy _ t)   = type_has_arrow t
1146     type_has_arrow (LitTy _)        = False
1147
1148     drv_fixes = case orig of
1149                    DerivOrigin      -> [drv_fix]
1150                    DerivOriginDC {} -> [drv_fix]
1151                    DerivOriginCoerce {} -> [drv_fix]
1152                    _                -> []
1153
1154     drv_fix = hang (ptext (sLit "use a standalone 'deriving instance' declaration,"))
1155                  2 (ptext (sLit "so you can specify the instance context yourself"))
1156
1157     -- Normal overlap error
1158     overlap_msg
1159       = ASSERT( not (null matches) )
1160         vcat [  addArising orig (ptext (sLit "Overlapping instances for")
1161                                 <+> pprType (mkClassPred clas tys))
1162
1163              ,  ppUnless (null matching_givens) $
1164                   sep [ptext (sLit "Matching givens (or their superclasses):")
1165                       , nest 2 (vcat matching_givens)]
1166
1167              ,  sep [ptext (sLit "Matching instances:"),
1168                      nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
1169
1170              ,  ppWhen (null matching_givens && isSingleton matches && null unifiers) $
1171                 -- Intuitively, some given matched the wanted in their
1172                 -- flattened or rewritten (from given equalities) form
1173                 -- but the matcher can't figure that out because the
1174                 -- constraints are non-flat and non-rewritten so we
1175                 -- simply report back the whole given
1176                 -- context. Accelerate Smart.hs showed this problem.
1177                   sep [ ptext (sLit "There exists a (perhaps superclass) match:")
1178                       , nest 2 (vcat (pp_givens givens))]
1179
1180              ,  ppWhen (isSingleton matches) $
1181                 parens (vcat [ ptext (sLit "The choice depends on the instantiation of") <+>
1182                                   quotes (pprWithCommas ppr (varSetElems (tyVarsOfTypes tys)))
1183                              , ppWhen (null (matching_givens)) $
1184                                vcat [ ptext (sLit "To pick the first instance above, use IncoherentInstances")
1185                                     , ptext (sLit "when compiling the other instance declarations")]
1186                         ])]
1187         where
1188             ispecs = [ispec | (ispec, _) <- matches]
1189
1190             givens = getUserGivens ctxt
1191             matching_givens = mapMaybe matchable givens
1192
1193             matchable (evvars,skol_info,_,loc)
1194               = case ev_vars_matching of
1195                      [] -> Nothing
1196                      _  -> Just $ hang (pprTheta ev_vars_matching)
1197                                     2 (sep [ ptext (sLit "bound by") <+> ppr skol_info
1198                                            , ptext (sLit "at") <+> ppr loc])
1199                 where ev_vars_matching = filter ev_var_matches (map evVarPred evvars)
1200                       ev_var_matches ty = case getClassPredTys_maybe ty of
1201                          Just (clas', tys')
1202                            | clas' == clas
1203                            , Just _ <- tcMatchTys (tyVarsOfTypes tys) tys tys'
1204                            -> True
1205                            | otherwise
1206                            -> any ev_var_matches (immSuperClasses clas' tys')
1207                          Nothing -> False
1208
1209     -- Overlap error because of Safe Haskell (first
1210     -- match should be the most specific match)
1211     safe_haskell_msg
1212       = ASSERT( length matches > 1 )
1213         vcat [ addArising orig (ptext (sLit "Unsafe overlapping instances for")
1214                         <+> pprType (mkClassPred clas tys))
1215              , sep [ptext (sLit "The matching instance is:"),
1216                     nest 2 (pprInstance $ head ispecs)]
1217              , vcat [ ptext $ sLit "It is compiled in a Safe module and as such can only"
1218                     , ptext $ sLit "overlap instances from the same module, however it"
1219                     , ptext $ sLit "overlaps the following instances from different modules:"
1220                     , nest 2 (vcat [pprInstances $ tail ispecs])
1221                     ]
1222              ]
1223
1224     -- This function tries to reconstruct why a "Coercible ty1 ty2" constraint
1225     -- is left over. Therefore its logic has to stay in sync with
1226     -- getCoericbleInst in TcInteract. See Note [Coercible Instances]
1227     coercible_explanation rdr_env
1228       | clas /= coercibleClass = empty
1229       | Just (tc1,tyArgs1) <- splitTyConApp_maybe ty1,
1230         Just (tc2,tyArgs2) <- splitTyConApp_maybe ty2,
1231         tc1 == tc2
1232       = nest 2 $ vcat $
1233           [ fsep [ hsep [ ptext $ sLit "because the", speakNth n, ptext $ sLit "type argument"]
1234                  , hsep [ ptext $ sLit "of", quotes (ppr tc1), ptext $ sLit "has role Nominal,"]
1235                  , ptext $ sLit "but the arguments"
1236                  , quotes (ppr t1)
1237                  , ptext $ sLit "and"
1238                  , quotes (ppr t2)
1239                  , ptext $ sLit "differ" ]
1240           | (n,Nominal,t1,t2) <- zip4 [1..] (tyConRoles tc1) tyArgs1 tyArgs2
1241           , not (t1 `eqType` t2)
1242           ]
1243       | Just (tc, tys) <- tcSplitTyConApp_maybe ty1
1244       , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys
1245       , Just msg <- coercible_msg_for_tycon rdr_env rep_tc
1246       = msg
1247       | Just (tc, tys) <- splitTyConApp_maybe ty2
1248       , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys
1249       , Just msg <- coercible_msg_for_tycon rdr_env rep_tc
1250       = msg
1251       | otherwise
1252       = nest 2 $ sep [ ptext (sLit "because") <+> quotes (ppr ty1)
1253                      , nest 4 (vcat [ ptext (sLit "and") <+> quotes (ppr ty2)
1254                                     , ptext (sLit "are different types.") ]) ]
1255       where
1256         (ty1, ty2) = getEqPredTys pred
1257
1258     coercible_msg_for_tycon rdr_env tc
1259         | isAbstractTyCon tc
1260         = Just $ hsep [ ptext $ sLit "because the type constructor", quotes (pprSourceTyCon tc)
1261                       , ptext $ sLit "is abstract" ]
1262         | isNewTyCon tc
1263         , [data_con] <- tyConDataCons tc
1264         , let dc_name = dataConName data_con
1265         , null (lookupGRE_Name rdr_env dc_name)
1266         = Just $ hang (ptext (sLit "because the data constructor") <+> quotes (ppr dc_name))
1267                     2 (sep [ ptext (sLit "of newtype") <+> quotes (pprSourceTyCon tc)
1268                            , ptext (sLit "is not in scope") ])
1269         | otherwise = Nothing
1270
1271 usefulContext :: ReportErrCtxt -> TcPredType -> [SkolemInfo]
1272 usefulContext ctxt pred
1273   = go (cec_encl ctxt)
1274   where
1275     pred_tvs = tyVarsOfType pred
1276     go [] = []
1277     go (ic : ics)
1278        = case ic_info ic of
1279                -- Do not suggest adding constraints to an *inferred* type signature!
1280            SigSkol (InfSigCtxt {}) _ -> rest
1281            info                      -> info : rest
1282        where
1283           -- Stop when the context binds a variable free in the predicate
1284           rest | any (`elemVarSet` pred_tvs) (ic_skols ic) = []
1285                | otherwise                                 = go ics
1286
1287 show_fixes :: [SDoc] -> SDoc
1288 show_fixes []     = empty
1289 show_fixes (f:fs) = sep [ ptext (sLit "Possible fix:")
1290                         , nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
1291
1292 ppr_insts :: [ClsInst] -> SDoc
1293 ppr_insts insts
1294   = pprInstances (take 3 insts) $$ dot_dot_message
1295   where
1296     n_extra = length insts - 3
1297     dot_dot_message
1298        | n_extra <= 0 = empty
1299        | otherwise    = ptext (sLit "...plus")
1300                         <+> speakNOf n_extra (ptext (sLit "other"))
1301
1302 ----------------------
1303 quickFlattenTy :: TcType -> TcM TcType
1304 -- See Note [Flattening in error message generation]
1305 quickFlattenTy ty | Just ty' <- tcView ty = quickFlattenTy ty'
1306 quickFlattenTy ty@(TyVarTy {})  = return ty
1307 quickFlattenTy ty@(ForAllTy {}) = return ty     -- See
1308 quickFlattenTy ty@(LitTy {})    = return ty
1309   -- Don't flatten because of the danger or removing a bound variable
1310 quickFlattenTy (AppTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
1311                                     ; fy2 <- quickFlattenTy ty2
1312                                     ; return (AppTy fy1 fy2) }
1313 quickFlattenTy (FunTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
1314                                     ; fy2 <- quickFlattenTy ty2
1315                                     ; return (FunTy fy1 fy2) }
1316 quickFlattenTy (TyConApp tc tys)
1317     | not (isTypeFamilyTyCon tc)
1318     = do { fys <- mapM quickFlattenTy tys
1319          ; return (TyConApp tc fys) }
1320     | otherwise
1321     = do { let (funtys,resttys) = splitAt (tyConArity tc) tys
1322                 -- Ignore the arguments of the type family funtys
1323          ; v <- newMetaTyVar TauTv (typeKind (TyConApp tc funtys))
1324          ; flat_resttys <- mapM quickFlattenTy resttys
1325          ; return (foldl AppTy (mkTyVarTy v) flat_resttys) }
1326 \end{code}
1327
1328 Note [Flattening in error message generation]
1329 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1330 Consider (C (Maybe (F x))), where F is a type function, and we have
1331 instances
1332                 C (Maybe Int) and C (Maybe a)
1333 Since (F x) might turn into Int, this is an overlap situation, and
1334 indeed (because of flattening) the main solver will have refrained
1335 from solving.  But by the time we get to error message generation, we've
1336 un-flattened the constraint.  So we must *re*-flatten it before looking
1337 up in the instance environment, lest we only report one matching
1338 instance when in fact there are two.
1339
1340 Re-flattening is pretty easy, because we don't need to keep track of
1341 evidence.  We don't re-use the code in TcCanonical because that's in
1342 the TcS monad, and we are in TcM here.
1343
1344 Note [Quick-flatten polytypes]
1345 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1346 If we see C (Ix a => blah) or C (forall a. blah) we simply refrain from
1347 flattening any further.  After all, there can be no instance declarations
1348 that match such things.  And flattening under a for-all is problematic
1349 anyway; consider C (forall a. F a)
1350
1351 Note [Suggest -fprint-explicit-kinds]
1352 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1353 It can be terribly confusing to get an error message like (Trac #9171)
1354     Couldn't match expected type ‘GetParam Base (GetParam Base Int)’
1355                 with actual type ‘GetParam Base (GetParam Base Int)’
1356 The reason may be that the kinds don't match up.  Typically you'll get
1357 more useful information, but not when it's as a result of ambiguity.
1358 This test suggests -fprint-explicit-kinds when all the ambiguous type
1359 variables are kind variables.
1360
1361 \begin{code}
1362 mkAmbigMsg :: Ct -> (Bool, SDoc)
1363 mkAmbigMsg ct
1364   | null ambig_tkvs = (False, empty)
1365   | otherwise       = (True,  msg)
1366   where
1367     ambig_tkv_set = filterVarSet isAmbiguousTyVar (tyVarsOfCt ct)
1368     ambig_tkvs    = varSetElems ambig_tkv_set
1369     (ambig_kvs, ambig_tvs) = partition isKindVar ambig_tkvs
1370
1371     msg | any isRuntimeUnkSkol ambig_tkvs  -- See Note [Runtime skolems]
1372         =  vcat [ ptext (sLit "Cannot resolve unknown runtime type") <> plural ambig_tvs
1373                      <+> pprQuotedList ambig_tvs
1374                 , ptext (sLit "Use :print or :force to determine these types")]
1375
1376         | not (null ambig_tvs)
1377         = pp_ambig (ptext (sLit "type")) ambig_tvs
1378
1379         | otherwise  -- All ambiguous kind variabes; suggest -fprint-explicit-kinds
1380         = vcat [ pp_ambig (ptext (sLit "kind")) ambig_kvs
1381                , sdocWithDynFlags suggest_explicit_kinds ]
1382
1383     pp_ambig what tkvs
1384       = ptext (sLit "The") <+> what <+> ptext (sLit "variable") <> plural tkvs
1385         <+> pprQuotedList tkvs <+> is_or_are tkvs <+> ptext (sLit "ambiguous")
1386
1387     is_or_are [_] = text "is"
1388     is_or_are _   = text "are"
1389
1390     suggest_explicit_kinds dflags  -- See Note [Suggest -fprint-explicit-kinds]
1391       | gopt Opt_PrintExplicitKinds dflags = empty
1392       | otherwise = ptext (sLit "Use -fprint-explicit-kinds to see the kind arguments")
1393
1394 pprSkol :: SkolemInfo -> SrcLoc -> SDoc
1395 pprSkol UnkSkol   _
1396   = ptext (sLit "is an unknown type variable")
1397 pprSkol skol_info tv_loc
1398   = sep [ ptext (sLit "is a rigid type variable bound by"),
1399           sep [ppr skol_info, ptext (sLit "at") <+> ppr tv_loc]]
1400
1401 getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo
1402 -- Get the skolem info for a type variable
1403 -- from the implication constraint that binds it
1404 getSkolemInfo [] tv
1405   = pprPanic "No skolem info:" (ppr tv)
1406
1407 getSkolemInfo (implic:implics) tv
1408   | tv `elem` ic_skols implic = ic_info implic
1409   | otherwise                 = getSkolemInfo implics tv
1410
1411 -----------------------
1412 -- relevantBindings looks at the value environment and finds values whose
1413 -- types mention any of the offending type variables.  It has to be
1414 -- careful to zonk the Id's type first, so it has to be in the monad.
1415 -- We must be careful to pass it a zonked type variable, too.
1416 --
1417 -- We always remove closed top-level bindings, though,
1418 -- since they are never relevant (cf Trac #8233)
1419
1420 relevantBindings :: Bool  -- True <=> filter by tyvar; False <=> no filtering
1421                           -- See Trac #8191
1422                  -> ReportErrCtxt -> Ct
1423                  -> TcM (ReportErrCtxt, SDoc)
1424 relevantBindings want_filtering ctxt ct
1425   = do { dflags <- getDynFlags
1426        ; (tidy_env', docs, discards)
1427               <- go (cec_tidy ctxt) (maxRelevantBinds dflags)
1428                     emptyVarSet [] False
1429                     (tcl_bndrs lcl_env)
1430          -- tcl_bndrs has the innermost bindings first,
1431          -- which are probably the most relevant ones
1432
1433        ; traceTc "relevantBindings" (ppr ct $$ ppr [id | TcIdBndr id _ <- tcl_bndrs lcl_env])
1434        ; let doc = hang (ptext (sLit "Relevant bindings include"))
1435                       2 (vcat docs $$ max_msg)
1436              max_msg | discards
1437                      = ptext (sLit "(Some bindings suppressed; use -fmax-relevant-binds=N or -fno-max-relevant-binds)")
1438                      | otherwise = empty
1439
1440        ; if null docs
1441          then return (ctxt, empty)
1442          else do { traceTc "rb" doc
1443                  ; return (ctxt { cec_tidy = tidy_env' }, doc) } }
1444   where
1445     loc       = ctLoc ct
1446     lcl_env   = ctLocEnv loc
1447     ct_tvs    = tyVarsOfCt ct `unionVarSet` extra_tvs
1448
1449     -- For *kind* errors, report the relevant bindings of the
1450     -- enclosing *type* equality, becuase that's more useful for the programmer
1451     extra_tvs = case ctLocOrigin loc of
1452                   KindEqOrigin t1 t2 _ -> tyVarsOfTypes [t1,t2]
1453                   _                    -> emptyVarSet
1454
1455     run_out :: Maybe Int -> Bool
1456     run_out Nothing = False
1457     run_out (Just n) = n <= 0
1458
1459     dec_max :: Maybe Int -> Maybe Int
1460     dec_max = fmap (\n -> n - 1)
1461
1462     go :: TidyEnv -> Maybe Int -> TcTyVarSet -> [SDoc]
1463        -> Bool                          -- True <=> some filtered out due to lack of fuel
1464        -> [TcIdBinder]
1465        -> TcM (TidyEnv, [SDoc], Bool)   -- The bool says if we filtered any out
1466                                         -- because of lack of fuel
1467     go tidy_env _ _ docs discards []
1468        = return (tidy_env, reverse docs, discards)
1469     go tidy_env n_left tvs_seen docs discards (TcIdBndr id top_lvl : tc_bndrs)
1470        = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id)
1471             ; traceTc "relevantBindings 1" (ppr id <+> dcolon <+> ppr tidy_ty)
1472             ; let id_tvs = tyVarsOfType tidy_ty
1473                   doc = sep [ pprPrefixOcc id <+> dcolon <+> ppr tidy_ty
1474                             , nest 2 (parens (ptext (sLit "bound at")
1475                                  <+> ppr (getSrcLoc id)))]
1476                   new_seen = tvs_seen `unionVarSet` id_tvs
1477
1478             ; if (want_filtering && not opt_PprStyle_Debug 
1479                                  && id_tvs `disjointVarSet` ct_tvs)
1480                        -- We want to filter out this binding anyway
1481                        -- so discard it silently
1482               then go tidy_env n_left tvs_seen docs discards tc_bndrs
1483
1484               else if isTopLevel top_lvl && not (isNothing n_left)
1485                        -- It's a top-level binding and we have not specified
1486                        -- -fno-max-relevant-bindings, so discard it silently
1487               then go tidy_env n_left tvs_seen docs discards tc_bndrs
1488
1489               else if run_out n_left && id_tvs `subVarSet` tvs_seen
1490                        -- We've run out of n_left fuel and this binding only
1491                        -- mentions aleady-seen type variables, so discard it
1492               then go tidy_env n_left tvs_seen docs True tc_bndrs
1493
1494                        -- Keep this binding, decrement fuel
1495               else go tidy_env' (dec_max n_left) new_seen (doc:docs) discards tc_bndrs }
1496
1497 -----------------------
1498 warnDefaulting :: Cts -> Type -> TcM ()
1499 warnDefaulting wanteds default_ty
1500   = do { warn_default <- woptM Opt_WarnTypeDefaults
1501        ; env0 <- tcInitTidyEnv
1502        ; let tidy_env = tidyFreeTyVars env0 $
1503                         tyVarsOfCts wanteds
1504              tidy_wanteds = mapBag (tidyCt tidy_env) wanteds
1505              (loc, ppr_wanteds) = pprWithArising (bagToList tidy_wanteds)
1506              warn_msg  = hang (ptext (sLit "Defaulting the following constraint(s) to type")
1507                                 <+> quotes (ppr default_ty))
1508                             2 ppr_wanteds
1509        ; setCtLoc loc $ warnTc warn_default warn_msg }
1510 \end{code}
1511
1512 Note [Runtime skolems]
1513 ~~~~~~~~~~~~~~~~~~~~~~
1514 We want to give a reasonably helpful error message for ambiguity
1515 arising from *runtime* skolems in the debugger.  These
1516 are created by in RtClosureInspect.zonkRTTIType.
1517
1518 %************************************************************************
1519 %*                                                                      *
1520                  Error from the canonicaliser
1521          These ones are called *during* constraint simplification
1522 %*                                                                      *
1523 %************************************************************************
1524
1525 \begin{code}
1526 solverDepthErrorTcS :: SubGoalCounter -> CtEvidence -> TcM a
1527 solverDepthErrorTcS cnt ev
1528   = setCtLoc loc $
1529     do { pred <- zonkTcType (ctEvPred ev)
1530        ; env0 <- tcInitTidyEnv
1531        ; let tidy_env  = tidyFreeTyVars env0 (tyVarsOfType pred)
1532              tidy_pred = tidyType tidy_env pred
1533        ; failWithTcM (tidy_env, hang (msg cnt) 2 (ppr tidy_pred)) }
1534   where
1535     loc   = ctEvLoc ev
1536     depth = ctLocDepth loc
1537     value = subGoalCounterValue cnt depth
1538     msg CountConstraints =
1539         vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int value
1540              , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
1541     msg CountTyFunApps =
1542         vcat [ ptext (sLit "Type function application stack overflow; size =") <+> int value
1543              , ptext (sLit "Use -ftype-function-depth=N to increase stack size to N") ]
1544 \end{code}
1545