TcErrors.lhs 52.3 KB
Newer Older
1
\begin{code}
2
{-# LANGUAGE ScopedTypeVariables #-}
Ian Lynagh's avatar
Ian Lynagh committed
3 4 5 6 7 8 9
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

10
module TcErrors( 
11
       reportUnsolved, reportAllUnsolved,
12
       warnDefaulting,
13 14

       solverDepthErrorTcS
15 16 17 18
  ) where

#include "HsVersions.h"

19
import TcRnTypes
20 21 22
import TcRnMonad
import TcMType
import TcType
23
import TypeRep
batterseapower's avatar
batterseapower committed
24
import Type
25
import Kind ( isKind )
26
import Unify            ( tcMatchTys )
27 28 29
import Inst
import InstEnv
import TyCon
30
import TcEvidence
31
import Name
32
import Id 
33 34 35 36
import Var
import VarSet
import VarEnv
import Bag
37 38
import Maybes
import ErrUtils         ( ErrMsg, makeIntoWarning, pprLocErrMsg )
39
import BasicTypes 
40 41 42
import Util
import FastString
import Outputable
43
import SrcLoc
44
import DynFlags
45
import Data.List        ( partition, mapAccumL )
46 47 48 49 50 51 52 53 54 55 56 57
\end{code}

%************************************************************************
%*									*
\section{Errors and contexts}
%*									*
%************************************************************************

ToDo: for these error messages, should we note the location as coming
from the insts, or just whatever seems to be around in the monad just
now?

58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76
Note [Deferring coercion errors to runtime]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
While developing, sometimes it is desirable to allow compilation to succeed even
if there are type errors in the code. Consider the following case:

  module Main where

  a :: Int
  a = 'a'

  main = print "b"

Even though `a` is ill-typed, it is not used in the end, so if all that we're
interested in is `main` it is handy to be able to ignore the problems in `a`.

Since we treat type equalities as evidence, this is relatively simple. Whenever
we run into a type mismatch in TcUnify, we normally just emit an error. But it
is always safe to defer the mismatch to the main constraint solver. If we do
that, `a` will get transformed into
77

78 79 80 81 82 83 84 85 86 87 88 89 90 91
  co :: Int ~ Char
  co = ...

  a :: Int
  a = 'a' `cast` co

The constraint solver would realize that `co` is an insoluble constraint, and
emit an error with `reportUnsolved`. But we can also replace the right-hand side
of `co` with `error "Deferred type error: Int ~ Char"`. This allows the program
to compile, and it will run fine unless we evaluate `a`. This is what
`deferErrorsToRuntime` does.

It does this by keeping track of which errors correspond to which coercion
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 94 95 96 97 98
compilation. The errors are turned into warnings in `reportUnsolved`.

\begin{code}
reportUnsolved :: WantedConstraints -> TcM (Bag EvBind)
reportUnsolved wanted
  = do { binds_var <- newTcEvBinds
ian@well-typed.com's avatar
ian@well-typed.com committed
99
       ; defer <- goptM Opt_DeferTypeErrors
100 101 102 103 104 105
       ; report_unsolved (Just binds_var) defer wanted
       ; getTcEvBinds binds_var }

reportAllUnsolved :: WantedConstraints -> TcM ()
-- Report all unsolved goals, even if -fdefer-type-errors is on
-- See Note [Deferring coercion errors to runtime]
Simon Peyton Jones's avatar
Simon Peyton Jones committed
106
reportAllUnsolved wanted = report_unsolved Nothing False wanted
107 108 109 110

report_unsolved :: Maybe EvBindsVar  -- cec_binds
                -> Bool              -- cec_defer
                -> WantedConstraints -> TcM ()
111 112 113
-- Important precondition:
-- WantedConstraints are fully zonked and unflattened, that is,
-- 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 123
                 
            -- If we are deferring we are going to need /all/ evidence around,
            -- 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 133 134
       ; traceTc "reportUnsolved (after unflattening):" $ 
         vcat [ pprTvBndrs (varSetElems free_tvs)
              , ppr wanted ]
135

136
       ; reportWanteds err_ctxt wanted }
137

138 139 140
--------------------------------------------
--      Internal functions
--------------------------------------------
141 142 143 144

data ReportErrCtxt 
    = CEC { cec_encl :: [Implication]  -- Enclosing implications
                	       	       --   (innermost first)
145
                                       -- ic_skols and givens are tidied, rest are not
146
          , cec_tidy  :: TidyEnv
147 148 149 150 151
          , cec_binds :: Maybe EvBindsVar 
                         -- Nothinng <=> Report all errors, including holes; no bindings
                         -- Just ev  <=> make some errors (depending on cec_defer)
                         --              into warnings, and emit evidence bindings
                         --              into 'ev' for unsolved constraints
152

153 154
          , cec_defer :: Bool       -- True <=> -fdefer-type-errors
                                    -- Irrelevant if cec_binds = Nothing
155 156 157
          , cec_suppress :: Bool    -- True <=> More important errors have occurred,
                                    --          so create bindings if need be, but
                                    --          don't issue any more errors/warnings
158
                                    -- See Note [Suppressing error messages]
159
      }
160
\end{code}
161

162 163 164 165 166 167 168 169 170 171 172 173 174
Note [Suppressing error messages]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The cec_suppress flag says "don't report any errors.  Instead, just create
evidence bindings (as usual).  It's used when more important errors have occurred.
Specifically (see reportWanteds)
  * If there are insoluble Givens, then we are in unreachable code and all bets
    are off.  So don't report any further errors.
  * If there are any insolubles (eg Int~Bool), here or in a nested implication, 
    then suppress errors from the flat constraints here.  Sometimes the
    flat-constraint errors are a knock-on effect of the insolubles.


\begin{code}
175 176 177
reportImplic :: ReportErrCtxt -> Implication -> TcM ()
reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given
                                 , ic_wanted = wanted, ic_binds = evb
Simon Peyton Jones's avatar
Simon Peyton Jones committed
178
                                 , ic_insol = ic_insoluble, ic_info = info })
179
  | BracketSkol <- info
Simon Peyton Jones's avatar
Simon Peyton Jones committed
180 181 182 183
  , not ic_insoluble -- For Template Haskell brackets report only
  = return ()        -- definite errors. The whole thing will be re-checked
                     -- later when we plug it in, and meanwhile there may
                     -- 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 192 193
                     , ic_given = map (tidyEvVar env2) given
                     , ic_info  = info' }
    ctxt' = ctxt { cec_tidy  = env2
194
                 , cec_encl  = implic' : cec_encl ctxt
195
                 , cec_binds = case cec_binds ctxt of
196 197 198 199
                                 Nothing -> Nothing
                                 Just {} -> Just evb }

reportWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
200 201 202 203
reportWanteds ctxt wanted@(WC { wc_flat = flats, wc_insol = insols, wc_impl = implics })
  = do { reportFlats ctxt  (mapBag (tidyCt env) insol_given)
       ; reportFlats ctxt1 (mapBag (tidyCt env) insol_wanted)
       ; reportFlats ctxt2 (mapBag (tidyCt env) flats)
204 205 206 207
            -- All the Derived ones have been filtered out of flats 
            -- by the constraint solver. This is ok; we don't want
            -- to report unsolved Derived goals as errors
            -- See Note [Do not report derived but soluble errors]
208 209 210 211 212 213
       ; mapBagM_ (reportImplic ctxt1) implics }
            -- NB ctxt1: don't suppress inner insolubles if there's only a
            -- wanted insoluble here; but do suppress inner insolubles
            -- if there's a given insoluble here (= inaccessible code)
 where
    (insol_given, insol_wanted) = partitionBag isGivenCt insols
214 215
    env = cec_tidy ctxt

216 217 218 219 220 221 222
      -- See Note [Suppressing error messages]
    suppress0 = cec_suppress ctxt
    suppress1 = suppress0 || not (isEmptyBag insol_given)
    suppress2 = suppress0 || insolubleWC wanted
    ctxt1     = ctxt { cec_suppress = suppress1 }
    ctxt2     = ctxt { cec_suppress = suppress2 }

223 224
reportFlats :: ReportErrCtxt -> Cts -> TcM ()
reportFlats ctxt flats    -- Here 'flats' includes insolble goals
225 226
  = traceTc "reportFlats" (vcat [ ptext (sLit "Flats =") <+> ppr flats
                                , ptext (sLit "Suppress =") <+> ppr (cec_suppress ctxt)]) >>
Simon Peyton Jones's avatar
Simon Peyton Jones committed
227
    tryReporters 
228 229 230
      [ -- First deal with things that are utterly wrong
        -- Like Int ~ Bool (incl nullary TyCons)
        -- or  Int ~ t a   (AppTy on one side)
231 232
        ("Utterly wrong",  utterly_wrong,   mkGroupReporter mkEqErr)
      , ("Holes",          is_hole,         mkUniReporter mkHoleError)
233 234 235 236

        -- Report equalities of form (a~ty).  They are usually
        -- skolem-equalities, and they cause confusing knock-on 
        -- effects in other errors; see test T4093b.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
237 238
      , ("Skolem equalities",    skolem_eq,   mkUniReporter mkEqErr1) ]
      reportFlatErrs
239
      ctxt (bagToList flats)
240
  where
Simon Peyton Jones's avatar
Simon Peyton Jones committed
241
    utterly_wrong, skolem_eq :: Ct -> PredTree -> Bool
242 243 244
    utterly_wrong _ (EqPred ty1 ty2) = isRigid ty1 && isRigid ty2 
    utterly_wrong _ _ = False

245 246
    is_hole ct _ = isHoleCt ct

247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267
    skolem_eq _ (EqPred ty1 ty2) = isRigidOrSkol ty1 && isRigidOrSkol ty2 
    skolem_eq _ _ = False

---------------
isRigid, isRigidOrSkol :: Type -> Bool
isRigid ty 
  | Just (tc,_) <- tcSplitTyConApp_maybe ty = isDecomposableTyCon tc
  | Just {} <- tcSplitAppTy_maybe ty        = True
  | isForAllTy ty                           = True
  | otherwise                               = False

isRigidOrSkol ty 
  | Just tv <- getTyVar_maybe ty = isSkolemTyVar tv
  | otherwise                    = isRigid ty

isTyFun_maybe :: Type -> Maybe TyCon
isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of
                      Just (tc,_) | isSynFamilyTyCon tc -> Just tc
                      _ -> Nothing

-----------------
268
reportFlatErrs :: Reporter
269 270 271 272
-- Called once for non-ambigs, once for ambigs
-- Report equality errors, and others only if we've done all 
-- the equalities.  The equality errors are more basic, and
-- can lead to knock on type-class errors
273
reportFlatErrs
274
  = tryReporters
275
      [ ("Equalities", is_equality, mkGroupReporter mkEqErr) ]
276 277 278 279
      (\ctxt cts -> do { let (dicts, ips, irreds) = go cts [] [] []
                       ; mkGroupReporter mkIPErr    ctxt ips   
                       ; mkGroupReporter mkIrredErr ctxt irreds
                       ; mkGroupReporter mkDictErr  ctxt dicts })
280
  where
281 282 283 284 285 286
    is_equality _ (EqPred {}) = True
    is_equality _ _           = False

    go [] dicts ips irreds
      = (dicts, ips, irreds)
    go (ct:cts) dicts ips irreds
Simon Peyton Jones's avatar
Simon Peyton Jones committed
287 288
      | isIPPred (ctPred ct) 
      = go cts dicts (ct:ips) irreds
289
      | otherwise
290 291 292
      = case classifyPredType (ctPred ct) of
          ClassPred {}  -> go cts (ct:dicts) ips irreds
          IrredPred {}  -> go cts dicts ips (ct:irreds)
293
          _             -> panic "reportFlatErrs"
batterseapower's avatar
batterseapower committed
294 295
    -- TuplePreds should have been expanded away by the constraint
    -- simplifier, so they shouldn't show up at this point
296 297
    -- And EqPreds are dealt with by the is_equality test

298 299

--------------------------------------------
300
--      Reporters
301 302
--------------------------------------------

303 304 305 306 307 308
type Reporter = ReportErrCtxt -> [Ct] -> TcM ()

mkUniReporter :: (ReportErrCtxt -> Ct -> TcM ErrMsg) -> Reporter
-- Reports errors one at a time
mkUniReporter mk_err ctxt 
  = mapM_ $ \ct -> 
309
    do { err <- mk_err ctxt ct
310
       ; maybeReportError ctxt err
311
       ; maybeAddDeferredBinding ctxt err ct }
312 313 314 315

mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg)
                             -- Make error message for a group
                -> Reporter  -- Deal with lots of constraints
316
-- Group together insts from same location
317 318
-- We want to report them together in error messages

319
mkGroupReporter _ _ [] 
320
  = return ()
321
mkGroupReporter mk_err ctxt (ct1 : rest)
322 323 324
  = do { err <- mk_err ctxt first_group
       ; maybeReportError ctxt err
       ; 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 336
   same_loc l1 l2 = ctLocSpan l1 == ctLocSpan l2

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 343 344 345 346 347 348 349 350 351 352
  | cec_suppress ctxt
  = return ()
  | otherwise
  = reportError err

maybeAddDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
-- See Note [Deferring coercion errors to runtime]
maybeAddDeferredBinding ctxt err ct
  | CtWanted { ctev_pred = pred, ctev_evar = ev_id } <- cc_ev ct
    -- Only add deferred bindings for Wanted constraints
  , 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 355 356 357 358 359 360 361 362 363
  = do { dflags <- getDynFlags
       ; let err_msg = pprLocErrMsg err
             err_fs  = mkFastString $ showSDoc dflags $
                       err_msg $$ text "(deferred type error)"

         -- Create the binding
       ; addTcEvBind ev_binds_var ev_id (EvDelayedError pred err_fs) }

  | otherwise   -- Do not set any evidence for Given/Derived
  = return ()   
364 365 366 367 368 369

tryReporters :: [(String, Ct -> PredTree -> Bool, Reporter)] 
             -> Reporter -> Reporter
-- Use the first reporter in the list whose predicate says True
tryReporters reporters deflt ctxt cts
  = do { traceTc "tryReporters {" (ppr cts) 
370
       ; go ctxt reporters cts
371 372
       ; traceTc "tryReporters }" empty }
  where
373 374 375 376 377 378 379 380 381 382
    go ctxt [] cts = deflt ctxt cts 
    go ctxt ((str, pred, reporter) : rs) cts
      | null yeses  = do { traceTc "tryReporters: no" (text str)
                         ; go ctxt rs cts }
      | otherwise   = do { traceTc "tryReporters: yes" (text str <+> ppr yeses)
                         ; reporter ctxt yeses :: TcM ()
                         ; go (ctxt { cec_suppress = True }) rs nos }
                         -- Carry on with the rest, because we must make
                         -- deferred bindings for them if we have 
                         -- -fdefer-type-errors
Simon Peyton Jones's avatar
Simon Peyton Jones committed
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 394
-- Print something like
--    (Eq a) arising from a use of x at y
395 396
--    (Show a) arising from a use of p at q
-- Also return a location for the error message
397
-- Works for Wanted/Derived only
398 399
pprWithArising [] 
  = panic "pprWithArising"
400 401
pprWithArising (ct:cts)
  | null cts
402
  = (loc, addArising (ctLocOrigin loc) 
dimitris's avatar
dimitris committed
403
                     (pprTheta [ctPred ct]))
404 405
  | otherwise
  = (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 412 413 414 415
mkErrorMsg :: ReportErrCtxt -> Ct -> SDoc -> TcM ErrMsg
mkErrorMsg ctxt ct msg 
  = do { let tcl_env = ctLocEnv (cc_loc ct)
       ; err_info <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)
       ; 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 424 425
    [ (givens, info, tcl_loc env) 
    | Implic {ic_given = givens, ic_env = env, ic_info = info } <- ctxt
    , not (null givens) ]
426 427
\end{code}

428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443
Note [Always warn with -fdefer-type-errors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When -fdefer-type-errors is on we warn about *all* type errors, even
if cec_suppress is on.  This can lead to a lot more warnings than you
would get errors without -fdefer-type-errors, but if we suppress any of
them you might get a runtime error that wasn't warned about at compile
time. 

This is an easy design choice to change; just flip the order of the
first two equations for maybeReportError

To be consistent, we should also report multiple warnings from a single
location in mkGroupReporter, when -fdefer-type-errors is on.  But that 
is perhaps a bit *over*-consistent! Again, an easy choice to change.


444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493
Note [Do not report derived but soluble errors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The wc_flats include Derived constraints that have not been solved, but are
not insoluble (in that case they'd be in wc_insols).  We do not want to report
these as errors:

* Superclass constraints. If we have an unsolved [W] Ord a, we'll also have
  an unsolved [D] Eq a, and we do not want to report that; it's just noise.

* Functional dependencies.  For givens, consider
      class C a b | a -> b
      data T a where
         MkT :: C a d => [d] -> T a
      f :: C a b => T a -> F Int
      f (MkT xs) = length xs
  Then we get a [D] b~d.  But there *is* a legitimate call to
  f, namely   f (MkT [True]) :: T Bool, in which b=d.  So we should
  not reject the program.

  For wanteds, something similar
      data T a where
        MkT :: C Int b => a -> b -> T a 
      g :: C Int c => c -> ()
      f :: T a -> ()
      f (MkT x y) = g x
  Here we get [G] C Int b, [W] C Int a, hence [D] a~b.
  But again f (MkT True True) is a legitimate call.

(We leave the Deriveds in wc_flat until reportErrors, so that we don't lose
derived superclasses between iterations of the solver.)

For functional dependencies, here is a real example, 
stripped off from libraries/utf8-string/Codec/Binary/UTF8/Generic.hs

  class C a b | a -> b
  g :: C a b => a -> b -> () 
  f :: C a b => a -> b -> () 
  f xa xb = 
      let loop = g xa 
      in loop xb

We will first try to infer a type for loop, and we will succeed:
    C a b' => b' -> ()
Subsequently, we will type check (loop xb) and all is good. But, 
recall that we have to solve a final implication constraint: 
    C a b => (C a b' => .... cts from body of loop .... )) 
And now we have a problem as we will generate an equality b ~ b' and fail to 
solve it. 


batterseapower's avatar
batterseapower committed
494 495 496 497 498 499 500
%************************************************************************
%*                  *
                Irreducible predicate errors
%*                  *
%************************************************************************

\begin{code}
501 502
mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkIrredErr ctxt cts 
503 504
  = do { (ctxt, binds_msg) <- relevantBindings ctxt ct1
       ; mkErrorMsg ctxt ct1 (msg $$ binds_msg) }
batterseapower's avatar
batterseapower committed
505
  where
506
    (ct1:_) = cts
507
    orig    = ctLocOrigin (cc_loc ct1)
508 509
    givens  = getUserGivens ctxt
    msg = couldNotDeduce givens (map ctPred cts, orig)
batterseapower's avatar
batterseapower committed
510

511
----------------
512
mkHoleError :: ReportErrCtxt -> Ct -> TcM ErrMsg
513
mkHoleError ctxt ct@(CHoleCan { cc_occ = occ })
514 515
  = do { let tyvars = varSetElems (tyVarsOfCt ct)
             tyvars_msg = map loc_msg tyvars
516 517 518
             msg = vcat [ hang (ptext (sLit "Found hole") <+> quotes (ppr occ))
                             2 (ptext (sLit "with type:") <+> pprType (ctEvPred (cc_ev ct)))
                        , ppUnless (null tyvars_msg) (ptext (sLit "Where:") <+> vcat tyvars_msg) ]
519 520
       ; (ctxt, binds_doc) <- relevantBindings ctxt ct
       ; mkErrorMsg ctxt ct (msg $$ binds_doc) }
521
  where
522 523 524
    loc_msg tv 
       = case tcTyVarDetails tv of
          SkolemTv {} -> quotes (ppr tv) <+> skol_msg
525
          MetaTv {}   -> quotes (ppr tv) <+> ptext (sLit "is an ambiguous type variable")
526 527 528
          det -> pprTcTyVarDetails det
       where 
          skol_msg = pprSkol (getSkolemInfo (cec_encl ctxt) tv) (getSrcLoc tv)
529 530

mkHoleError _ ct = pprPanic "mkHoleError" (ppr ct)
531

532
----------------
533 534
mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkIPErr ctxt cts
535 536
  = do { (ctxt, bind_msg) <- relevantBindings ctxt ct1
       ; mkErrorMsg ctxt ct1 (msg $$ bind_msg) }
537
  where
538
    (ct1:_) = cts
539
    orig    = ctLocOrigin (cc_loc ct1)
540 541
    preds   = map ctPred cts
    givens  = getUserGivens ctxt
542 543
    msg | null givens
        = addArising orig $
544 545
          sep [ ptext (sLit "Unbound implicit parameter") <> plural cts
              , nest 2 (pprTheta preds) ] 
546
        | otherwise
547
        = couldNotDeduce givens (preds, orig)
548 549 550 551 552 553 554 555 556
\end{code}


%************************************************************************
%*									*
                Equality errors
%*									*
%************************************************************************

557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574
Note [Inaccessible code]
~~~~~~~~~~~~~~~~~~~~~~~~
Consider
   data T a where
     T1 :: T a
     T2 :: T Bool

   f :: (a ~ Int) => T a -> Int
   f T1 = 3
   f T2 = 4   -- Unreachable code

Here the second equation is unreachable. The original constraint
(a~Int) from the signature gets rewritten by the pattern-match to
(Bool~Int), so the danger is that we report the error as coming from
the *signature* (Trac #7293).  So, for Given errors we replace the
env (and hence src-loc) on its CtLoc with that from the immediately
enclosing implication.

575
\begin{code}
576 577 578 579 580 581 582 583 584
mkEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
-- Don't have multiple equality errors from the same location
-- E.g.   (Int,Bool) ~ (Bool,Int)   one error will do!
mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct
mkEqErr _ [] = panic "mkEqErr"

mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg
-- Wanted constraints only!
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 589
       ; dflags <- getDynFlags
       ; mkEqErr_help dflags ctxt (given_msg $$ binds_msg) 
590 591 592 593 594 595 596
                      (ct { cc_loc = given_loc}) -- Note [Inaccessible code]
                      Nothing ty1 ty2 }

  | otherwise   -- Wanted or derived
  = do { (ctxt, binds_msg) <- relevantBindings ctxt ct
       ; (ctxt, tidy_orig) <- zonkTidyOrigin ctxt (ctLocOrigin (cc_loc ct))
       ; let (is_oriented, wanted_msg) = mk_wanted_extra tidy_orig
597 598
       ; dflags <- getDynFlags
       ; mkEqErr_help dflags ctxt (wanted_msg $$ binds_msg) 
599
                      ct is_oriented ty1 ty2 }
600
  where
601
    ev         = cc_ev ct
602 603 604 605 606 607 608 609 610
    (ty1, ty2) = getEqPredTys (ctEvPred ev)

    mk_given :: [Implication] -> (CtLoc, SDoc)
    -- For given constraints we overwrite the env (and hence src-loc)
    -- with one from the implication.  See Note [Inaccessible code]
    mk_given []           = (cc_loc ct, empty)
    mk_given (implic : _) = (setCtLocEnv (cc_loc ct) (ic_env implic)
                            , hang (ptext (sLit "Inaccessible code in"))
                                 2 (ppr (ic_info implic)))
611

612 613
       -- If the types in the error message are the same as the types
       -- we are unifying, don't add the extra expected/actual message
614 615 616 617 618
    mk_wanted_extra orig@(TypeEqOrigin {})
      = mkExpectedActualMsg ty1 ty2 orig

    mk_wanted_extra (KindEqOrigin cty1 cty2 sub_o)
      = (Nothing, msg1 $$ msg2)
619
      where
620 621 622 623 624 625 626 627
        msg1 = hang (ptext (sLit "When matching types"))
                  2 (vcat [ ppr cty1 <+> dcolon <+> ppr (typeKind cty1)
                          , ppr cty2 <+> dcolon <+> ppr (typeKind cty2) ])
        msg2 = case sub_o of
                 TypeEqOrigin {} -> snd (mkExpectedActualMsg cty1 cty2 sub_o)
                 _ -> empty

    mk_wanted_extra _ = (Nothing, empty)
628

629 630 631 632 633 634 635
mkEqErr_help :: DynFlags -> ReportErrCtxt -> SDoc
             -> Ct          
             -> Maybe SwapFlag   -- Nothing <=> not sure
             -> TcType -> TcType -> TcM ErrMsg
mkEqErr_help dflags ctxt extra ct oriented ty1 ty2
  | Just tv1 <- tcGetTyVar_maybe ty1 = mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2
  | Just tv2 <- tcGetTyVar_maybe ty2 = mkTyVarEqErr dflags ctxt extra ct swapped  tv2 ty1
636
  | otherwise                        = reportEqErr  ctxt extra ct oriented ty1 ty2
637 638
  where
    swapped = fmap flipSwap oriented
639

640 641 642 643
reportEqErr :: ReportErrCtxt -> SDoc
            -> Ct    
            -> Maybe SwapFlag   -- Nothing <=> not sure
            -> TcType -> TcType -> TcM ErrMsg
644
reportEqErr ctxt extra1 ct oriented ty1 ty2
645 646
  = do { let extra2 = mkEqInfoMsg ct ty1 ty2
       ; mkErrorMsg ctxt ct (vcat [ misMatchOrCND ctxt ct oriented ty1 ty2
647
                                   , extra2, extra1]) }
648

649 650
mkTyVarEqErr :: DynFlags -> ReportErrCtxt -> SDoc -> Ct 
             -> Maybe SwapFlag -> TcTyVar -> TcType -> TcM ErrMsg
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
651
-- tv1 and ty2 are already tidied
652 653 654
mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2
  | isUserSkolem ctxt tv1   -- ty2 won't be a meta-tyvar, or else the thing would
                            -- be oriented the other way round; see TcCanonical.reOrient
655
  || isSigTyVar tv1 && not (isTyVarTy ty2)
656 657 658
  = mkErrorMsg ctxt ct (vcat [ misMatchOrCND ctxt ct oriented ty1 ty2
                             , extraTyVarInfo ctxt ty1 ty2
                             , extra ])
659

660 661 662
  -- So tv is a meta tyvar (or started that way before we 
  -- generalised it).  So presumably it is an *untouchable* 
  -- 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 668
  = do { let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:")
                              2 (sep [ppr ty1, char '~', ppr ty2])
669 670
             extra2 = mkEqInfoMsg ct ty1 ty2
       ; mkErrorMsg ctxt ct (occCheckMsg $$ extra2 $$ extra) }
Simon Peyton Jones's avatar
Simon Peyton Jones committed
671

672 673 674 675 676 677 678 679 680
  | OC_Forall <- occ_check_expand
  = do { let msg = vcat [ ptext (sLit "Cannot instantiate unification variable")
                          <+> quotes (ppr tv1)
                        , hang (ptext (sLit "with a type involving foralls:")) 2 (ppr ty2)
                        , nest 2 (ptext (sLit "Perhaps you want -XImpredicativeTypes")) ]
       ; mkErrorMsg ctxt ct msg }

  -- If the immediately-enclosing implication has 'tv' a skolem, and
  -- we know by now its an InferSkol kind of skolem, then presumably
681 682
  -- it started life as a SigTv, else it'd have been unified, given
  -- that there's no occurs-check or forall problem
683 684 685 686 687 688 689
  | (implic:_) <- cec_encl ctxt
  , Implic { ic_skols = skols } <- implic
  , tv1 `elem` skols
  = mkErrorMsg ctxt ct (vcat [ misMatchMsg oriented ty1 ty2
                             , extraTyVarInfo ctxt ty1 ty2
                             , extra ])

690 691
  -- Check for skolem escape
  | (implic:_) <- cec_encl ctxt   -- Get the innermost context
692 693
  , Implic { ic_env = env, ic_skols = skols, ic_info = skol_info } <- implic
  , let esc_skols = filter (`elemVarSet` (tyVarsOfType ty2)) skols
694
  , not (null esc_skols)
695
  = do { let msg = misMatchMsg oriented ty1 ty2
696 697 698 699 700
             esc_doc = sep [ ptext (sLit "because type variable") <> plural esc_skols
                             <+> pprQuotedList esc_skols
                           , ptext (sLit "would escape") <+>
                             if isSingleton esc_skols then ptext (sLit "its scope")
                                                      else ptext (sLit "their scope") ]
701 702 703 704 705 706 707 708
             tv_extra = vcat [ nest 2 $ esc_doc
                             , sep [ (if isSingleton esc_skols 
                                      then ptext (sLit "This (rigid, skolem) type variable is")
                                      else ptext (sLit "These (rigid, skolem) type variables are"))
                               <+> ptext (sLit "bound by")
                             , nest 2 $ ppr skol_info
                             , nest 2 $ ptext (sLit "at") <+> ppr (tcl_loc env) ] ]
       ; mkErrorMsg ctxt ct (msg $$ tv_extra $$ extra) }
709 710 711

  -- Nastiest case: attempt to unify an untouchable variable
  | (implic:_) <- cec_encl ctxt   -- Get the innermost context
712 713 714 715 716 717 718 719 720 721
  , Implic { ic_env = env, ic_given = given, ic_info = skol_info } <- implic
  = do { let msg = misMatchMsg oriented ty1 ty2
             untch_extra 
                = nest 2 $
                  sep [ quotes (ppr tv1) <+> ptext (sLit "is untouchable")
                      , nest 2 $ ptext (sLit "inside the constraints") <+> pprEvVarTheta given
                      , nest 2 $ ptext (sLit "bound by") <+> ppr skol_info
                      , nest 2 $ ptext (sLit "at") <+> ppr (tcl_loc env) ]
             tv_extra = extraTyVarInfo ctxt ty1 ty2
       ; mkErrorMsg ctxt ct (vcat [msg, untch_extra, tv_extra, extra]) }
722

723
  | otherwise
724
  = reportEqErr ctxt extra ct oriented (mkTyVarTy tv1) ty2
725 726
        -- This *can* happen (Trac #6123, and test T2627b)
        -- Consider an ambiguous top-level constraint (a ~ F a)
Gabor Greif's avatar
typos  
Gabor Greif committed
727
        -- Not an occurs check, because F is a type function.
728
  where         
729
    occ_check_expand = occurCheckExpand dflags tv1 ty2
730 731 732
    k1 	= tyVarKind tv1
    k2 	= typeKind ty2
    ty1 = mkTyVarTy tv1
733

734
mkEqInfoMsg :: Ct -> TcType -> TcType -> SDoc
735 736 737 738 739
-- Report (a) ambiguity if either side is a type function application
--            e.g. F a0 ~ Int    
--        (b) warning about injectivity if both sides are the same
--            type function application   F a ~ F b
--            See Note [Non-injective type functions]
740 741
mkEqInfoMsg ct ty1 ty2
  = tyfun_msg $$ ambig_msg
742 743 744
  where
    mb_fun1 = isTyFun_maybe ty1
    mb_fun2 = isTyFun_maybe ty2
745 746 747 748 749

    ambig_msg | isJust mb_fun1 || isJust mb_fun2 
              = snd (mkAmbigMsg ct)
              | otherwise = empty

750 751 752 753 754 755 756
    tyfun_msg | Just tc1 <- mb_fun1
              , Just tc2 <- mb_fun2
              , tc1 == tc2 
              = ptext (sLit "NB:") <+> quotes (ppr tc1) 
                <+> ptext (sLit "is a type function, and may not be injective")
              | otherwise = empty

Simon Peyton Jones's avatar
Simon Peyton Jones committed
757 758 759 760 761 762 763 764 765 766 767
isUserSkolem :: ReportErrCtxt -> TcTyVar -> Bool
-- See Note [Reporting occurs-check errors]
isUserSkolem ctxt tv
  = isSkolemTyVar tv && any is_user_skol_tv (cec_encl ctxt)
  where
    is_user_skol_tv (Implic { ic_skols = sks, ic_info = skol_info })
      = tv `elem` sks && is_user_skol_info skol_info

    is_user_skol_info (InferSkol {}) = False
    is_user_skol_info _ = True

768
misMatchOrCND :: ReportErrCtxt -> Ct -> Maybe SwapFlag -> TcType -> TcType -> SDoc
Simon Peyton Jones's avatar
Simon Peyton Jones committed
769
-- If oriented then ty1 is actual, ty2 is expected
770 771 772
misMatchOrCND ctxt ct oriented ty1 ty2
  | null givens || 
    (isRigid ty1 && isRigid ty2) || 
773
    isGivenCt ct
774 775 776 777
       -- If the equality is unconditionally insoluble
       -- or there is no context, don't report the context
  = misMatchMsg oriented ty1 ty2
  | otherwise      
778
  = couldNotDeduce givens ([mkEqPred ty1 ty2], orig)
779 780
  where
    givens = getUserGivens ctxt
Simon Peyton Jones's avatar
Simon Peyton Jones committed
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)
dimitris's avatar
dimitris committed
786 787
         , vcat (pp_givens givens)]

788
pp_givens :: [UserGiven] -> [SDoc]
dimitris's avatar
dimitris committed
789 790
pp_givens givens 
   = case givens of
791 792 793
         []     -> []
         (g:gs) ->      ppr_given (ptext (sLit "from the context")) g
                 : map (ppr_given (ptext (sLit "or from"))) gs
794 795
    where 
       ppr_given herald (gs, skol_info, loc)
dimitris's avatar
dimitris committed
796
           = hang (herald <+> pprEvVarTheta gs)
797 798
                2 (sep [ ptext (sLit "bound by") <+> ppr skol_info
                       , ptext (sLit "at") <+> ppr loc])
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
799

800
extraTyVarInfo :: ReportErrCtxt -> TcType -> TcType -> SDoc
801 802
-- Add on extra info about the types themselves
-- NB: The types themselves are already tidied
803 804
extraTyVarInfo ctxt ty1 ty2
  = nest 2 (extra1 $$ extra2)
805
  where
806 807
    extra1 = tyVarExtraInfoMsg (cec_encl ctxt) ty1
    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
Simon Peyton Jones's avatar
Simon Peyton Jones committed
813 814 815
  , isTcTyVar tv, isSkolemTyVar tv
  , let pp_tv = quotes (ppr tv)
 = case tcTyVarDetails tv of
816
    SkolemTv {}   -> pp_tv <+> pprSkol (getSkolemInfo implics tv) (getSrcLoc tv)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
817 818 819 820 821 822 823
    FlatSkol {}   -> pp_tv <+> ptext (sLit "is a flattening type variable")
    RuntimeUnk {} -> pp_tv <+> ptext (sLit "is an interactive-debugger skolem")
    MetaTv {}     -> empty

 | otherwise             -- Normal case
 = empty
 
824 825 826 827 828 829 830 831 832
kindErrorMsg :: TcType -> TcType -> SDoc   -- Types are already tidy
kindErrorMsg ty1 ty2
  = vcat [ ptext (sLit "Kind incompatibility when matching types:")
         , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1
                        , ppr ty2 <+> dcolon <+> ppr k2 ]) ]
  where
    k1 = typeKind ty1
    k2 = typeKind ty2

833
--------------------
834
misMatchMsg :: Maybe SwapFlag -> TcType -> TcType -> SDoc	   -- Types are already tidy
835
-- If oriented then ty1 is actual, ty2 is expected
836 837 838 839
misMatchMsg oriented ty1 ty2  
  | Just IsSwapped <- oriented
  = misMatchMsg (Just NotSwapped) ty2 ty1
  | Just NotSwapped <- oriented
840 841
  = sep [ ptext (sLit "Couldn't match expected") <+> what <+> quotes (ppr ty2)
        , nest 12 $   ptext (sLit "with actual") <+> what <+> quotes (ppr ty1) ]
842 843 844 845 846 847
  | otherwise
  = sep [ ptext (sLit "Couldn't match") <+> what <+> quotes (ppr ty1)
        , nest 14 $ ptext (sLit "with") <+> quotes (ppr ty2) ]
  where 
    what | isKind ty1 = ptext (sLit "kind")
         | 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 853
  | act `pickyEqType` ty1, exp `pickyEqType` ty2 = (Just NotSwapped,  empty)
  | exp `pickyEqType` ty1, act `pickyEqType` ty2 = (Just IsSwapped, empty)
854 855 856 857 858 859
  | otherwise                                    = (Nothing, msg)
  where
    msg = vcat [ text "Expected type:" <+> ppr exp
               , text "  Actual type:" <+> ppr act ]

mkExpectedActualMsg _ _ _ = panic "mkExprectedAcutalMsg"
860 861
\end{code}

Simon Peyton Jones's avatar
Simon Peyton Jones committed
862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879
Note [Reporting occurs-check errors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Given (a ~ [a]), if 'a' is a rigid type variable bound by a user-supplied
type signature, then the best thing is to report that we can't unify
a with [a], because a is a skolem variable.  That avoids the confusing
"occur-check" error message.

But nowadays when inferring the type of a function with no type signature,
even if there are errors inside, we still generalise its signature and
carry on. For example
   f x = x:x
Here we will infer somethiing like
   f :: forall a. a -> [a]
with a suspended error of (a ~ [a]).  So 'a' is now a skolem, but not
one bound by the programmer!  Here we really should report an occurs check.

So isUserSkolem distinguishes the two.

880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897
Note [Non-injective type functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's very confusing to get a message like
     Couldn't match expected type `Depend s'
            against inferred type `Depend s1'
so mkTyFunInfoMsg adds:
       NB: `Depend' is type function, and hence may not be injective

Warn of loopy local equalities that were dropped.


%************************************************************************
%*									*
                 Type-class errors
%*									*
%************************************************************************

\begin{code}
898 899
mkDictErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkDictErr ctxt cts 
900 901 902 903 904 905 906
  = ASSERT( not (null cts) )
    do { inst_envs <- tcGetInstEnvs
       ; lookups   <- mapM (lookup_cls_inst inst_envs) cts
       ; let (no_inst_cts, overlap_cts) = partition is_no_inst lookups

       -- Report definite no-instance errors, 
       -- or (iff there are none) overlap errors
Gabor Greif's avatar
typos  
Gabor Greif committed
907
       -- But we report only one of them (hence 'head') because they all
908 909
       -- have the same source-location origin, to try avoid a cascade
       -- 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 915 916 917 918 919 920 921 922 923
    no_givens = null (getUserGivens ctxt)
    is_no_inst (ct, (matches, unifiers, _))
      =  no_givens 
      && null matches 
      && (null unifiers || all (not . isAmbiguousTyVar) (varSetElems (tyVarsOfCt ct)))
           
    lookup_cls_inst inst_envs ct
      = do { tys_flat <- mapM quickFlattenTy tys
                -- Note [Flattening in error message generation]
           ; 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 930 931 932
-- Report an overlap error if this class constraint results
-- from an overlap (returning Left clas), otherwise return (Right pred)
mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell)) 
  | null matches  -- No matches but perhaps several unifiers
933
  = do { let (is_ambig, ambig_msg) = mkAmbigMsg ct
934
       ; (ctxt, binds_msg) <- relevantBindings ctxt ct
Simon Peyton Jones's avatar
Simon Peyton Jones committed
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 939
  | not safe_haskell   -- Some matches => overlap errors
  = return (ctxt, overlap_msg)
940

941 942 943
  | otherwise
  = return (ctxt, safe_haskell_msg)
  where
944
    orig        = ctLocOrigin (cc_loc ct)
945 946 947 948 949 950
    pred        = ctPred ct
    (clas, tys) = getClassPredTys pred
    ispecs      = [ispec | (ispec, _) <- matches]
    givens      = getUserGivens ctxt
    all_tyvars  = all isTyVarTy tys

951
    cannot_resolve_msg has_ambig_tvs binds_msg ambig_msg
952 953
      = vcat [ addArising orig (no_inst_herald <+> pprParendType pred)
             , vcat (pp_givens givens)
954 955
             , ppWhen (has_ambig_tvs && not (null unifiers && null givens))
               (vcat [ ambig_msg, binds_msg, potential_msg ])
956
             , show_fixes (add_to_ctxt_fixes has_ambig_tvs ++ drv_fixes) ]
957 958

    potential_msg
959 960
      = ppWhen (not (null unifiers) && want_potential orig) $
        hang (if isSingleton unifiers 
961 962 963 964
              then ptext (sLit "Note: there is a potential instance available:")
              else ptext (sLit "Note: there are several potential instances:"))
    	   2 (ppr_insts unifiers)

965 966 967 968 969
    -- Report "potential instances" only when the constraint arises
    -- directly from the user's use of an overloaded function
    want_potential (AmbigOrigin {})   = False
    want_potential _                  = True

970 971 972 973 974 975 976 977 978 979 980 981
    add_to_ctxt_fixes has_ambig_tvs
      | not has_ambig_tvs && all_tyvars
      , (orig:origs) <- mapCatMaybes get_good_orig (cec_encl ctxt)
      = [sep [ ptext (sLit "add") <+> pprParendType pred
               <+> ptext (sLit "to the context of")
	     , nest 2 $ ppr_skol orig $$ 
                        vcat [ ptext (sLit "or") <+> ppr_skol orig 
                             | orig <- origs ] ] ]
      | otherwise = []

    ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc)
    ppr_skol skol_info      = ppr skol_info
982 983

	-- Do not suggest adding constraints to an *inferred* type signature!
984 985 986
    get_good_orig ic = case ic_info ic of 
                         SigSkol (InfSigCtxt {}) _ -> Nothing
                         origin                    -> Just origin
987

988 989 990
    no_inst_herald
      | null givens && null matches = ptext (sLit "No instance for")
      | otherwise                   = ptext (sLit "Could not deduce")
991

992 993 994
    drv_fixes = case orig of
                   DerivOrigin -> [drv_fix]
                   _           -> []
995

996 997
    drv_fix = hang (ptext (sLit "use a standalone 'deriving instance' declaration,"))
                 2 (ptext (sLit "so you can specify the instance context yourself"))
998

999
    -- Normal overlap error
1000
    overlap_msg
1001 1002
      = ASSERT( not (null matches) )
        vcat [	addArising orig (ptext (sLit "Overlapping instances for") 
batterseapower's avatar
batterseapower committed
1003
				<+> pprType (mkClassPred clas tys))
dimitris's avatar
dimitris committed
1004

1005
             ,  ppUnless (null matching_givens) $
1006
                  sep [ptext (sLit "Matching givens (or their superclasses):") 
1007
                      , nest 2 (vcat matching_givens)]
dimitris's avatar
dimitris committed
1008

1009 1010 1011
    	     ,	sep [ptext (sLit "Matching instances:"),
    		     nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]

Simon Peyton Jones's avatar