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

59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77
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
78

79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106
  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
and does not fail if -fwarn-type-errors is on, so that we can continue
compilation. The errors are turned into warnings in `reportUnsolved`.

\begin{code}
reportUnsolved :: WantedConstraints -> TcM (Bag EvBind)
reportUnsolved wanted
  = do { binds_var <- newTcEvBinds
       ; defer <- doptM Opt_DeferTypeErrors
       ; 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
107
reportAllUnsolved wanted = report_unsolved Nothing False wanted
108 109 110 111

report_unsolved :: Maybe EvBindsVar  -- cec_binds
                -> Bool              -- cec_defer
                -> WantedConstraints -> TcM ()
112 113 114
-- Important precondition:
-- WantedConstraints are fully zonked and unflattened, that is,
-- zonkWC has already been applied to these constraints.
115
report_unsolved mb_binds_var defer wanted
116
  | isEmptyWC wanted
117
  = return ()
118
  | otherwise
119
  = do { traceTc "reportUnsolved (before unflattening)" (ppr wanted)
120

121
       ; env0 <- tcInitTidyEnv
122 123 124
                 
            -- If we are deferring we are going to need /all/ evidence around,
            -- including the evidence produced by unflattening (zonkWC)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
125
--       ; errs_so_far <- ifErrsM (return True) (return False)
126
       ; let tidy_env = tidyFreeTyVars env0 free_tvs
127
             free_tvs = tyVarsOfWC wanted
128
             err_ctxt = CEC { cec_encl  = []
129
                            , cec_tidy  = tidy_env
130
                            , cec_defer    = defer
131 132 133
                            , cec_suppress = insolubleWC wanted
                                  -- Suppress all but insolubles if there are
                                  -- any insoulubles, or earlier errors
134
                            , cec_binds    = mb_binds_var }
135

136 137 138
       ; traceTc "reportUnsolved (after unflattening):" $ 
         vcat [ pprTvBndrs (varSetElems free_tvs)
              , ppr wanted ]
139

140
       ; reportWanteds err_ctxt wanted }
141

142 143 144
--------------------------------------------
--      Internal functions
--------------------------------------------
145 146 147 148

data ReportErrCtxt 
    = CEC { cec_encl :: [Implication]  -- Enclosing implications
                	       	       --   (innermost first)
149
                                       -- ic_skols and givens are tidied, rest are not
150
          , cec_tidy  :: TidyEnv
151 152 153 154 155
          , 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
156

157 158
          , cec_defer :: Bool       -- True <=> -fdefer-type-errors
                                    -- Irrelevant if cec_binds = Nothing
159 160 161
          , cec_suppress :: Bool    -- True <=> More important errors have occurred,
                                    --          so create bindings if need be, but
                                    --          don't issue any more errors/warnings
162 163
      }

164 165 166
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
167
                                 , ic_insol = ic_insoluble, ic_info = info })
168
  | BracketSkol <- info
Simon Peyton Jones's avatar
Simon Peyton Jones committed
169 170 171 172
  , 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
173 174

  | otherwise
175
  = reportWanteds ctxt' wanted
176
  where
177
    (env1, tvs') = mapAccumL tidyTyVarBndr (cec_tidy ctxt) tvs
178
    (env2, info') = tidySkolemInfo env1 info
179
    implic' = implic { ic_skols = tvs'
180 181 182
                     , ic_given = map (tidyEvVar env2) given
                     , ic_info  = info' }
    ctxt' = ctxt { cec_tidy  = env2
183
                 , cec_encl  = implic' : cec_encl ctxt
184
                 , cec_binds = case cec_binds ctxt of
185 186 187 188 189
                                 Nothing -> Nothing
                                 Just {} -> Just evb }

reportWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
reportWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = implics })
190 191
  = do { reportFlats (ctxt { cec_suppress = False }) (mapBag (tidyCt env) insols)
       ; reportFlats ctxt                            (mapBag (tidyCt env) flats)
192
       ; mapBagM_ (reportImplic ctxt) implics }
193
  where
194
    env = cec_tidy ctxt
195
--    tidy_cts = mapBag (tidyCt env) (insols `unionBags` flats)
196 197 198
                  -- All the Derived ones have been filtered out alrady
                  -- by the constraint solver. This is ok; we don't want
                  -- to report unsolved Derived goals as error
199
                  -- See Note [Do not report derived but soluble errors]
200

201 202
reportFlats :: ReportErrCtxt -> Cts -> TcM ()
reportFlats ctxt flats    -- Here 'flats' includes insolble goals
Simon Peyton Jones's avatar
Simon Peyton Jones committed
203 204
  = traceTc "reportFlats" (ppr flats) >>
    tryReporters 
205 206 207
      [ -- First deal with things that are utterly wrong
        -- Like Int ~ Bool (incl nullary TyCons)
        -- or  Int ~ t a   (AppTy on one side)
208 209
        ("Utterly wrong",  utterly_wrong,   mkGroupReporter mkEqErr)
      , ("Holes",          is_hole,         mkUniReporter mkHoleError)
210 211 212 213

        -- 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
214 215 216
      , ("Skolem equalities",    skolem_eq,   mkUniReporter mkEqErr1) ]
--      , ("Unambiguous",          unambiguous, reportFlatErrs) ]
      reportFlatErrs
217
      ctxt (bagToList flats)
218
  where
Simon Peyton Jones's avatar
Simon Peyton Jones committed
219
    utterly_wrong, skolem_eq :: Ct -> PredTree -> Bool
220 221 222
    utterly_wrong _ (EqPred ty1 ty2) = isRigid ty1 && isRigid ty2 
    utterly_wrong _ _ = False

223 224
    is_hole ct _ = isHoleCt ct

225 226 227
    skolem_eq _ (EqPred ty1 ty2) = isRigidOrSkol ty1 && isRigidOrSkol ty2 
    skolem_eq _ _ = False

Simon Peyton Jones's avatar
Simon Peyton Jones committed
228 229
{-
    unambiguous :: Ct -> PredTree -> Bool
230 231 232 233 234 235 236
    unambiguous ct pred 
      | not (any isAmbiguousTyVar (varSetElems (tyVarsOfCt ct)))
      = True
      | otherwise 
      = case pred of
          EqPred ty1 ty2 -> isNothing (isTyFun_maybe ty1) && isNothing (isTyFun_maybe ty2)
          _              -> False
Simon Peyton Jones's avatar
Simon Peyton Jones committed
237
-}
238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256

---------------
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

-----------------
257
reportFlatErrs :: Reporter
258 259 260 261
-- 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
262
reportFlatErrs
263
  = tryReporters
264
      [ ("Equalities", is_equality, mkGroupReporter mkEqErr) ]
265 266 267 268
      (\ctxt cts -> do { let (dicts, ips, irreds) = go cts [] [] []
                       ; mkGroupReporter mkIPErr    ctxt ips   
                       ; mkGroupReporter mkIrredErr ctxt irreds
                       ; mkGroupReporter mkDictErr  ctxt dicts })
269
  where
270 271 272 273 274 275
    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
276 277
      | isIPPred (ctPred ct) 
      = go cts dicts (ct:ips) irreds
278
      | otherwise
279 280 281
      = case classifyPredType (ctPred ct) of
          ClassPred {}  -> go cts (ct:dicts) ips irreds
          IrredPred {}  -> go cts dicts ips (ct:irreds)
282
          _             -> panic "reportFlatErrs"
batterseapower's avatar
batterseapower committed
283 284
    -- TuplePreds should have been expanded away by the constraint
    -- simplifier, so they shouldn't show up at this point
285 286
    -- And EqPreds are dealt with by the is_equality test

287 288

--------------------------------------------
289
--      Reporters
290 291
--------------------------------------------

292 293 294 295 296 297
type Reporter = ReportErrCtxt -> [Ct] -> TcM ()

mkUniReporter :: (ReportErrCtxt -> Ct -> TcM ErrMsg) -> Reporter
-- Reports errors one at a time
mkUniReporter mk_err ctxt 
  = mapM_ $ \ct -> 
298 299 300
    do { err <- mk_err ctxt ct
       ; maybeReportError ctxt err ct
       ; maybeAddDeferredBinding ctxt err ct }
301 302 303 304

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

308
mkGroupReporter _ _ [] 
309
  = return ()
310
mkGroupReporter mk_err ctxt (ct1 : rest)
311 312 313 314
  = do { err <- mk_err ctxt cts
       ; maybeReportError ctxt err ct1
       ; mapM_ (maybeAddDeferredBinding ctxt err) (ct1:rest)
               -- Add deferred bindings for all
315
       ; mkGroupReporter mk_err ctxt others }
316
  where
317
   loc               = cc_loc ct1
318 319
   cts               = ct1 : friends
   (friends, others) = partition is_friend rest
320
   is_friend friend  = cc_loc friend `same_loc` loc
321

322
   same_loc :: CtLoc -> CtLoc -> Bool
323 324
   same_loc l1 l2 = ctLocSpan l1 == ctLocSpan l2

325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351
maybeReportError :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
-- Report the error and/or make a deferred binding for it
maybeReportError ctxt err ct
  | cec_suppress ctxt
  = return ()
  | isHoleCt ct || cec_defer ctxt  -- And it's a hole or we have -fdefer-type-errors
  = reportWarning (makeIntoWarning err)
  | 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
  , Just ev_binds_var <- cec_binds ctxt  -- We hvae somewhere to put the bindings
  = 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 ()   
352 353 354 355 356 357

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) 
358
       ; go ctxt reporters cts
359 360
       ; traceTc "tryReporters }" empty }
  where
361 362 363 364 365 366 367 368 369 370
    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
371
                         -- But suppress their error messages
372
      where
373
       (yeses, nos) = partition keep_me cts
374
       keep_me ct = pred ct (classifyPredType (ctPred ct))
375 376

-- Add the "arising from..." part to a message about bunch of dicts
377
addArising :: CtOrigin -> SDoc -> SDoc
378
addArising orig msg = hang msg 2 (pprArising orig)
379

380
pprWithArising :: [Ct] -> (CtLoc, SDoc)
381 382
-- Print something like
--    (Eq a) arising from a use of x at y
383 384
--    (Show a) arising from a use of p at q
-- Also return a location for the error message
385
-- Works for Wanted/Derived only
386 387
pprWithArising [] 
  = panic "pprWithArising"
388 389
pprWithArising (ct:cts)
  | null cts
390
  = (loc, addArising (ctLocOrigin loc) 
dimitris's avatar
dimitris committed
391
                     (pprTheta [ctPred ct]))
392 393
  | otherwise
  = (loc, vcat (map ppr_one (ct:cts)))
394
  where
395
    loc = cc_loc ct
396
    ppr_one ct = hang (parens (pprType (ctPred ct))) 
397
                    2 (pprArisingAt (cc_loc ct))
398

399 400 401 402 403
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 }
404

405
type UserGiven = ([EvVar], SkolemInfo, SrcSpan)
406 407

getUserGivens :: ReportErrCtxt -> [UserGiven]
408
-- One item for each enclosing implication
409
getUserGivens (CEC {cec_encl = ctxt})
410
  = reverse $
411 412 413
    [ (givens, info, tcl_loc env) 
    | Implic {ic_given = givens, ic_env = env, ic_info = info } <- ctxt
    , not (null givens) ]
414 415
\end{code}

416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465
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
466 467 468 469 470 471 472
%************************************************************************
%*                  *
                Irreducible predicate errors
%*                  *
%************************************************************************

\begin{code}
473 474
mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkIrredErr ctxt cts 
475 476
  = do { (ctxt, binds_msg) <- relevantBindings ctxt ct1
       ; mkErrorMsg ctxt ct1 (msg $$ binds_msg) }
batterseapower's avatar
batterseapower committed
477
  where
478
    (ct1:_) = cts
479
    orig    = ctLocOrigin (cc_loc ct1)
480 481
    givens  = getUserGivens ctxt
    msg = couldNotDeduce givens (map ctPred cts, orig)
batterseapower's avatar
batterseapower committed
482

483
----------------
484 485
mkHoleError :: ReportErrCtxt -> Ct -> TcM ErrMsg
mkHoleError ctxt ct@(CHoleCan {})
486 487 488
  = do { let tyvars = varSetElems (tyVarsOfCt ct)
             tyvars_msg = map loc_msg tyvars
             msg = (text "Found hole" <+> quotes (text "_") 
489
                    <+> text "with type") <+> pprType (ctEvPred (cc_ev ct))
490
                   $$ (if null tyvars_msg then empty else text "Where:" <+> vcat tyvars_msg)
491 492
       ; (ctxt, binds_doc) <- relevantBindings ctxt ct
       ; mkErrorMsg ctxt ct (msg $$ binds_doc) }
493
  where
494 495 496 497 498 499 500
    loc_msg tv 
       = case tcTyVarDetails tv of
          SkolemTv {} -> quotes (ppr tv) <+> skol_msg
          MetaTv {}   -> quotes (ppr tv) <+> text "is a free type variable"
          det -> pprTcTyVarDetails det
       where 
          skol_msg = pprSkol (getSkolemInfo (cec_encl ctxt) tv) (getSrcLoc tv)
501 502

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

504
----------------
505 506
mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkIPErr ctxt cts
507 508 509
  = do { (ctxt, _, ambig_err) <- mkAmbigMsg ctxt cts
       ; (ctxt, bind_msg) <- relevantBindings ctxt ct1
       ; mkErrorMsg ctxt ct1 (msg $$ ambig_err $$ bind_msg) }
510
  where
511
    (ct1:_) = cts
512
    orig    = ctLocOrigin (cc_loc ct1)
513 514
    preds   = map ctPred cts
    givens  = getUserGivens ctxt
515 516
    msg | null givens
        = addArising orig $
517 518
          sep [ ptext (sLit "Unbound implicit parameter") <> plural cts
              , nest 2 (pprTheta preds) ] 
519
        | otherwise
520
        = couldNotDeduce givens (preds, orig)
521 522 523 524 525 526 527 528 529 530
\end{code}


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

\begin{code}
531 532 533 534 535 536 537 538 539
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
540 541
  = do { (ctxt, binds_msg) <- relevantBindings ctxt ct
       ; (ctxt, orig) <- zonkTidyOrigin ctxt orig
542
       ; let (is_oriented, wanted_msg) = mk_wanted_extra orig
543
       ; if isGiven ev then 
544
           mkEqErr_help ctxt (inaccessible_msg orig $$ binds_msg) ct Nothing ty1 ty2
545
         else
546
           mkEqErr_help ctxt (wanted_msg $$ binds_msg) ct is_oriented ty1 ty2 }
547
  where
548 549
    ev         = cc_ev ct
    orig       = ctLocOrigin (cc_loc ct)
dimitris's avatar
dimitris committed
550
    (ty1, ty2) = getEqPredTys (ctPred ct)
551

552 553 554
    inaccessible_msg orig = hang (ptext (sLit "Inaccessible code in"))
                               2 (ppr orig)

555 556
       -- If the types in the error message are the same as the types
       -- we are unifying, don't add the extra expected/actual message
557 558 559 560 561 562
    mk_wanted_extra orig@(TypeEqOrigin {})
      = mkExpectedActualMsg ty1 ty2 orig


    mk_wanted_extra (KindEqOrigin cty1 cty2 sub_o)
      = (Nothing, msg1 $$ msg2)
563
      where
564 565 566 567 568 569 570 571
        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)
572

573
mkEqErr_help, reportEqErr 
574
   :: ReportErrCtxt -> SDoc
575
   -> Ct
576
   -> Maybe SwapFlag   -- Nothing <=> not sure
577
   -> TcType -> TcType -> TcM ErrMsg
578 579 580 581
mkEqErr_help ctxt extra ct oriented ty1 ty2
  | Just tv1 <- tcGetTyVar_maybe ty1 = mkTyVarEqErr ctxt extra ct oriented tv1 ty2
  | Just tv2 <- tcGetTyVar_maybe ty2 = mkTyVarEqErr ctxt extra ct oriented tv2 ty1
  | otherwise                        = reportEqErr  ctxt extra ct oriented ty1 ty2
582

583 584 585 586
reportEqErr ctxt extra1 ct oriented ty1 ty2
  = do { (ctxt', extra2) <- mkEqInfoMsg ctxt ct ty1 ty2
       ; mkErrorMsg ctxt' ct (vcat [ misMatchOrCND ctxt' ct oriented ty1 ty2
                                   , extra2, extra1]) }
587

588
mkTyVarEqErr :: ReportErrCtxt -> SDoc -> Ct -> Maybe SwapFlag -> TcTyVar -> TcType -> TcM ErrMsg
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
589
-- tv1 and ty2 are already tidied
590
mkTyVarEqErr ctxt extra ct oriented tv1 ty2
591
  -- Occurs check
Simon Peyton Jones's avatar
Simon Peyton Jones committed
592 593
  |  isUserSkolem ctxt tv1   -- ty2 won't be a meta-tyvar, or else the thing would
     		   	     -- be oriented the other way round; see TcCanonical.reOrient
594
  || isSigTyVar tv1 && not (isTyVarTy ty2)
595 596 597
  = mkErrorMsg ctxt ct (vcat [ misMatchOrCND ctxt ct oriented ty1 ty2
                             , extraTyVarInfo ctxt ty1 ty2
                             , extra ])
598 599 600

  -- So tv is a meta tyvar, and presumably it is
  -- an *untouchable* meta tyvar, else it'd have been unified
601
  | not (k2 `tcIsSubKind` k1)   	 -- Kind error
602
  = mkErrorMsg ctxt ct $ (kindErrorMsg (mkTyVarTy tv1) ty2 $$ extra)
603

Simon Peyton Jones's avatar
Simon Peyton Jones committed
604 605 606 607 608
  | isNothing (occurCheckExpand tv1 ty2)
  = let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:") 2
                           (sep [ppr ty1, char '~', ppr ty2])
    in mkErrorMsg ctxt ct (occCheckMsg $$ extra)

609 610
  -- Check for skolem escape
  | (implic:_) <- cec_encl ctxt   -- Get the innermost context
611 612
  , Implic { ic_env = env, ic_skols = skols, ic_info = skol_info } <- implic
  , let esc_skols = filter (`elemVarSet` (tyVarsOfType ty2)) skols
613
  , not (null esc_skols)
614
  = do { let msg = misMatchMsg oriented ty1 ty2
615 616 617 618 619
             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") ]
620 621 622 623 624 625 626 627
             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) }
628 629 630

  -- Nastiest case: attempt to unify an untouchable variable
  | (implic:_) <- cec_encl ctxt   -- Get the innermost context
631 632 633 634 635 636 637 638 639 640
  , 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]) }
641

642
  | otherwise
643
  = reportEqErr ctxt extra ct oriented (mkTyVarTy tv1) ty2
644 645 646
        -- This *can* happen (Trac #6123, and test T2627b)
        -- Consider an ambiguous top-level constraint (a ~ F a)
        -- Not an occurs check, becuase F is a type function.
647
  where         
648 649 650
    k1 	= tyVarKind tv1
    k2 	= typeKind ty2
    ty1 = mkTyVarTy tv1
651

652
mkEqInfoMsg :: ReportErrCtxt -> Ct -> TcType -> TcType -> TcM (ReportErrCtxt, SDoc)
653 654 655 656 657 658 659 660 661
-- 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]
mkEqInfoMsg ctxt ct ty1 ty2
  = do { (ctxt', _, ambig_msg) <- if isJust mb_fun1 || isJust mb_fun2
                                  then mkAmbigMsg ctxt [ct]
                                  else return (ctxt, False, empty)
662
       ; return (ctxt', tyfun_msg $$ ambig_msg) }
663 664 665 666 667 668 669 670 671 672
  where
    mb_fun1 = isTyFun_maybe ty1
    mb_fun2 = isTyFun_maybe ty2
    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
673 674 675 676 677 678 679 680 681 682 683
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

684
misMatchOrCND :: ReportErrCtxt -> Ct -> Maybe SwapFlag -> TcType -> TcType -> SDoc
685 686 687 688
-- If oriented then ty1 is expected, ty2 is actual
misMatchOrCND ctxt ct oriented ty1 ty2
  | null givens || 
    (isRigid ty1 && isRigid ty2) || 
689
    isGivenCt ct
690 691 692 693
       -- If the equality is unconditionally insoluble
       -- or there is no context, don't report the context
  = misMatchMsg oriented ty1 ty2
  | otherwise      
694
  = couldNotDeduce givens ([mkEqPred ty1 ty2], orig)
695 696
  where
    givens = getUserGivens ctxt
697
    orig   = TypeEqOrigin ty1 ty2
698

699
couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc
700
couldNotDeduce givens (wanteds, orig)
701
  = vcat [ addArising orig (ptext (sLit "Could not deduce") <+> pprTheta wanteds)
dimitris's avatar
dimitris committed
702 703
         , vcat (pp_givens givens)]

704
pp_givens :: [UserGiven] -> [SDoc]
dimitris's avatar
dimitris committed
705 706
pp_givens givens 
   = case givens of
707 708 709
         []     -> []
         (g:gs) ->      ppr_given (ptext (sLit "from the context")) g
                 : map (ppr_given (ptext (sLit "or from"))) gs
710 711
    where 
       ppr_given herald (gs, skol_info, loc)
dimitris's avatar
dimitris committed
712
           = hang (herald <+> pprEvVarTheta gs)
713 714
                2 (sep [ ptext (sLit "bound by") <+> ppr skol_info
                       , ptext (sLit "at") <+> ppr loc])
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
715

716
extraTyVarInfo :: ReportErrCtxt -> TcType -> TcType -> SDoc
717 718
-- Add on extra info about the types themselves
-- NB: The types themselves are already tidied
719 720
extraTyVarInfo ctxt ty1 ty2
  = nest 2 (extra1 $$ extra2)
721
  where
722 723
    extra1 = tyVarExtraInfoMsg (cec_encl ctxt) ty1
    extra2 = tyVarExtraInfoMsg (cec_encl ctxt) ty2
724

725
tyVarExtraInfoMsg :: [Implication] -> Type -> SDoc
726
-- Shows a bit of extra info about skolem constants
727
tyVarExtraInfoMsg implics ty
728
  | Just tv <- tcGetTyVar_maybe ty
Simon Peyton Jones's avatar
Simon Peyton Jones committed
729 730 731
  , isTcTyVar tv, isSkolemTyVar tv
  , let pp_tv = quotes (ppr tv)
 = case tcTyVarDetails tv of
732
    SkolemTv {}   -> pp_tv <+> pprSkol (getSkolemInfo implics tv) (getSrcLoc tv)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
733 734 735 736 737 738 739
    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
 
740 741 742 743 744 745 746 747 748
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

749
--------------------
750
misMatchMsg :: Maybe SwapFlag -> TcType -> TcType -> SDoc	   -- Types are already tidy
751
-- If oriented then ty1 is expected, ty2 is actual
752 753 754 755
misMatchMsg oriented ty1 ty2  
  | Just IsSwapped <- oriented
  = misMatchMsg (Just NotSwapped) ty2 ty1
  | Just NotSwapped <- oriented
756 757 758 759 760 761 762 763
  = sep [ ptext (sLit "Couldn't match expected") <+> what <+> quotes (ppr ty1)
        , nest 12 $   ptext (sLit "with actual") <+> what <+> quotes (ppr ty2) ]
  | 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")
764

765 766 767 768 769 770 771 772 773 774
mkExpectedActualMsg :: Type -> Type -> CtOrigin -> (Maybe SwapFlag, SDoc)
mkExpectedActualMsg ty1 ty2 (TypeEqOrigin { uo_actual = act, uo_expected = exp })
  | act `pickyEqType` ty1, exp `pickyEqType` ty2 = (Just IsSwapped,  empty)
  | exp `pickyEqType` ty1, act `pickyEqType` ty2 = (Just NotSwapped, empty)
  | otherwise                                    = (Nothing, msg)
  where
    msg = vcat [ text "Expected type:" <+> ppr exp
               , text "  Actual type:" <+> ppr act ]

mkExpectedActualMsg _ _ _ = panic "mkExprectedAcutalMsg"
775 776
\end{code}

Simon Peyton Jones's avatar
Simon Peyton Jones committed
777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794
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.

795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812
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}
813 814
mkDictErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkDictErr ctxt cts 
815 816 817 818 819 820 821
  = 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
822 823 824
       -- But we report only one of them (hence 'head') becuase they all
       -- have the same source-location origin, to try avoid a cascade
       -- of error from one location
825
       ; (ctxt, err) <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts))
826
       ; mkErrorMsg ctxt ct1 err }
827
  where
828
    ct1:_ = cts
829 830 831 832 833 834 835 836 837 838
    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) }
839
      where
840
        (clas, tys) = getClassPredTys (ctPred ct)
841

842
mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult)
843
            -> TcM (ReportErrCtxt, SDoc)
844 845 846 847
-- 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
848 849
  = do { (ctxt, is_ambig, ambig_msg) <- mkAmbigMsg ctxt [ct]
       ; (ctxt, binds_msg) <- relevantBindings ctxt ct
Simon Peyton Jones's avatar
Simon Peyton Jones committed
850
       ; traceTc "mk_dict_err" (ppr ct $$ ppr is_ambig $$ ambig_msg)
851
       ; return (ctxt, cannot_resolve_msg is_ambig binds_msg ambig_msg) }
852

853 854
  | not safe_haskell   -- Some matches => overlap errors
  = return (ctxt, overlap_msg)
855

856 857 858
  | otherwise
  = return (ctxt, safe_haskell_msg)
  where
859
    orig        = ctLocOrigin (cc_loc ct)
860 861 862 863 864 865
    pred        = ctPred ct
    (clas, tys) = getClassPredTys pred
    ispecs      = [ispec | (ispec, _) <- matches]
    givens      = getUserGivens ctxt
    all_tyvars  = all isTyVarTy tys

866
    cannot_resolve_msg has_ambig_tvs binds_msg ambig_msg
867 868
      = vcat [ addArising orig (no_inst_herald <+> pprParendType pred)
             , vcat (pp_givens givens)
869
             , if (has_ambig_tvs && not (null unifiers && null givens))
Simon Peyton Jones's avatar
Simon Peyton Jones committed
870
               then vcat [ ambig_msg, binds_msg, potential_msg ]
871
               else empty
872
             , show_fixes (add_to_ctxt_fixes has_ambig_tvs ++ drv_fixes) ]
873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893

    potential_msg
      | null unifiers = empty
      | otherwise 
      = hang (if isSingleton unifiers 
              then ptext (sLit "Note: there is a potential instance available:")
              else ptext (sLit "Note: there are several potential instances:"))
    	   2 (ppr_insts unifiers)

    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
894 895

	-- Do not suggest adding constraints to an *inferred* type signature!
896 897 898
    get_good_orig ic = case ic_info ic of 
                         SigSkol (InfSigCtxt {}) _ -> Nothing
                         origin                    -> Just origin
899

900 901 902
    no_inst_herald
      | null givens && null matches = ptext (sLit "No instance for")
      | otherwise                   = ptext (sLit "Could not deduce")
903

904 905 906
    drv_fixes = case orig of
                   DerivOrigin -> [drv_fix]
                   _           -> []
907

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

911
    -- Normal overlap error
912
    overlap_msg
913 914
      = ASSERT( not (null matches) )
        vcat [	addArising orig (ptext (sLit "Overlapping instances for") 
batterseapower's avatar
batterseapower committed
915
				<+> pprType (mkClassPred clas tys))
dimitris's avatar
dimitris committed
916

917
             ,  if not (null matching_givens) then 
918
                  sep [ptext (sLit "Matching givens (or their superclasses):") 
919
                      , nest 2 (vcat matching_givens)]
dimitris's avatar
dimitris committed
920 921
                else empty

922 923 924
    	     ,	sep [ptext (sLit "Matching instances:"),
    		     nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]

925 926 927 928 929 930 931
             ,  if null matching_givens && isSingleton matches && null unifiers then
                -- Intuitively, some given matched the wanted in their
                -- flattened or rewritten (from given equalities) form
                -- but the matcher can't figure that out because the
                -- constraints are non-flat and non-rewritten so we
                -- simply report back the whole given
                -- context. Accelerate Smart.hs showed this problem.
932
                  sep [ ptext (sLit "There exists a (perhaps superclass) match:") 
933
                      , nest 2 (vcat (pp_givens givens))]
dimitris's avatar
dimitris committed
934 935
                else empty 

936 937 938
	     ,	if not (isSingleton matches)
    		then 	-- Two or more matches
		     empty
Simon Peyton Jones's avatar
Simon Peyton Jones committed
939
    		else 	-- One match
940
		parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
batterseapower's avatar
batterseapower committed
941
	    		         quotes (pprWithCommas ppr (varSetElems (tyVarsOfTypes tys))),
942
			      if null (matching_givens) then
dimitris's avatar
dimitris committed
943 944 945
                                   vcat [ ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
			                  ptext (sLit "when compiling the other instance declarations")]
                              else empty])]
946 947 948 949
        where
            ispecs = [ispec | (ispec, _) <- matches]

            givens = getUserGivens ctxt
950 951
            matching_givens = mapCatMaybes matchable givens

952
            matchable (evvars,skol_info,loc) 
953 954 955
              = case ev_vars_matching of
                     [] -> Nothing
                     _  -> Just $ hang (pprTheta ev_vars_matching)
956 957
                                    2 (sep [ ptext (sLit "bound by") <+> ppr skol_info
                                           , ptext (sLit "at") <+> ppr loc])
958
                where ev_vars_matching = filter ev_var_matches (map evVarPred evvars)
batterseapower's avatar
batterseapower committed
959 960 961 962 963 964 965 966
                      ev_var_matches ty = case getClassPredTys_maybe ty of
                         Just (clas', tys')
                           | clas' == clas
                           , Just _ <- tcMatchTys (tyVarsOfTypes tys) tys tys'
                           -> True 
                           | otherwise
                           -> any ev_var_matches (immSuperClasses clas' tys')
                         Nothing -> False
967

968 969 970
    -- Overlap error because of Safe Haskell (first 
    -- match should be the most specific match)
    safe_haskell_msg
971 972
      = ASSERT( length matches > 1 )
        vcat [ addArising orig (ptext (sLit "Unsafe overlapping instances for") 
batterseapower's avatar
batterseapower committed
973
                        <+> pprType (mkClassPred clas tys))
974
             , sep [ptext (sLit "The matching instance is:"),
975 976 977 978 979 980 981
                    nest 2 (pprInstance $ head ispecs)]
             , vcat [ ptext $ sLit "It is compiled in a Safe module and as such can only"
                    , ptext $ sLit "overlap instances from the same module, however it"
                    , ptext $ sLit "overlaps the following instances from different modules:"
                    , nest 2 (vcat [pprInstances $ tail ispecs])
                    ]
             ]
982 983 984 985 986 987 988 989 990 991 992 993 994 995 996

show_fixes :: [SDoc] -> SDoc
show_fixes []     = empty
show_fixes (f:fs) = sep [ ptext (sLit "Possible fix:")
                        , nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]

ppr_insts :: [ClsInst] -> SDoc
ppr_insts insts
  = pprInstances (take 3 insts) $$ dot_dot_message
  where
    n_extra = length insts - 3
    dot_dot_message 
       | n_extra <= 0 = empty
       | otherwise    = ptext (sLit "...plus") 
                        <+> speakNOf n_extra (ptext (sLit "other"))
dimitris's avatar
dimitris committed
997

998 999 1000 1001 1002 1003
----------------------
quickFlattenTy :: TcType -> TcM TcType
-- See Note [Flattening in error message generation]
quickFlattenTy ty | Just ty' <- tcView ty = quickFlattenTy ty'
quickFlattenTy ty@(TyVarTy {})  = return ty
quickFlattenTy ty@(ForAllTy {}) = return ty     -- See
1004
quickFlattenTy ty@(LitTy {})    = return ty
1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047
  -- Don't flatten because of the danger or removing a bound variable
quickFlattenTy (AppTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
                                    ; fy2 <- quickFlattenTy ty2
                                    ; return (AppTy fy1 fy2) }
quickFlattenTy (FunTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
                                    ; fy2 <- quickFlattenTy ty2
                                    ; return (FunTy fy1 fy2) }
quickFlattenTy (TyConApp tc tys)
    | not (isSynFamilyTyCon tc)
    = do { fys <- mapM quickFlattenTy tys 
         ; return (TyConApp tc fys) }
    | otherwise
    = do { let (funtys,resttys) = splitAt (tyConArity tc) tys
                -- Ignore the arguments of the type family funtys
         ; v <- newMetaTyVar TauTv (typeKind (TyConApp tc funtys))
         ; flat_resttys <- mapM quickFlattenTy resttys
         ; return (foldl AppTy (mkTyVarTy v) flat_resttys) }
\end{code}

Note [Flattening in error message generation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider (C (Maybe (F x))), where F is a type function, and we have
instances
                C (Maybe Int) and C (Maybe a)
Since (F x) might turn into Int, this is an overlap situation, and
indeed (because of flattening) the main solver will have refrained
from solving.  But by the time we get to error message generation, we've
un-flattened the constraint.  So we must *re*-flatten it before looking
up in the instance environment, lest we only report one matching
instance when in fact there are two.

Re-flattening is pretty easy, because we don't need to keep track of
evidence.  We don't re-use