TcErrors.lhs 63 KB
Newer Older
1
\begin{code}
2
{-# LANGUAGE CPP, ScopedTypeVariables #-}
3 4

module TcErrors(
5
       reportUnsolved, reportAllUnsolved,
6
       warnDefaulting,
7 8

       solverDepthErrorTcS
9 10 11 12
  ) where

#include "HsVersions.h"

13
import TcRnTypes
14 15 16
import TcRnMonad
import TcMType
import TcType
17
import TypeRep
batterseapower's avatar
batterseapower committed
18
import Type
19
import Kind ( isKind )
20
import Unify            ( tcMatchTys )
21
import Module
22
import FamInst          ( FamInstEnvs, tcGetFamInstEnvs, tcLookupDataFamInst )
23 24 25
import Inst
import InstEnv
import TyCon
26
import DataCon
27
import TcEvidence
28
import TysWiredIn       ( coercibleClass )
29
import Name
30
import RdrName          ( lookupGRE_Name )
31
import Id
32 33 34 35
import Var
import VarSet
import VarEnv
import Bag
36
import ErrUtils         ( ErrMsg, makeIntoWarning, pprLocErrMsg )
37
import BasicTypes
38 39 40
import Util
import FastString
import Outputable
41
import SrcLoc
42
import DynFlags
43
import ListSetOps       ( equivClasses )
Icelandjack's avatar
Icelandjack committed
44 45

import Data.Maybe
46
import Data.List        ( partition, mapAccumL, zip4, nub )
47 48 49
\end{code}

%************************************************************************
50
%*                                                                      *
51
\section{Errors and contexts}
52
%*                                                                      *
53 54 55 56 57 58
%************************************************************************

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
  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
93
and does not fail if -fdefer-type-errors is on, so that we can continue
94 95 96 97 98 99
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
100
       ; defer <- goptM Opt_DeferTypeErrors
101 102 103 104 105 106
       ; 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)
125
       ; let tidy_env = tidyFreeTyVars env0 free_tvs
126
             free_tvs = tyVarsOfWC wanted
127
             err_ctxt = CEC { cec_encl  = []
128
                            , cec_tidy  = tidy_env
129
                            , cec_defer    = defer
130
                            , cec_suppress = False -- See Note [Suppressing error messages]
131
                            , cec_binds    = mb_binds_var }
132

133
       ; traceTc "reportUnsolved (after unflattening):" $
134 135
         vcat [ pprTvBndrs (varSetElems free_tvs)
              , ppr wanted ]
136

137
       ; reportWanteds err_ctxt wanted }
138

139 140 141
--------------------------------------------
--      Internal functions
--------------------------------------------
142

143
data ReportErrCtxt
144
    = CEC { cec_encl :: [Implication]  -- Enclosing implications
145
                                       --   (innermost first)
146
                                       -- ic_skols and givens are tidied, rest are not
147
          , cec_tidy  :: TidyEnv
148
          , cec_binds :: Maybe EvBindsVar
149 150 151 152
                         -- 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
153

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

163 164 165 166 167 168 169
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.
170
  * If there are any insolubles (eg Int~Bool), here or in a nested implication,
171 172 173 174 175
    then suppress errors from the flat constraints here.  Sometimes the
    flat-constraint errors are a knock-on effect of the insolubles.


\begin{code}
176 177 178
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
179
                                 , ic_insol = ic_insoluble, ic_info = info })
180
  | BracketSkol <- info
Simon Peyton Jones's avatar
Simon Peyton Jones committed
181 182 183 184
  , 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
185 186

  | otherwise
187
  = reportWanteds ctxt' wanted
188
  where
189
    (env1, tvs') = mapAccumL tidyTyVarBndr (cec_tidy ctxt) tvs
190
    (env2, info') = tidySkolemInfo env1 info
191
    implic' = implic { ic_skols = tvs'
192 193 194
                     , ic_given = map (tidyEvVar env2) given
                     , ic_info  = info' }
    ctxt' = ctxt { cec_tidy  = env2
195
                 , cec_encl  = implic' : cec_encl ctxt
196
                 , cec_binds = case cec_binds ctxt of
197 198 199 200
                                 Nothing -> Nothing
                                 Just {} -> Just evb }

reportWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
201 202 203 204
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)
205
            -- All the Derived ones have been filtered out of flats
206 207 208
            -- 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]
209 210 211 212 213 214
       ; 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
215 216
    env = cec_tidy ctxt

217 218 219 220 221 222 223
      -- 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 }

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

        -- Report equalities of form (a~ty).  They are usually
236
        -- skolem-equalities, and they cause confusing knock-on
237
        -- effects in other errors; see test T4093b.
238 239 240 241 242 243 244 245 246 247 248 249
      , ("Skolem equalities", skolem_eq,  True,  mkSkolReporter)

        -- Other equalities; also confusing knock on effects
      , ("Equalities",      is_equality, True,  mkGroupReporter mkEqErr)

      , ("Implicit params", is_ip,       False, mkGroupReporter mkIPErr)
      , ("Irreds",          is_irred,    False, mkGroupReporter mkIrredErr)
      , ("Dicts",           is_dict,     False, mkGroupReporter mkDictErr)
      ]
      panicReporter ctxt (bagToList flats)
          -- TuplePreds should have been expanded away by the constraint
          -- simplifier, so they shouldn't show up at this point
250
  where
251 252 253 254
    utterly_wrong, skolem_eq, is_hole, is_dict,
      is_equality, is_ip, is_irred :: Ct -> PredTree -> Bool

    utterly_wrong _ (EqPred ty1 ty2) = isRigid ty1 && isRigid ty2
255 256
    utterly_wrong _ _ = False

257 258
    is_hole ct _ = isHoleCt ct

259
    skolem_eq _ (EqPred ty1 ty2) = isRigidOrSkol ty1 && isRigidOrSkol ty2
260 261
    skolem_eq _ _ = False

262 263 264 265 266 267 268 269 270 271 272 273 274
    is_equality _ (EqPred {}) = True
    is_equality _ _           = False

    is_dict _ (ClassPred {}) = True
    is_dict _ _              = False

    is_ip _ (ClassPred cls _) = isIPClass cls
    is_ip _ _                 = False

    is_irred _ (IrredPred {}) = True
    is_irred _ _              = False


275 276
---------------
isRigid, isRigidOrSkol :: Type -> Bool
277
isRigid ty
278 279 280 281 282
  | Just (tc,_) <- tcSplitTyConApp_maybe ty = isDecomposableTyCon tc
  | Just {} <- tcSplitAppTy_maybe ty        = True
  | isForAllTy ty                           = True
  | otherwise                               = False

283
isRigidOrSkol ty
284 285 286 287 288 289 290 291
  | 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

292 293

--------------------------------------------
294
--      Reporters
295 296
--------------------------------------------

297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318
type Reporter
  = ReportErrCtxt -> [Ct] -> TcM ()
type ReporterSpec
  = ( String                     -- Name
    , Ct -> PredTree -> Bool     -- Pick these ones
    , Bool                       -- True <=> suppress subsequent reporters
    , Reporter)                  -- The reporter itself

panicReporter :: Reporter
panicReporter _ cts
  | null cts  = return ()
  | otherwise =  pprPanic "reportFlats" (ppr cts)

mkSkolReporter :: Reporter
-- Suppress duplicates with the same LHS
mkSkolReporter ctxt cts
  = mapM_ (reportGroup mkEqErr ctxt) (equivClasses cmp_lhs_type cts)
  where
    cmp_lhs_type ct1 ct2
      = case (classifyPredType (ctPred ct1), classifyPredType (ctPred ct2)) of
           (EqPred ty1 _, EqPred ty2 _) -> ty1 `cmpType` ty2
           _ -> pprPanic "mkSkolReporter" (ppr ct1 $$ ppr ct2)
319 320 321

mkUniReporter :: (ReportErrCtxt -> Ct -> TcM ErrMsg) -> Reporter
-- Reports errors one at a time
322 323
mkUniReporter mk_err ctxt
  = mapM_ $ \ct ->
324
    do { err <- mk_err ctxt ct
325
       ; maybeReportError ctxt err
326
       ; maybeAddDeferredBinding ctxt err ct }
327 328 329 330

mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg)
                             -- Make error message for a group
                -> Reporter  -- Deal with lots of constraints
331 332 333 334 335
-- Group together errors from same location,
-- and report only the first (to avoid a cascade)
mkGroupReporter mk_err ctxt cts
  = mapM_ (reportGroup mk_err ctxt) (equivClasses cmp_loc cts)
  where
336
    cmp_loc ct1 ct2 = ctLocSpan (ctLoc ct1) `compare` ctLocSpan (ctLoc ct2)
337

338 339 340 341
reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> ReportErrCtxt
            -> [Ct] -> TcM ()
reportGroup mk_err ctxt cts
  = do { err <- mk_err ctxt cts
342
       ; maybeReportError ctxt err
343
       ; mapM_ (maybeAddDeferredBinding ctxt err) cts }
344
               -- Add deferred bindings for all
345
               -- But see Note [Always warn with -fdefer-type-errors]
346

347
maybeReportError :: ReportErrCtxt -> ErrMsg -> TcM ()
348
-- Report the error and/or make a deferred binding for it
349
maybeReportError ctxt err
350
  | cec_defer ctxt  -- See Note [Always warn with -fdefer-type-errors]
351
  = reportWarning (makeIntoWarning err)
352 353 354 355 356 357 358 359
  | cec_suppress ctxt
  = return ()
  | otherwise
  = reportError err

maybeAddDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
-- See Note [Deferring coercion errors to runtime]
maybeAddDeferredBinding ctxt err ct
360
  | CtWanted { ctev_pred = pred, ctev_evar = ev_id } <- ctEvidence ct
361 362
    -- Only add deferred bindings for Wanted constraints
  , isHoleCt ct || cec_defer ctxt  -- And it's a hole or we have -fdefer-type-errors
363
  , Just ev_binds_var <- cec_binds ctxt  -- We have somewhere to put the bindings
364 365 366 367 368 369 370 371 372
  = 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
373
  = return ()
374

375
tryReporters :: [ReporterSpec] -> Reporter -> Reporter
376 377
-- Use the first reporter in the list whose predicate says True
tryReporters reporters deflt ctxt cts
378
  = do { traceTc "tryReporters {" (ppr cts)
379
       ; go ctxt reporters cts
380 381
       ; traceTc "tryReporters }" empty }
  where
382 383
    go ctxt [] cts = deflt ctxt cts
    go ctxt ((str, pred, suppress_after, reporter) : rs) cts
384 385 386 387
      | 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 ()
388 389
                         ; let ctxt' = ctxt { cec_suppress = suppress_after || cec_suppress ctxt }
                         ; go ctxt' rs nos }
390
                         -- Carry on with the rest, because we must make
391
                         -- deferred bindings for them if we have
392
                         -- -fdefer-type-errors
Simon Peyton Jones's avatar
Simon Peyton Jones committed
393
                         -- But suppress their error messages
394
      where
395
       (yeses, nos) = partition keep_me cts
396
       keep_me ct = pred ct (classifyPredType (ctPred ct))
397 398

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

402
pprWithArising :: [Ct] -> (CtLoc, SDoc)
403 404
-- Print something like
--    (Eq a) arising from a use of x at y
405 406
--    (Show a) arising from a use of p at q
-- Also return a location for the error message
407
-- Works for Wanted/Derived only
408
pprWithArising []
409
  = panic "pprWithArising"
410 411
pprWithArising (ct:cts)
  | null cts
412
  = (loc, addArising (ctLocOrigin loc)
dimitris's avatar
dimitris committed
413
                     (pprTheta [ctPred ct]))
414 415
  | otherwise
  = (loc, vcat (map ppr_one (ct:cts)))
416
  where
417
    loc = ctLoc ct
418
    ppr_one ct' = hang (parens (pprType (ctPred ct')))
419
                     2 (pprArisingAt (ctLoc ct'))
420

421
mkErrorMsg :: ReportErrCtxt -> Ct -> SDoc -> TcM ErrMsg
422
mkErrorMsg ctxt ct msg
423
  = do { let tcl_env = ctLocEnv (ctLoc ct)
424 425
       ; err_info <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)
       ; mkLongErrAt (tcl_loc tcl_env) msg err_info }
426

427
type UserGiven = ([EvVar], SkolemInfo, SrcSpan)
428 429

getUserGivens :: ReportErrCtxt -> [UserGiven]
430
-- One item for each enclosing implication
431
getUserGivens (CEC {cec_encl = ctxt})
432
  = reverse $
433
    [ (givens, info, tcl_loc env)
434 435
    | Implic {ic_given = givens, ic_env = env, ic_info = info } <- ctxt
    , not (null givens) ]
436 437
\end{code}

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
444
time.
445 446 447 448 449

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
450
location in mkGroupReporter, when -fdefer-type-errors is on.  But that
451 452 453
is perhaps a bit *over*-consistent! Again, an easy choice to change.


454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474
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
475
        MkT :: C Int b => a -> b -> T a
476 477 478 479 480 481 482 483 484
      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.)

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

  class C a b | a -> b
489 490 491 492
  g :: C a b => a -> b -> ()
  f :: C a b => a -> b -> ()
  f xa xb =
      let loop = g xa
493 494 495 496
      in loop xb

We will first try to infer a type for loop, and we will succeed:
    C a b' => b' -> ()
497 498 499 500 501
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.
502 503


batterseapower's avatar
batterseapower committed
504 505 506 507 508 509 510
%************************************************************************
%*                  *
                Irreducible predicate errors
%*                  *
%************************************************************************

\begin{code}
511
mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
512
mkIrredErr ctxt cts
513
  = do { (ctxt, binds_msg) <- relevantBindings True ctxt ct1
514
       ; mkErrorMsg ctxt ct1 (msg $$ binds_msg) }
batterseapower's avatar
batterseapower committed
515
  where
516
    (ct1:_) = cts
517
    orig    = ctLocOrigin (ctLoc ct1)
518 519
    givens  = getUserGivens ctxt
    msg = couldNotDeduce givens (map ctPred cts, orig)
batterseapower's avatar
batterseapower committed
520

521
----------------
522
mkHoleError :: ReportErrCtxt -> Ct -> TcM ErrMsg
523
mkHoleError ctxt ct@(CHoleCan { cc_occ = occ })
524 525
  = do { let tyvars = varSetElems (tyVarsOfCt ct)
             tyvars_msg = map loc_msg tyvars
526
             msg = vcat [ hang (ptext (sLit "Found hole") <+> quotes (ppr occ))
527
                             2 (ptext (sLit "with type:") <+> pprType (ctEvPred (ctEvidence ct)))
528
                        , ppUnless (null tyvars_msg) (ptext (sLit "Where:") <+> vcat tyvars_msg) ]
529 530
       ; (ctxt, binds_doc) <- relevantBindings False ctxt ct
               -- The 'False' means "don't filter the bindings; see Trac #8191
531
       ; mkErrorMsg ctxt ct (msg $$ binds_doc) }
532
  where
533
    loc_msg tv
534 535
       = case tcTyVarDetails tv of
          SkolemTv {} -> quotes (ppr tv) <+> skol_msg
536
          MetaTv {}   -> quotes (ppr tv) <+> ptext (sLit "is an ambiguous type variable")
537
          det -> pprTcTyVarDetails det
538
       where
539
          skol_msg = pprSkol (getSkolemInfo (cec_encl ctxt) tv) (getSrcLoc tv)
540 541

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

543
----------------
544 545
mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkIPErr ctxt cts
546
  = do { (ctxt, bind_msg) <- relevantBindings True ctxt ct1
547
       ; mkErrorMsg ctxt ct1 (msg $$ bind_msg) }
548
  where
549
    (ct1:_) = cts
550
    orig    = ctLocOrigin (ctLoc ct1)
551 552
    preds   = map ctPred cts
    givens  = getUserGivens ctxt
553 554
    msg | null givens
        = addArising orig $
555
          sep [ ptext (sLit "Unbound implicit parameter") <> plural cts
556
              , nest 2 (pprTheta preds) ]
557
        | otherwise
558
        = couldNotDeduce givens (preds, orig)
559 560 561 562
\end{code}


%************************************************************************
563
%*                                                                      *
564
                Equality errors
565
%*                                                                      *
566 567
%************************************************************************

568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585
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.

586
\begin{code}
587 588 589 590 591 592 593 594 595
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
596
  | isGiven ev
597
  = do { (ctxt, binds_msg) <- relevantBindings True ctxt ct
598
       ; let (given_loc, given_msg) = mk_given (cec_encl ctxt)
599
       ; dflags <- getDynFlags
600
       ; mkEqErr_help dflags ctxt (given_msg $$ binds_msg)
601
                      (ct { cc_ev = ev {ctev_loc = given_loc}}) -- Note [Inaccessible code]
602 603 604
                      Nothing ty1 ty2 }

  | otherwise   -- Wanted or derived
605
  = do { (ctxt, binds_msg) <- relevantBindings True ctxt ct
606
       ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc)
607
       ; let (is_oriented, wanted_msg) = mk_wanted_extra tidy_orig
608
       ; dflags <- getDynFlags
609
       ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctLocOrigin loc) $$ pprCtOrigin tidy_orig) 
610 611
       ; mkEqErr_help dflags (ctxt {cec_tidy = env1})
                      (wanted_msg $$ binds_msg)
612
                      ct is_oriented ty1 ty2 }
613
  where
614 615
    ev         = ctEvidence ct
    loc        = ctev_loc ev
616 617 618 619 620
    (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]
621 622
    mk_given []           = (loc, empty)
    mk_given (implic : _) = (setCtLocEnv loc (ic_env implic)
623 624
                            , hang (ptext (sLit "Inaccessible code in"))
                                 2 (ppr (ic_info implic)))
625

626 627
       -- If the types in the error message are the same as the types
       -- we are unifying, don't add the extra expected/actual message
628 629 630 631 632
    mk_wanted_extra orig@(TypeEqOrigin {})
      = mkExpectedActualMsg ty1 ty2 orig

    mk_wanted_extra (KindEqOrigin cty1 cty2 sub_o)
      = (Nothing, msg1 $$ msg2)
633
      where
634 635 636 637 638 639 640
        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

641 642 643
    mk_wanted_extra orig@(FunDepOrigin1 {}) = (Nothing, pprArising orig)
    mk_wanted_extra orig@(FunDepOrigin2 {}) = (Nothing, pprArising orig)
    mk_wanted_extra _                       = (Nothing, empty)
644

645
mkEqErr_help :: DynFlags -> ReportErrCtxt -> SDoc
646
             -> Ct
647 648 649 650 651
             -> 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
652
  | otherwise                        = reportEqErr  ctxt extra ct oriented ty1 ty2
653 654
  where
    swapped = fmap flipSwap oriented
655

656
reportEqErr :: ReportErrCtxt -> SDoc
657
            -> Ct
658 659
            -> Maybe SwapFlag   -- Nothing <=> not sure
            -> TcType -> TcType -> TcM ErrMsg
660
reportEqErr ctxt extra1 ct oriented ty1 ty2
661 662
  = do { let extra2 = mkEqInfoMsg ct ty1 ty2
       ; mkErrorMsg ctxt ct (vcat [ misMatchOrCND ctxt ct oriented ty1 ty2
663
                                   , extra2, extra1]) }
664

665
mkTyVarEqErr :: DynFlags -> ReportErrCtxt -> SDoc -> Ct
666
             -> Maybe SwapFlag -> TcTyVar -> TcType -> TcM ErrMsg
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
667
-- tv1 and ty2 are already tidied
668 669
mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2
  | isUserSkolem ctxt tv1   -- ty2 won't be a meta-tyvar, or else the thing would
670 671
                            -- be oriented the other way round;
                            -- see TcCanonical.canEqTyVarTyVar
672
  || isSigTyVar tv1 && not (isTyVarTy ty2)
673
  = mkErrorMsg ctxt ct (vcat [ misMatchOrCND ctxt ct oriented ty1 ty2
674
                             , extraTyVarInfo ctxt tv1 ty2
675
                             , extra ])
676

677 678
  -- So tv is a meta tyvar (or started that way before we
  -- generalised it).  So presumably it is an *untouchable*
679
  -- meta tyvar or a SigTv, else it'd have been unified
680
  | not (k2 `tcIsSubKind` k1)            -- Kind error
681
  = mkErrorMsg ctxt ct $ (kindErrorMsg (mkTyVarTy tv1) ty2 $$ extra)
682

683
  | OC_Occurs <- occ_check_expand
684 685
  = do { let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:")
                              2 (sep [ppr ty1, char '~', ppr ty2])
686 687
             extra2 = mkEqInfoMsg ct ty1 ty2
       ; mkErrorMsg ctxt ct (occCheckMsg $$ extra2 $$ extra) }
Simon Peyton Jones's avatar
Simon Peyton Jones committed
688

689 690 691 692
  | 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)
693
                        , nest 2 (ptext (sLit "Perhaps you want ImpredicativeTypes")) ]
694 695 696 697
       ; 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
698 699
  -- it started life as a SigTv, else it'd have been unified, given
  -- that there's no occurs-check or forall problem
700 701 702 703
  | (implic:_) <- cec_encl ctxt
  , Implic { ic_skols = skols } <- implic
  , tv1 `elem` skols
  = mkErrorMsg ctxt ct (vcat [ misMatchMsg oriented ty1 ty2
704
                             , extraTyVarInfo ctxt tv1 ty2
705 706
                             , extra ])

707 708
  -- Check for skolem escape
  | (implic:_) <- cec_encl ctxt   -- Get the innermost context
709 710
  , Implic { ic_env = env, ic_skols = skols, ic_info = skol_info } <- implic
  , let esc_skols = filter (`elemVarSet` (tyVarsOfType ty2)) skols
711
  , not (null esc_skols)
712
  = do { let msg = misMatchMsg oriented ty1 ty2
713 714 715 716 717
             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") ]
718
             tv_extra = vcat [ nest 2 $ esc_doc
719
                             , sep [ (if isSingleton esc_skols
720 721 722 723 724 725
                                      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) }
726 727 728

  -- Nastiest case: attempt to unify an untouchable variable
  | (implic:_) <- cec_encl ctxt   -- Get the innermost context
729 730
  , Implic { ic_env = env, ic_given = given, ic_info = skol_info } <- implic
  = do { let msg = misMatchMsg oriented ty1 ty2
731
             untch_extra
732 733 734 735 736
                = 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) ]
737
             tv_extra = extraTyVarInfo ctxt tv1 ty2
738 739
             add_sig  = suggestAddSig ctxt ty1 ty2
       ; mkErrorMsg ctxt ct (vcat [msg, untch_extra, tv_extra, add_sig, extra]) }
740

741
  | otherwise
742
  = reportEqErr ctxt extra ct oriented (mkTyVarTy tv1) ty2
743 744
        -- 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
745
        -- Not an occurs check, because F is a type function.
746
  where
747
    occ_check_expand = occurCheckExpand dflags tv1 ty2
748 749
    k1  = tyVarKind tv1
    k2  = typeKind ty2
750
    ty1 = mkTyVarTy tv1
751

752
mkEqInfoMsg :: Ct -> TcType -> TcType -> SDoc
753
-- Report (a) ambiguity if either side is a type function application
754
--            e.g. F a0 ~ Int
755 756 757
--        (b) warning about injectivity if both sides are the same
--            type function application   F a ~ F b
--            See Note [Non-injective type functions]
758 759
mkEqInfoMsg ct ty1 ty2
  = tyfun_msg $$ ambig_msg
760 761 762
  where
    mb_fun1 = isTyFun_maybe ty1
    mb_fun2 = isTyFun_maybe ty2
763

764
    ambig_msg | isJust mb_fun1 || isJust mb_fun2
765 766 767
              = snd (mkAmbigMsg ct)
              | otherwise = empty

768 769
    tyfun_msg | Just tc1 <- mb_fun1
              , Just tc2 <- mb_fun2
770 771
              , tc1 == tc2
              = ptext (sLit "NB:") <+> quotes (ppr tc1)
772 773 774
                <+> ptext (sLit "is a type function, and may not be injective")
              | otherwise = empty

Simon Peyton Jones's avatar
Simon Peyton Jones committed
775 776 777 778 779 780 781 782 783 784 785
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

786
misMatchOrCND :: ReportErrCtxt -> Ct -> Maybe SwapFlag -> TcType -> TcType -> SDoc
Simon Peyton Jones's avatar
Simon Peyton Jones committed
787
-- If oriented then ty1 is actual, ty2 is expected
788
misMatchOrCND ctxt ct oriented ty1 ty2
789 790
  | null givens ||
    (isRigid ty1 && isRigid ty2) ||
791
    isGivenCt ct
792 793 794
       -- If the equality is unconditionally insoluble
       -- or there is no context, don't report the context
  = misMatchMsg oriented ty1 ty2
795
  | otherwise
796
  = couldNotDeduce givens ([mkTcEqPred ty1 ty2], orig)
797 798
  where
    givens = getUserGivens ctxt
Simon Peyton Jones's avatar
Simon Peyton Jones committed
799
    orig   = TypeEqOrigin { uo_actual = ty1, uo_expected = ty2 }
800

801
couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc
802
couldNotDeduce givens (wanteds, orig)
803
  = vcat [ addArising orig (ptext (sLit "Could not deduce") <+> pprTheta wanteds)
dimitris's avatar
dimitris committed
804 805
         , vcat (pp_givens givens)]

806
pp_givens :: [UserGiven] -> [SDoc]
807
pp_givens givens
dimitris's avatar
dimitris committed
808
   = case givens of
809 810 811
         []     -> []
         (g:gs) ->      ppr_given (ptext (sLit "from the context")) g
                 : map (ppr_given (ptext (sLit "or from"))) gs
812
    where
813
       ppr_given herald (gs, skol_info, loc)
dimitris's avatar
dimitris committed
814
           = hang (herald <+> pprEvVarTheta gs)
815 816
                2 (sep [ ptext (sLit "bound by") <+> ppr skol_info
                       , ptext (sLit "at") <+> ppr loc])
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
817

818
extraTyVarInfo :: ReportErrCtxt -> TcTyVar -> TcType -> SDoc
819
-- Add on extra info about skolem constants
820
-- NB: The types themselves are already tidied
821 822
extraTyVarInfo ctxt tv1 ty2
  = nest 2 (tv_extra tv1 $$ ty_extra ty2)
823
  where
824
    implics = cec_encl ctxt
825 826 827 828 829
    ty_extra ty = case tcGetTyVar_maybe ty of
                    Just tv -> tv_extra tv
                    Nothing -> empty

    tv_extra tv | isTcTyVar tv, isSkolemTyVar tv
830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857
                , let pp_tv = quotes (ppr tv)
                = case tcTyVarDetails tv of
                    SkolemTv {}   -> pp_tv <+> pprSkol (getSkolemInfo implics tv) (getSrcLoc tv)
                    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

suggestAddSig :: ReportErrCtxt -> TcType -> TcType -> SDoc
-- See Note [Suggest adding a type signature]
suggestAddSig ctxt ty1 ty2
  | null inferred_bndrs
  = empty
  | [bndr] <- inferred_bndrs
  = ptext (sLit "Possible fix: add a type signature for") <+> quotes (ppr bndr)
  | otherwise
  = ptext (sLit "Possible fix: add type signatures for some or all of") <+> (ppr inferred_bndrs)
  where
    inferred_bndrs = nub (get_inf ty1 ++ get_inf ty2)
    get_inf ty | Just tv <- tcGetTyVar_maybe ty
               , isTcTyVar tv, isSkolemTyVar tv
               , InferSkol prs <- getSkolemInfo (cec_encl ctxt) tv
               = map fst prs
               | otherwise
               = []

858 859 860 861 862 863 864 865 866
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

867
--------------------
868
misMatchMsg :: Maybe SwapFlag -> TcType -> TcType -> SDoc          -- Types are already tidy
869
-- If oriented then ty1 is actual, ty2 is expected
870
misMatchMsg oriented ty1 ty2
871 872 873
  | Just IsSwapped <- oriented
  = misMatchMsg (Just NotSwapped) ty2 ty1
  | Just NotSwapped <- oriented
874
  = sep [ ptext (sLit "Couldn't match expected") <+> what <+> quotes (ppr ty2)
875 876
        , nest 12 $   ptext (sLit "with actual") <+> what <+> quotes (ppr ty1)
        , sameOccExtra ty2 ty1 ]
877 878
  | otherwise
  = sep [ ptext (sLit "Couldn't match") <+> what <+> quotes (ppr ty1)
879 880 881
        , nest 14 $ ptext (sLit "with") <+> quotes (ppr ty2)
        , sameOccExtra ty1 ty2 ]
  where
882 883
    what | isKind ty1 = ptext (sLit "kind")
         | otherwise  = ptext (sLit "type")
884

885
mkExpectedActualMsg :: Type -> Type -> CtOrigin -> (Maybe SwapFlag, SDoc)
886
-- NotSwapped means (actual, expected), IsSwapped is the reverse
887
mkExpectedActualMsg ty1 ty2 (TypeEqOrigin { uo_actual = act, uo_expected = exp })
888 889
  | act `pickyEqType` ty1, exp `pickyEqType` ty2 = (Just NotSwapped,  empty)
  | exp `pickyEqType` ty1, act `pickyEqType` ty2 = (Just IsSwapped, empty)