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