TcErrors.hs 128 KB
Newer Older
1 2 3
{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
4 5

module TcErrors(
6
       reportUnsolved, reportAllUnsolved, warnAllUnsolved,
7
       warnDefaulting,
8 9

       solverDepthErrorTcS
10 11 12 13
  ) where

#include "HsVersions.h"

14 15
import GhcPrelude

16
import TcRnTypes
17 18
import TcRnMonad
import TcMType
19
import TcUnify( occCheckForErrors, OccCheckResult(..) )
20
import TcEnv( tcInitTidyEnv )
21
import TcType
22
import RnUnbound ( unknownNameSuggestions )
batterseapower's avatar
batterseapower committed
23
import Type
24
import TyCoRep
25
import Unify            ( tcMatchTys )
26
import Module
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
27
import FamInst
28
import FamInstEnv       ( flattenTys )
29 30 31
import Inst
import InstEnv
import TyCon
32
import Class
33
import DataCon
34
import TcEvidence
35
import TcEvTerm
36
import HsExpr  ( UnboundVar(..) )
37
import HsBinds ( PatSynBind(..) )
38
import Name
39
import RdrName ( lookupGlobalRdrEnv, lookupGRE_Name, GlobalRdrEnv
40
               , mkRdrUnqual, isLocalGRE, greSrcSpan )
41
import PrelNames ( typeableClassName )
42
import Id
43 44 45
import Var
import VarSet
import VarEnv
46
import NameSet
47
import Bag
48
import ErrUtils         ( ErrMsg, errDoc, pprLocErrMsg )
49
import BasicTypes
50
import ConLike          ( ConLike(..))
51 52 53
import Util
import FastString
import Outputable
54
import SrcLoc
55
import DynFlags
56
import ListSetOps       ( equivClasses )
57
import Maybes
58
import Pair
59
import qualified GHC.LanguageExtensions as LangExt
60
import FV ( fvVarList, unionFV )
Icelandjack's avatar
Icelandjack committed
61

62
import Control.Monad    ( when )
63
import Data.Foldable    ( toList )
64
import Data.List        ( partition, mapAccumL, nub, sortBy, unfoldr )
65
import qualified Data.Set as Set
66 67

import {-# SOURCE #-} TcHoleErrors ( findValidHoleFits )
68

David Eichmann's avatar
David Eichmann committed
69
-- import Data.Semigroup   ( Semigroup )
70
import qualified Data.Semigroup as Semigroup
71 72


Austin Seipp's avatar
Austin Seipp committed
73 74 75
{-
************************************************************************
*                                                                      *
76
\section{Errors and contexts}
Austin Seipp's avatar
Austin Seipp committed
77 78
*                                                                      *
************************************************************************
79 80 81 82 83

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?

84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102
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
103

104 105 106 107 108 109 110 111 112 113 114 115 116 117
  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
118
and does not fail if -fdefer-type-errors is on, so that we can continue
119
compilation. The errors are turned into warnings in `reportUnsolved`.
Austin Seipp's avatar
Austin Seipp committed
120
-}
121

122 123
-- | Report unsolved goals as errors or warnings. We may also turn some into
-- deferred run-time errors if `-fdefer-type-errors` is on.
124 125
reportUnsolved :: WantedConstraints -> TcM (Bag EvBind)
reportUnsolved wanted
126 127 128 129
  = do { binds_var <- newTcEvBinds
       ; defer_errors <- goptM Opt_DeferTypeErrors
       ; warn_errors <- woptM Opt_WarnDeferredTypeErrors -- implement #10283
       ; let type_errors | not defer_errors = TypeError
130
                         | warn_errors      = TypeWarn (Reason Opt_WarnDeferredTypeErrors)
131
                         | otherwise        = TypeDefer
132

133
       ; defer_holes <- goptM Opt_DeferTypedHoles
134 135 136 137 138
       ; warn_holes  <- woptM Opt_WarnTypedHoles
       ; let expr_holes | not defer_holes = HoleError
                        | warn_holes      = HoleWarn
                        | otherwise       = HoleDefer

139
       ; partial_sigs      <- xoptM LangExt.PartialTypeSignatures
thomasw's avatar
thomasw committed
140
       ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures
141 142 143 144
       ; let type_holes | not partial_sigs  = HoleError
                        | warn_partial_sigs = HoleWarn
                        | otherwise         = HoleDefer

145 146 147 148 149 150
       ; defer_out_of_scope <- goptM Opt_DeferOutOfScopeVariables
       ; warn_out_of_scope <- woptM Opt_WarnDeferredOutOfScopeVariables
       ; let out_of_scope_holes | not defer_out_of_scope = HoleError
                                | warn_out_of_scope      = HoleWarn
                                | otherwise              = HoleDefer

151 152 153
       ; report_unsolved type_errors expr_holes
                         type_holes out_of_scope_holes
                         binds_var wanted
154 155 156

       ; ev_binds <- getTcEvBindsMap binds_var
       ; return (evBindMapBinds ev_binds)}
157

158
-- | Report *all* unsolved goals as errors, even if -fdefer-type-errors is on
Simon Peyton Jones's avatar
Simon Peyton Jones committed
159 160
-- However, do not make any evidence bindings, because we don't
-- have any convenient place to put them.
161
-- See Note [Deferring coercion errors to runtime]
Simon Peyton Jones's avatar
Simon Peyton Jones committed
162 163 164
-- Used by solveEqualities for kind equalities
--      (see Note [Fail fast on kind errors] in TcSimplify]
-- and for simplifyDefault.
165
reportAllUnsolved :: WantedConstraints -> TcM ()
166
reportAllUnsolved wanted
167
  = do { ev_binds <- newNoTcEvBinds
168 169
       ; report_unsolved TypeError HoleError HoleError HoleError
                         ev_binds wanted }
170

171 172 173 174 175
-- | Report all unsolved goals as warnings (but without deferring any errors to
-- run-time). See Note [Safe Haskell Overlapping Instances Implementation] in
-- TcSimplify
warnAllUnsolved :: WantedConstraints -> TcM ()
warnAllUnsolved wanted
176
  = do { ev_binds <- newTcEvBinds
177 178
       ; report_unsolved (TypeWarn NoReason) HoleWarn HoleWarn HoleWarn
                         ev_binds wanted }
179 180

-- | Report unsolved goals as errors or warnings.
181
report_unsolved :: TypeErrorChoice   -- Deferred type errors
182 183
                -> HoleChoice        -- Expression holes
                -> HoleChoice        -- Type holes
184
                -> HoleChoice        -- Out of scope holes
185
                -> EvBindsVar        -- cec_binds
186
                -> WantedConstraints -> TcM ()
187 188
report_unsolved type_errors expr_holes
    type_holes out_of_scope_holes binds_var wanted
189
  | isEmptyWC wanted
190
  = return ()
191
  | otherwise
192 193 194 195 196
  = do { traceTc "reportUnsolved {" $
         vcat [ text "type errors:" <+> ppr type_errors
              , text "expr holes:" <+> ppr expr_holes
              , text "type holes:" <+> ppr type_holes
              , text "scope holes:" <+> ppr out_of_scope_holes ]
197
       ; traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted)
198

199
       ; wanted <- zonkWC wanted   -- Zonk to reveal all information
200
       ; env0 <- tcInitTidyEnv
201 202
            -- If we are deferring we are going to need /all/ evidence around,
            -- including the evidence produced by unflattening (zonkWC)
203
       ; let tidy_env = tidyFreeTyCoVars env0 free_tvs
niteria's avatar
niteria committed
204
             free_tvs = tyCoVarsOfWCList wanted
205

206 207
       ; traceTc "reportUnsolved (after zonking):" $
         vcat [ text "Free tyvars:" <+> pprTyVars free_tvs
208
              , text "Tidy env:" <+> ppr tidy_env
209
              , text "Wanted:" <+> ppr wanted ]
210 211 212

       ; warn_redundant <- woptM Opt_WarnRedundantConstraints
       ; let err_ctxt = CEC { cec_encl  = []
213
                            , cec_tidy  = tidy_env
214
                            , cec_defer_type_errors = type_errors
215 216
                            , cec_expr_holes = expr_holes
                            , cec_type_holes = type_holes
217
                            , cec_out_of_scope_holes = out_of_scope_holes
218 219 220 221
                            , cec_suppress = insolubleWC wanted
                                 -- See Note [Suppressing error messages]
                                 -- Suppress low-priority errors if there
                                 -- are insolule errors anywhere;
222
                                 -- See #15539 and c.f. setting ic_status
223
                                 -- in TcSimplify.setImplicationStatus
224
                            , cec_warn_redundant = warn_redundant
225
                            , cec_binds    = binds_var }
226

227
       ; tc_lvl <- getTcLevel
228 229
       ; reportWanteds err_ctxt tc_lvl wanted
       ; traceTc "reportUnsolved }" empty }
230

231 232 233
--------------------------------------------
--      Internal functions
--------------------------------------------
234

235 236 237 238 239
-- | An error Report collects messages categorised by their importance.
-- See Note [Error report] for details.
data Report
  = Report { report_important :: [SDoc]
           , report_relevant_bindings :: [SDoc]
240
           , report_valid_hole_fits :: [SDoc]
241 242
           }

243
instance Outputable Report where   -- Debugging only
244 245
  ppr (Report { report_important = imp
              , report_relevant_bindings = rel
246
              , report_valid_hole_fits = val })
247
    = vcat [ text "important:" <+> vcat imp
248 249
           , text "relevant:"  <+> vcat rel
           , text "valid:"  <+> vcat val ]
250

251 252 253 254 255 256 257 258
{- Note [Error report]
The idea is that error msgs are divided into three parts: the main msg, the
context block (\"In the second argument of ...\"), and the relevant bindings
block, which are displayed in that order, with a mark to divide them.  The
idea is that the main msg ('report_important') varies depending on the error
in question, but context and relevant bindings are always the same, which
should simplify visual parsing.

259
The context is added when the Report is passed off to 'mkErrorReport'.
260 261 262 263
Unfortunately, unlike the context, the relevant bindings are added in
multiple places so they have to be in the Report.
-}

264
instance Semigroup Report where
265
    Report a1 b1 c1 <> Report a2 b2 c2 = Report (a1 ++ a2) (b1 ++ b2) (c1 ++ c2)
266

267
instance Monoid Report where
268
    mempty = Report [] [] []
269
    mappend = (Semigroup.<>)
270 271 272 273 274 275 276 277 278

-- | Put a doc into the important msgs block.
important :: SDoc -> Report
important doc = mempty { report_important = [doc] }

-- | Put a doc into the relevant bindings block.
relevant_bindings :: SDoc -> Report
relevant_bindings doc = mempty { report_relevant_bindings = [doc] }

279 280 281
-- | Put a doc into the valid hole fits block.
valid_hole_fits :: SDoc -> Report
valid_hole_fits docs = mempty { report_valid_hole_fits = [docs] }
282

283 284
data TypeErrorChoice   -- What to do for type errors found by the type checker
  = TypeError     -- A type error aborts compilation with an error message
285 286 287 288 289
  | TypeWarn WarnReason
                  -- A type error is deferred to runtime, plus a compile-time warning
                  -- The WarnReason should usually be (Reason Opt_WarnDeferredTypeErrors)
                  -- but it isn't for the Safe Haskell Overlapping Instances warnings
                  -- see warnAllUnsolved
290 291
  | TypeDefer     -- A type error is deferred to runtime; no error or warning at compile time

292 293 294 295 296
data HoleChoice
  = HoleError     -- A hole is a compile-time error
  | HoleWarn      -- Defer to runtime, emit a compile-time warning
  | HoleDefer     -- Defer to runtime, no warning

297 298 299 300 301 302
instance Outputable HoleChoice where
  ppr HoleError = text "HoleError"
  ppr HoleWarn  = text "HoleWarn"
  ppr HoleDefer = text "HoleDefer"

instance Outputable TypeErrorChoice  where
303 304 305
  ppr TypeError         = text "TypeError"
  ppr (TypeWarn reason) = text "TypeWarn" <+> ppr reason
  ppr TypeDefer         = text "TypeDefer"
306

307
data ReportErrCtxt
308
    = CEC { cec_encl :: [Implication]  -- Enclosing implications
309
                                       --   (innermost first)
310
                                       -- ic_skols and givens are tidied, rest are not
311
          , cec_tidy  :: TidyEnv
Simon Peyton Jones's avatar
Simon Peyton Jones committed
312

313 314 315
          , cec_binds :: EvBindsVar    -- Make some errors (depending on cec_defer)
                                       -- into warnings, and emit evidence bindings
                                       -- into 'cec_binds' for unsolved constraints
316

317
          , cec_defer_type_errors :: TypeErrorChoice -- Defer type errors until runtime
318

319 320 321 322 323 324 325
          -- cec_expr_holes is a union of:
          --   cec_type_holes - a set of typed holes: '_', '_a', '_foo'
          --   cec_out_of_scope_holes - a set of variables which are
          --                            out of scope: 'x', 'y', 'bar'
          , cec_expr_holes :: HoleChoice           -- Holes in expressions
          , cec_type_holes :: HoleChoice           -- Holes in types
          , cec_out_of_scope_holes :: HoleChoice   -- Out of scope holes
326

327
          , cec_warn_redundant :: Bool    -- True <=> -Wredundant-constraints
328

329 330 331
          , cec_suppress :: Bool    -- True <=> More important errors have occurred,
                                    --          so create bindings if need be, but
                                    --          don't issue any more errors/warnings
332
                                    -- See Note [Suppressing error messages]
333 334
      }

335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351
instance Outputable ReportErrCtxt where
  ppr (CEC { cec_binds              = bvar
           , cec_defer_type_errors  = dte
           , cec_expr_holes         = eh
           , cec_type_holes         = th
           , cec_out_of_scope_holes = osh
           , cec_warn_redundant     = wr
           , cec_suppress           = sup })
    = text "CEC" <+> braces (vcat
         [ text "cec_binds"              <+> equals <+> ppr bvar
         , text "cec_defer_type_errors"  <+> equals <+> ppr dte
         , text "cec_expr_holes"         <+> equals <+> ppr eh
         , text "cec_type_holes"         <+> equals <+> ppr th
         , text "cec_out_of_scope_holes" <+> equals <+> ppr osh
         , text "cec_warn_redundant"     <+> equals <+> ppr wr
         , text "cec_suppress"           <+> equals <+> ppr sup ])

352 353 354 355 356 357 358 359 360 361 362 363 364 365 366
-- | Returns True <=> the ReportErrCtxt indicates that something is deferred
deferringAnyBindings :: ReportErrCtxt -> Bool
  -- Don't check cec_type_holes, as these don't cause bindings to be deferred
deferringAnyBindings (CEC { cec_defer_type_errors  = TypeError
                          , cec_expr_holes         = HoleError
                          , cec_out_of_scope_holes = HoleError }) = False
deferringAnyBindings _                                            = True

-- | Transforms a 'ReportErrCtxt' into one that does not defer any bindings
-- at all.
noDeferredBindings :: ReportErrCtxt -> ReportErrCtxt
noDeferredBindings ctxt = ctxt { cec_defer_type_errors  = TypeError
                               , cec_expr_holes         = HoleError
                               , cec_out_of_scope_holes = HoleError }

Simon Peyton Jones's avatar
Simon Peyton Jones committed
367 368
{- Note [Suppressing error messages]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
369
The cec_suppress flag says "don't report any errors".  Instead, just create
370
evidence bindings (as usual).  It's used when more important errors have occurred.
371

372 373 374
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.
375
  * If there are any insolubles (eg Int~Bool), here or in a nested implication,
376 377
    then suppress errors from the simple constraints here.  Sometimes the
    simple-constraint errors are a knock-on effect of the insolubles.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
378 379 380 381 382 383

This suppression behaviour is controlled by the Bool flag in
ReportErrorSpec, as used in reportWanteds.

But we need to take care: flags can turn errors into warnings, and we
don't want those warnings to suppress subsequent errors (including
384
suppressing the essential addTcEvBind for them: #15152). So in
Simon Peyton Jones's avatar
Simon Peyton Jones committed
385 386 387 388 389 390
tryReporter we use askNoErrs to see if any error messages were
/actually/ produced; if not, we don't switch on suppression.

A consequence is that warnings never suppress warnings, so turning an
error into a warning may allow subsequent warnings to appear that were
previously suppressed.   (e.g. partial-sigs/should_fail/T14584)
Austin Seipp's avatar
Austin Seipp committed
391
-}
392

393
reportImplic :: ReportErrCtxt -> Implication -> TcM ()
394 395
reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_telescope = m_telescope
                                 , ic_given = given
396
                                 , ic_wanted = wanted, ic_binds = evb
397
                                 , ic_status = status, ic_info = info
398
                                 , ic_tclvl = tc_lvl })
399
  | BracketSkol <- info
400
  , not insoluble
401 402
  = return ()        -- For Template Haskell brackets report only
                     -- definite errors. The whole thing will be re-checked
Simon Peyton Jones's avatar
Simon Peyton Jones committed
403 404
                     -- later when we plug it in, and meanwhile there may
                     -- certainly be un-satisfied constraints
405 406

  | otherwise
407 408
  = do { traceTc "reportImplic" (ppr implic')
       ; reportWanteds ctxt' tc_lvl wanted
409
       ; when (cec_warn_redundant ctxt) $
410 411
         warnRedundantConstraints ctxt' tcl_env info' dead_givens
       ; when bad_telescope $ reportBadTelescope ctxt tcl_env m_telescope tvs }
412
  where
413
    tcl_env      = implicLclEnv implic
414
    insoluble    = isInsolubleStatus status
Ningning Xie's avatar
Ningning Xie committed
415
    (env1, tvs') = mapAccumL tidyVarBndr (cec_tidy ctxt) tvs
Simon Peyton Jones's avatar
Simon Peyton Jones committed
416
    info'        = tidySkolemInfo env1 info
417
    implic' = implic { ic_skols = tvs'
Simon Peyton Jones's avatar
Simon Peyton Jones committed
418
                     , ic_given = map (tidyEvVar env1) given
419
                     , ic_info  = info' }
Simon Peyton Jones's avatar
Simon Peyton Jones committed
420
    ctxt1 | CoEvBindsVar{} <- evb    = noDeferredBindings ctxt
421
          | otherwise                = ctxt
422
          -- If we go inside an implication that has no term
423
          -- evidence (e.g. unifying under a forall), we can't defer
424 425 426
          -- type errors.  You could imagine using the /enclosing/
          -- bindings (in cec_binds), but that may not have enough stuff
          -- in scope for the bindings to be well typed.  So we just
427
          -- switch off deferred type errors altogether.  See #14605.
428 429 430 431 432 433 434 435

    ctxt' = ctxt1 { cec_tidy     = env1
                  , cec_encl     = implic' : cec_encl ctxt

                  , cec_suppress = insoluble || cec_suppress ctxt
                        -- Suppress inessential errors if there
                        -- are insolubles anywhere in the
                        -- tree rooted here, or we've come across
436
                        -- a suppress-worthy constraint higher up (#11541)
437 438

                  , cec_binds    = evb }
439

440 441 442 443
    dead_givens = case status of
                    IC_Solved { ics_dead = dead } -> dead
                    _                             -> []

444 445 446 447
    bad_telescope = case status of
              IC_BadTelescope -> True
              _               -> False

448
warnRedundantConstraints :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [EvVar] -> TcM ()
449
-- See Note [Tracking redundant constraints] in TcSimplify
450
warnRedundantConstraints ctxt env info ev_vars
451
 | null redundant_evs
452 453 454 455 456
 = return ()

 | SigSkol {} <- info
 = setLclEnv env $  -- We want to add "In the type signature for f"
                    -- to the error context, which is a bit tiresome
457
   addErrCtxt (text "In" <+> ppr info) $
458
   do { env <- getLclEnv
459
      ; msg <- mkErrorReport ctxt env (important doc)
460
      ; reportWarning (Reason Opt_WarnRedundantConstraints) msg }
461 462 463 464

 | otherwise  -- But for InstSkol there already *is* a surrounding
              -- "In the instance declaration for Eq [a]" context
              -- and we don't want to say it twice. Seems a bit ad-hoc
465
 = do { msg <- mkErrorReport ctxt env (important doc)
466
      ; reportWarning (Reason Opt_WarnRedundantConstraints) msg }
467
 where
468
   doc = text "Redundant constraint" <> plural redundant_evs <> colon
469 470
         <+> pprEvVarTheta redundant_evs

471 472 473
   redundant_evs =
       filterOut is_type_error $
       case info of -- See Note [Redundant constraints in instance decls]
474
         InstSkol -> filterOut (improving . idType) ev_vars
475 476 477 478
         _        -> ev_vars

   -- See #15232
   is_type_error = isJust . userTypeError_maybe . idType
479

480 481
   improving pred -- (transSuperClasses p) does not include p
     = any isImprovementPred (pred : transSuperClasses pred)
482

483 484 485 486 487 488 489 490 491
reportBadTelescope :: ReportErrCtxt -> TcLclEnv -> Maybe SDoc -> [TcTyVar] -> TcM ()
reportBadTelescope ctxt env (Just telescope) skols
  = do { msg <- mkErrorReport ctxt env (important doc)
       ; reportError msg }
  where
    doc = hang (text "These kind and type variables:" <+> telescope $$
                text "are out of dependency order. Perhaps try this ordering:")
             2 (pprTyVars sorted_tvs)

Tobias Dammers's avatar
Tobias Dammers committed
492
    sorted_tvs = scopedSort skols
493 494 495 496

reportBadTelescope _ _ Nothing skols
  = pprPanic "reportBadTelescope" (ppr skols)

497 498 499
{- Note [Redundant constraints in instance decls]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For instance declarations, we don't report unused givens if
500
they can give rise to improvement.  Example (#10100):
501 502 503 504
    class Add a b ab | a b -> ab, a ab -> b
    instance Add Zero b b
    instance Add a b ab => Add (Succ a) b (Succ ab)
The context (Add a b ab) for the instance is clearly unused in terms
505
of evidence, since the dictionary has no fields.  But it is still
506 507 508 509 510 511 512
needed!  With the context, a wanted constraint
   Add (Succ Zero) beta (Succ Zero)
we will reduce to (Add Zero beta Zero), and thence we get beta := Zero.
But without the context we won't find beta := Zero.

This only matters in instance declarations..
-}
513

514
reportWanteds :: ReportErrCtxt -> TcLevel -> WantedConstraints -> TcM ()
515
reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics })
516 517
  = do { traceTc "reportWanteds" (vcat [ text "Simples =" <+> ppr simples
                                       , text "Suppress =" <+> ppr (cec_suppress ctxt)])
518
       ; traceTc "rw2" (ppr tidy_cts)
519 520 521 522

         -- First deal with things that are utterly wrong
         -- Like Int ~ Bool (incl nullary TyCons)
         -- or  Int ~ t a   (AppTy on one side)
523
         -- These /ones/ are not suppressed by the incoming context
524 525 526 527 528 529 530 531
       ; let ctxt_for_insols = ctxt { cec_suppress = False }
       ; (ctxt1, cts1) <- tryReporters ctxt_for_insols report1 tidy_cts

         -- Now all the other constraints.  We suppress errors here if
         -- any of the first batch failed, or if the enclosing context
         -- says to suppress
       ; let ctxt2 = ctxt { cec_suppress = cec_suppress ctxt || cec_suppress ctxt1 }
       ; (_, leftovers) <- tryReporters ctxt2 report2 cts1
532 533
       ; MASSERT2( null leftovers, ppr leftovers )

534
            -- All the Derived ones have been filtered out of simples
535 536 537
            -- 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]
538

539
     ; mapBagM_ (reportImplic ctxt2) implics }
540
            -- NB ctxt1: don't suppress inner insolubles if there's only a
541
            -- wanted insoluble here; but do suppress inner insolubles
542
            -- if there's a *given* insoluble here (= inaccessible code)
543
 where
544
    env = cec_tidy ctxt
545
    tidy_cts = bagToList (mapBag (tidyCt env) simples)
546

547 548 549
    -- report1: ones that should *not* be suppresed by
    --          an insoluble somewhere else in the tree
    -- It's crucial that anything that is considered insoluble
550
    -- (see TcRnTypes.insolubleCt) is caught here, otherwise
551 552
    -- we might suppress its error message, and proceed on past
    -- type checking to get a Lint error later
Simon Peyton Jones's avatar
Simon Peyton Jones committed
553
    report1 = [ ("Out of scope", is_out_of_scope,    True,  mkHoleReporter tidy_cts)
554
              , ("Holes",        is_hole,            False, mkHoleReporter tidy_cts)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
555
              , ("custom_error", is_user_type_error, True,  mkUserTypeErrorReporter)
556

557
              , given_eq_spec
558 559 560 561
              , ("insoluble2",   utterly_wrong,  True, mkGroupReporter mkEqErr)
              , ("skolem eq1",   very_wrong,     True, mkSkolReporter)
              , ("skolem eq2",   skolem_eq,      True, mkSkolReporter)
              , ("non-tv eq",    non_tv_eq,      True, mkSkolReporter)
562 563 564

                  -- The only remaining equalities are alpha ~ ty,
                  -- where alpha is untouchable; and representational equalities
565 566 567 568 569
                  -- Prefer homogeneous equalities over hetero, because the
                  -- former might be holding up the latter.
                  -- See Note [Equalities with incompatible kinds] in TcCanonical
              , ("Homo eqs",      is_homo_equality, True,  mkGroupReporter mkEqErr)
              , ("Other eqs",     is_equality,      False, mkGroupReporter mkEqErr) ]
570 571 572 573 574 575

    -- report2: we suppress these if there are insolubles elsewhere in the tree
    report2 = [ ("Implicit params", is_ip,           False, mkGroupReporter mkIPErr)
              , ("Irreds",          is_irred,        False, mkGroupReporter mkIrredErr)
              , ("Dicts",           is_dict,         False, mkGroupReporter mkDictErr) ]

576 577
    -- rigid_nom_eq, rigid_nom_tv_eq,
    is_hole, is_dict,
578
      is_equality, is_ip, is_irred :: Ct -> PredTree -> Bool
579

580 581 582 583 584
    is_given_eq ct pred
       | EqPred {} <- pred = arisesFromGivens ct
       | otherwise         = False
       -- I think all given residuals are equalities

585 586 587 588 589 590 591
    -- Things like (Int ~N Bool)
    utterly_wrong _ (EqPred NomEq ty1 ty2) = isRigidTy ty1 && isRigidTy ty2
    utterly_wrong _ _                      = False

    -- Things like (a ~N Int)
    very_wrong _ (EqPred NomEq ty1 ty2) = isSkolemTy tc_lvl ty1 && isRigidTy ty2
    very_wrong _ _                      = False
592

593
    -- Things like (a ~N b) or (a  ~N  F Bool)
594
    skolem_eq _ (EqPred NomEq ty1 _) = isSkolemTy tc_lvl ty1
595
    skolem_eq _ _                    = False
596

597 598 599 600 601 602 603 604
    -- Things like (F a  ~N  Int)
    non_tv_eq _ (EqPred NomEq ty1 _) = not (isTyVarTy ty1)
    non_tv_eq _ _                    = False

    is_out_of_scope ct _ = isOutOfScopeCt ct
    is_hole         ct _ = isHoleCt ct

    is_user_type_error ct _ = isUserTypeErrorCt ct
605

606
    is_homo_equality _ (EqPred _ ty1 ty2) = tcTypeKind ty1 `tcEqType` tcTypeKind ty2
607 608
    is_homo_equality _ _                  = False

609 610 611
    is_equality _ (EqPred {}) = True
    is_equality _ _           = False

612 613 614 615 616 617 618 619 620
    is_dict _ (ClassPred {}) = True
    is_dict _ _              = False

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

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

621 622 623 624 625 626 627 628 629
    given_eq_spec  -- See Note [Given errors]
      | has_gadt_match (cec_encl ctxt)
      = ("insoluble1a", is_given_eq, True,  mkGivenErrorReporter)
      | otherwise
      = ("insoluble1b", is_given_eq, False, ignoreErrorReporter)
          -- False means don't suppress subsequent errors
          -- Reason: we don't report all given errors
          --         (see mkGivenErrorReporter), and we should only suppress
          --         subsequent errors if we actually report this one!
630
          --         #13446 is an example
631 632 633 634

    -- See Note [Given errors]
    has_gadt_match [] = False
    has_gadt_match (implic : implics)
635 636
      | PatSkol {} <- ic_info implic
      , not (ic_no_eqs implic)
637 638 639
      , wopt Opt_WarnInaccessibleCode (implicDynFlags implic)
          -- Don't bother doing this if -Winaccessible-code isn't enabled.
          -- See Note [Avoid -Winaccessible-code when deriving] in TcInstDcls.
640
      = True
641
      | otherwise
642
      = has_gadt_match implics
643

644
---------------
645
isSkolemTy :: TcLevel -> Type -> Bool
646
-- The type is a skolem tyvar
647
isSkolemTy tc_lvl ty
648 649
  | Just tv <- getTyVar_maybe ty
  =  isSkolemTyVar tv
650 651
  || (isTyVarTyVar tv && isTouchableMetaTyVar tc_lvl tv)
     -- The last case is for touchable TyVarTvs
652 653 654 655
     -- we postpone untouchables to a latter test (too obscure)

  | otherwise
  = False
656

657 658
isTyFun_maybe :: Type -> Maybe TyCon
isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of
659
                      Just (tc,_) | isTypeFamilyTyCon tc -> Just tc
660 661
                      _ -> Nothing

662
--------------------------------------------
663
--      Reporters
664 665
--------------------------------------------

666 667 668 669 670 671 672 673 674
type Reporter
  = ReportErrCtxt -> [Ct] -> TcM ()
type ReporterSpec
  = ( String                     -- Name
    , Ct -> PredTree -> Bool     -- Pick these ones
    , Bool                       -- True <=> suppress subsequent reporters
    , Reporter)                  -- The reporter itself

mkSkolReporter :: Reporter
675
-- Suppress duplicates with either the same LHS, or same location
676
mkSkolReporter ctxt cts
677
  = mapM_ (reportGroup mkEqErr ctxt) (group cts)
678
  where
679 680 681 682 683 684
     group [] = []
     group (ct:cts) = (ct : yeses) : group noes
        where
          (yeses, noes) = partition (group_with ct) cts

     group_with ct1 ct2
685 686 687
       | EQ <- cmp_loc ct1 ct2 = True
       | eq_lhs_type   ct1 ct2 = True
       | otherwise             = False
688

689
mkHoleReporter :: [Ct] -> Reporter
690
-- Reports errors one at a time
691 692
mkHoleReporter tidy_simples ctxt
  = mapM_ $ \ct -> do { err <- mkHoleError tidy_simples ctxt ct
693 694
                      ; maybeReportHoleError ctxt ct err
                      ; maybeAddDeferredHoleBinding ctxt err ct }
695

696 697
mkUserTypeErrorReporter :: Reporter
mkUserTypeErrorReporter ctxt
698
  = mapM_ $ \ct -> do { err <- mkUserTypeError ctxt ct
699 700
                      ; maybeReportError ctxt err
                      ; addDeferredBinding ctxt err ct }
701 702 703

mkUserTypeError :: ReportErrCtxt -> Ct -> TcM ErrMsg
mkUserTypeError ctxt ct = mkErrorMsgFromCt ctxt ct
704
                        $ important
705 706
                        $ pprUserTypeErrorTy
                        $ case getUserTypeErrorMsg ct of
707 708
                            Just msg -> msg
                            Nothing  -> pprPanic "mkUserTypeError" (ppr ct)
709 710


711
mkGivenErrorReporter :: Reporter
712
-- See Note [Given errors]
713
mkGivenErrorReporter ctxt cts
714 715
  = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct
       ; dflags <- getDynFlags
716 717 718
       ; let (implic:_) = cec_encl ctxt
                 -- Always non-empty when mkGivenErrorReporter is called
             ct' = setCtLoc ct (setCtLocEnv (ctLoc ct) (implicLclEnv implic))
719
                   -- For given constraints we overwrite the env (and hence src-loc)
720 721
                   -- with one from the immediately-enclosing implication.
                   -- See Note [Inaccessible code]
722 723 724 725 726 727 728 729 730

             inaccessible_msg = hang (text "Inaccessible code in")
                                   2 (ppr (ic_info implic))
             report = important inaccessible_msg `mappend`
                      relevant_bindings binds_msg

       ; err <- mkEqErr_help dflags ctxt report ct'
                             Nothing ty1 ty2

Simon Peyton Jones's avatar
Simon Peyton Jones committed
731
       ; traceTc "mkGivenErrorReporter" (ppr ct)
732
       ; reportWarning (Reason Opt_WarnInaccessibleCode) err }
733 734 735 736
  where
    (ct : _ )  = cts    -- Never empty
    (ty1, ty2) = getEqPredTys (ctPred ct)

737 738
ignoreErrorReporter :: Reporter
-- Discard Given errors that don't come from
Simon Peyton Jones's avatar
Simon Peyton Jones committed
739
-- a pattern match; maybe we should warn instead?
740
ignoreErrorReporter ctxt cts
Simon Peyton Jones's avatar
Simon Peyton Jones committed
741
  = do { traceTc "mkGivenErrorReporter no" (ppr cts $$ ppr (cec_encl ctxt))
742 743
       ; return () }

744 745 746

{- Note [Given errors]
~~~~~~~~~~~~~~~~~~~~~~
Gabor Greif's avatar
Gabor Greif committed
747
Given constraints represent things for which we have (or will have)
748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765
evidence, so they aren't errors.  But if a Given constraint is
insoluble, this code is inaccessible, and we might want to at least
warn about that.  A classic case is

   data T a where
     T1 :: T Int
     T2 :: T a
     T3 :: T Bool

   f :: T Int -> Bool
   f T1 = ...
   f T2 = ...
   f T3 = ...  -- We want to report this case as inaccessible

We'd like to point out that the T3 match is inaccessible. It
will have a Given constraint [G] Int ~ Bool.

But we don't want to report ALL insoluble Given constraints.  See Trac
Simon Peyton Jones's avatar
Simon Peyton Jones committed
766
#12466 for a long discussion.  For example, if we aren't careful
767 768 769 770
we'll complain about
   f :: ((Int ~ Bool) => a -> a) -> Int
which arguably is OK.  It's more debatable for
   g :: (Int ~ Bool) => Int -> Int
771
but it's tricky to distinguish these cases so we don't report
772 773
either.

774
The bottom line is this: has_gadt_match looks for an enclosing
775 776 777 778
pattern match which binds some equality constraints.  If we
find one, we report the insoluble Given.
-}

779 780 781
mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg)
                             -- Make error message for a group
                -> Reporter  -- Deal with lots of constraints
782 783 784
-- Group together errors from same location,
-- and report only the first (to avoid a cascade)
mkGroupReporter mk_err ctxt cts
785
  = mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc cts)
786

787 788
eq_lhs_type :: Ct -> Ct -> Bool
eq_lhs_type ct1 ct2
789 790
  = case (classifyPredType (ctPred ct1), classifyPredType (ctPred ct2)) of
       (EqPred eq_rel1 ty1 _, EqPred eq_rel2 ty2 _) ->
791
         (eq_rel1 == eq_rel2) && (ty1 `eqType` ty2)
792 793 794 795
       _ -> pprPanic "mkSkolReporter" (ppr ct1 $$ ppr ct2)

cmp_loc :: Ct -> Ct -> Ordering
cmp_loc ct1 ct2 = ctLocSpan (ctLoc ct1) `compare` ctLocSpan (ctLoc ct2)
796

797 798
reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> ReportErrCtxt
            -> [Ct] -> TcM ()
quchen's avatar
quchen committed
799 800 801
reportGroup mk_err ctxt cts =
  case partition isMonadFailInstanceMissing cts of
        -- Only warn about missing MonadFail constraint when
Gabor Greif's avatar
Gabor Greif committed
802
        -- there are no other missing constraints!
803 804 805
        (monadFailCts, []) ->
            do { err <- mk_err ctxt monadFailCts
               ; reportWarning (Reason Opt_WarnMissingMonadFailInstances) err }
quchen's avatar
quchen committed
806 807

        (_, cts') -> do { err <- mk_err ctxt cts'
Simon Peyton Jones's avatar
Simon Peyton Jones committed
808 809 810 811
                        ; traceTc "About to maybeReportErr" $
                          vcat [ text "Constraint:"             <+> ppr cts'
                               , text "cec_suppress ="          <+> ppr (cec_suppress ctxt)
                               , text "cec_defer_type_errors =" <+> ppr (cec_defer_type_errors ctxt) ]
quchen's avatar
quchen committed
812
                        ; maybeReportError ctxt err
813 814 815 816 817 818
                            -- But see Note [Always warn with -fdefer-type-errors]
                        ; traceTc "reportGroup" (ppr cts')
                        ; mapM_ (addDeferredBinding ctxt err) cts' }
                            -- Add deferred bindings for all
                            -- Redundant if we are going to abort compilation,
                            -- but that's hard to know for sure, and if we don't
819
                            -- abort, we need bindings for all (e.g. #12156)
quchen's avatar
quchen committed
820 821 822 823 824
  where
    isMonadFailInstanceMissing ct =
        case ctLocOrigin (ctLoc ct) of
            FailablePattern _pat -> True
            _otherwise           -> False
825

826
maybeReportHoleError :: ReportErrCtxt -> Ct -> ErrMsg -> TcM ()
827 828
-- Unlike maybeReportError, these "hole" errors are
-- /not/ suppressed by cec_suppress.  We want to see them!
829
maybeReportHoleError ctxt ct err
thomasw's avatar
thomasw committed
830
  -- When -XPartialTypeSignatures is on, warnings (instead of errors) are
831 832 833
  -- generated for holes in partial type signatures.
  -- Unless -fwarn_partial_type_signatures is not on,
  -- in which case the messages are discarded.
834 835 836 837 838
  | isTypeHoleCt ct
  = -- For partial type signatures, generate warnings only, and do that
    -- only if -fwarn_partial_type_signatures is on
    case cec_type_holes ctxt of
       HoleError -> reportError err
839
       HoleWarn  -> reportWarning (Reason Opt_WarnPartialTypeSignatures) err
840 841
       HoleDefer -> return ()

842 843 844
  -- Always report an error for out-of-scope variables
  -- Unless -fdefer-out-of-scope-variables is on,
  -- in which case the messages are discarded.
845
  -- See #12170, #12406
846
  | isOutOfScopeCt ct
847 848 849 850 851 852
  = -- If deferring, report a warning only if -Wout-of-scope-variables is on
    case cec_out_of_scope_holes ctxt of
      HoleError -> reportError err
      HoleWarn  ->
        reportWarning (Reason Opt_WarnDeferredOutOfScopeVariables) err
      HoleDefer -> return ()
853 854 855

  -- Otherwise this is a typed hole in an expression,
  -- but not for an out-of-scope variable
856
  | otherwise
857
  = -- If deferring, report a warning only if -Wtyped-holes is on
858 859
    case cec_expr_holes ctxt of
       HoleError -> reportError err
860
       HoleWarn  -> reportWarning (Reason Opt_WarnTypedHoles) err
861
       HoleDefer -> return ()