{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}

module TcErrors(
       reportUnsolved, reportAllUnsolved, warnAllUnsolved,
       warnDefaulting,

       solverDepthErrorTcS
  ) where

#include "HsVersions.h"

import GhcPrelude

import TcRnTypes
import TcRnMonad
import TcMType
import TcUnify( occCheckForErrors, OccCheckResult(..) )
import TcEnv( tcInitTidyEnv )
import TcType
import RnUnbound ( unknownNameSuggestions )
import Type
import TyCoRep
import Unify            ( tcMatchTys )
import Module
import FamInst
import FamInstEnv       ( flattenTys )
import Inst
import InstEnv
import TyCon
import Class
import DataCon
import TcEvidence
import TcEvTerm
import HsExpr  ( UnboundVar(..) )
import HsBinds ( PatSynBind(..) )
import Name
import RdrName ( lookupGlobalRdrEnv, lookupGRE_Name, GlobalRdrEnv
               , mkRdrUnqual, isLocalGRE, greSrcSpan )
import PrelNames ( typeableClassName )
import Id
import Var
import VarSet
import VarEnv
import NameSet
import Bag
import ErrUtils         ( ErrMsg, errDoc, pprLocErrMsg )
import BasicTypes
import ConLike          ( ConLike(..))
import Util
import FastString
import Outputable
import SrcLoc
import DynFlags
import ListSetOps       ( equivClasses )
import Maybes
import Pair
import qualified GHC.LanguageExtensions as LangExt
import FV ( fvVarList, unionFV )

import Control.Monad    ( when )
import Data.Foldable    ( toList )
import Data.List        ( partition, mapAccumL, nub, sortBy, unfoldr )
import qualified Data.Set as Set

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

-- import Data.Semigroup   ( Semigroup )
import qualified Data.Semigroup as Semigroup


{-
************************************************************************
*                                                                      *
\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?

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

  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 -fdefer-type-errors is on, so that we can continue
compilation. The errors are turned into warnings in `reportUnsolved`.
-}

-- | Report unsolved goals as errors or warnings. We may also turn some into
-- deferred run-time errors if `-fdefer-type-errors` is on.
reportUnsolved :: WantedConstraints -> TcM (Bag EvBind)
reportUnsolved :: WantedConstraints -> TcM (Bag EvBind)
reportUnsolved wanted :: WantedConstraints
wanted
  = do { EvBindsVar
binds_var <- TcM EvBindsVar
newTcEvBinds
       ; Bool
defer_errors <- GeneralFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_DeferTypeErrors
       ; Bool
warn_errors <- WarningFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnDeferredTypeErrors -- implement #10283
       ; let type_errors :: TypeErrorChoice
type_errors | Bool -> Bool
not Bool
defer_errors = TypeErrorChoice
TypeError
                         | Bool
warn_errors      = WarnReason -> TypeErrorChoice
TypeWarn (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnDeferredTypeErrors)
                         | Bool
otherwise        = TypeErrorChoice
TypeDefer

       ; Bool
defer_holes <- GeneralFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_DeferTypedHoles
       ; Bool
warn_holes  <- WarningFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnTypedHoles
       ; let expr_holes :: HoleChoice
expr_holes | Bool -> Bool
not Bool
defer_holes = HoleChoice
HoleError
                        | Bool
warn_holes      = HoleChoice
HoleWarn
                        | Bool
otherwise       = HoleChoice
HoleDefer

       ; Bool
partial_sigs      <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.PartialTypeSignatures
       ; Bool
warn_partial_sigs <- WarningFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnPartialTypeSignatures
       ; let type_holes :: HoleChoice
type_holes | Bool -> Bool
not Bool
partial_sigs  = HoleChoice
HoleError
                        | Bool
warn_partial_sigs = HoleChoice
HoleWarn
                        | Bool
otherwise         = HoleChoice
HoleDefer

       ; Bool
defer_out_of_scope <- GeneralFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_DeferOutOfScopeVariables
       ; Bool
warn_out_of_scope <- WarningFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnDeferredOutOfScopeVariables
       ; let out_of_scope_holes :: HoleChoice
out_of_scope_holes | Bool -> Bool
not Bool
defer_out_of_scope = HoleChoice
HoleError
                                | Bool
warn_out_of_scope      = HoleChoice
HoleWarn
                                | Bool
otherwise              = HoleChoice
HoleDefer

       ; TypeErrorChoice
-> HoleChoice
-> HoleChoice
-> HoleChoice
-> EvBindsVar
-> WantedConstraints
-> TcM ()
report_unsolved TypeErrorChoice
type_errors HoleChoice
expr_holes
                         HoleChoice
type_holes HoleChoice
out_of_scope_holes
                         EvBindsVar
binds_var WantedConstraints
wanted

       ; EvBindMap
ev_binds <- EvBindsVar -> TcM EvBindMap
getTcEvBindsMap EvBindsVar
binds_var
       ; Bag EvBind -> TcM (Bag EvBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (EvBindMap -> Bag EvBind
evBindMapBinds EvBindMap
ev_binds)}

-- | Report *all* unsolved goals as errors, even if -fdefer-type-errors is on
-- However, do not make any evidence bindings, because we don't
-- have any convenient place to put them.
-- NB: Type-level holes are OK, because there are no bindings.
-- See Note [Deferring coercion errors to runtime]
-- Used by solveEqualities for kind equalities
--      (see Note [Fail fast on kind errors] in TcSimplify)
-- and for simplifyDefault.
reportAllUnsolved :: WantedConstraints -> TcM ()
reportAllUnsolved :: WantedConstraints -> TcM ()
reportAllUnsolved wanted :: WantedConstraints
wanted
  = do { EvBindsVar
ev_binds <- TcM EvBindsVar
newNoTcEvBinds

       ; Bool
partial_sigs      <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.PartialTypeSignatures
       ; Bool
warn_partial_sigs <- WarningFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnPartialTypeSignatures
       ; let type_holes :: HoleChoice
type_holes | Bool -> Bool
not Bool
partial_sigs  = HoleChoice
HoleError
                        | Bool
warn_partial_sigs = HoleChoice
HoleWarn
                        | Bool
otherwise         = HoleChoice
HoleDefer

       ; TypeErrorChoice
-> HoleChoice
-> HoleChoice
-> HoleChoice
-> EvBindsVar
-> WantedConstraints
-> TcM ()
report_unsolved TypeErrorChoice
TypeError HoleChoice
HoleError HoleChoice
type_holes HoleChoice
HoleError
                         EvBindsVar
ev_binds WantedConstraints
wanted }

-- | 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 :: WantedConstraints -> TcM ()
warnAllUnsolved wanted :: WantedConstraints
wanted
  = do { EvBindsVar
ev_binds <- TcM EvBindsVar
newTcEvBinds
       ; TypeErrorChoice
-> HoleChoice
-> HoleChoice
-> HoleChoice
-> EvBindsVar
-> WantedConstraints
-> TcM ()
report_unsolved (WarnReason -> TypeErrorChoice
TypeWarn WarnReason
NoReason) HoleChoice
HoleWarn HoleChoice
HoleWarn HoleChoice
HoleWarn
                         EvBindsVar
ev_binds WantedConstraints
wanted }

-- | Report unsolved goals as errors or warnings.
report_unsolved :: TypeErrorChoice   -- Deferred type errors
                -> HoleChoice        -- Expression holes
                -> HoleChoice        -- Type holes
                -> HoleChoice        -- Out of scope holes
                -> EvBindsVar        -- cec_binds
                -> WantedConstraints -> TcM ()
report_unsolved :: TypeErrorChoice
-> HoleChoice
-> HoleChoice
-> HoleChoice
-> EvBindsVar
-> WantedConstraints
-> TcM ()
report_unsolved type_errors :: TypeErrorChoice
type_errors expr_holes :: HoleChoice
expr_holes
    type_holes :: HoleChoice
type_holes out_of_scope_holes :: HoleChoice
out_of_scope_holes binds_var :: EvBindsVar
binds_var wanted :: WantedConstraints
wanted
  | WantedConstraints -> Bool
isEmptyWC WantedConstraints
wanted
  = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise
  = do { String -> SDoc -> TcM ()
traceTc "reportUnsolved {" (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
         [SDoc] -> SDoc
vcat [ String -> SDoc
text "type errors:" SDoc -> SDoc -> SDoc
<+> TypeErrorChoice -> SDoc
forall a. Outputable a => a -> SDoc
ppr TypeErrorChoice
type_errors
              , String -> SDoc
text "expr holes:" SDoc -> SDoc -> SDoc
<+> HoleChoice -> SDoc
forall a. Outputable a => a -> SDoc
ppr HoleChoice
expr_holes
              , String -> SDoc
text "type holes:" SDoc -> SDoc -> SDoc
<+> HoleChoice -> SDoc
forall a. Outputable a => a -> SDoc
ppr HoleChoice
type_holes
              , String -> SDoc
text "scope holes:" SDoc -> SDoc -> SDoc
<+> HoleChoice -> SDoc
forall a. Outputable a => a -> SDoc
ppr HoleChoice
out_of_scope_holes ]
       ; String -> SDoc -> TcM ()
traceTc "reportUnsolved (before zonking and tidying)" (WantedConstraints -> SDoc
forall a. Outputable a => a -> SDoc
ppr WantedConstraints
wanted)

       ; WantedConstraints
wanted <- WantedConstraints -> TcM WantedConstraints
zonkWC WantedConstraints
wanted   -- Zonk to reveal all information
       ; TidyEnv
env0 <- TcM TidyEnv
tcInitTidyEnv
            -- If we are deferring we are going to need /all/ evidence around,
            -- including the evidence produced by unflattening (zonkWC)
       ; let tidy_env :: TidyEnv
tidy_env = TidyEnv -> [TyCoVar] -> TidyEnv
tidyFreeTyCoVars TidyEnv
env0 [TyCoVar]
free_tvs
             free_tvs :: [TyCoVar]
free_tvs = WantedConstraints -> [TyCoVar]
tyCoVarsOfWCList WantedConstraints
wanted

       ; String -> SDoc -> TcM ()
traceTc "reportUnsolved (after zonking):" (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
         [SDoc] -> SDoc
vcat [ String -> SDoc
text "Free tyvars:" SDoc -> SDoc -> SDoc
<+> [TyCoVar] -> SDoc
pprTyVars [TyCoVar]
free_tvs
              , String -> SDoc
text "Tidy env:" SDoc -> SDoc -> SDoc
<+> TidyEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr TidyEnv
tidy_env
              , String -> SDoc
text "Wanted:" SDoc -> SDoc -> SDoc
<+> WantedConstraints -> SDoc
forall a. Outputable a => a -> SDoc
ppr WantedConstraints
wanted ]

       ; Bool
warn_redundant <- WarningFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnRedundantConstraints
       ; let err_ctxt :: ReportErrCtxt
err_ctxt = CEC :: [Implication]
-> TidyEnv
-> EvBindsVar
-> TypeErrorChoice
-> HoleChoice
-> HoleChoice
-> HoleChoice
-> Bool
-> Bool
-> ReportErrCtxt
CEC { cec_encl :: [Implication]
cec_encl  = []
                            , cec_tidy :: TidyEnv
cec_tidy  = TidyEnv
tidy_env
                            , cec_defer_type_errors :: TypeErrorChoice
cec_defer_type_errors = TypeErrorChoice
type_errors
                            , cec_expr_holes :: HoleChoice
cec_expr_holes = HoleChoice
expr_holes
                            , cec_type_holes :: HoleChoice
cec_type_holes = HoleChoice
type_holes
                            , cec_out_of_scope_holes :: HoleChoice
cec_out_of_scope_holes = HoleChoice
out_of_scope_holes
                            , cec_suppress :: Bool
cec_suppress = WantedConstraints -> Bool
insolubleWC WantedConstraints
wanted
                                 -- See Note [Suppressing error messages]
                                 -- Suppress low-priority errors if there
                                 -- are insolule errors anywhere;
                                 -- See Trac #15539 and c.f. setting ic_status
                                 -- in TcSimplify.setImplicationStatus
                            , cec_warn_redundant :: Bool
cec_warn_redundant = Bool
warn_redundant
                            , cec_binds :: EvBindsVar
cec_binds    = EvBindsVar
binds_var }

       ; TcLevel
tc_lvl <- TcM TcLevel
getTcLevel
       ; ReportErrCtxt -> TcLevel -> WantedConstraints -> TcM ()
reportWanteds ReportErrCtxt
err_ctxt TcLevel
tc_lvl WantedConstraints
wanted
       ; String -> SDoc -> TcM ()
traceTc "reportUnsolved }" SDoc
empty }

--------------------------------------------
--      Internal functions
--------------------------------------------

-- | An error Report collects messages categorised by their importance.
-- See Note [Error report] for details.
data Report
  = Report { Report -> [SDoc]
report_important :: [SDoc]
           , Report -> [SDoc]
report_relevant_bindings :: [SDoc]
           , Report -> [SDoc]
report_valid_hole_fits :: [SDoc]
           }

instance Outputable Report where   -- Debugging only
  ppr :: Report -> SDoc
ppr (Report { report_important :: Report -> [SDoc]
report_important = [SDoc]
imp
              , report_relevant_bindings :: Report -> [SDoc]
report_relevant_bindings = [SDoc]
rel
              , report_valid_hole_fits :: Report -> [SDoc]
report_valid_hole_fits = [SDoc]
val })
    = [SDoc] -> SDoc
vcat [ String -> SDoc
text "important:" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat [SDoc]
imp
           , String -> SDoc
text "relevant:"  SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat [SDoc]
rel
           , String -> SDoc
text "valid:"  SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat [SDoc]
val ]

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

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

instance Semigroup Report where
    Report a1 :: [SDoc]
a1 b1 :: [SDoc]
b1 c1 :: [SDoc]
c1 <> :: Report -> Report -> Report
<> Report a2 :: [SDoc]
a2 b2 :: [SDoc]
b2 c2 :: [SDoc]
c2 = [SDoc] -> [SDoc] -> [SDoc] -> Report
Report ([SDoc]
a1 [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [SDoc]
a2) ([SDoc]
b1 [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [SDoc]
b2) ([SDoc]
c1 [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [SDoc]
c2)

instance Monoid Report where
    mempty :: Report
mempty = [SDoc] -> [SDoc] -> [SDoc] -> Report
Report [] [] []
    mappend :: Report -> Report -> Report
mappend = Report -> Report -> Report
forall a. Semigroup a => a -> a -> a
(Semigroup.<>)

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

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

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

data TypeErrorChoice   -- What to do for type errors found by the type checker
  = TypeError     -- A type error aborts compilation with an error message
  | 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
  | TypeDefer     -- A type error is deferred to runtime; no error or warning at compile time

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

instance Outputable HoleChoice where
  ppr :: HoleChoice -> SDoc
ppr HoleError = String -> SDoc
text "HoleError"
  ppr HoleWarn  = String -> SDoc
text "HoleWarn"
  ppr HoleDefer = String -> SDoc
text "HoleDefer"

instance Outputable TypeErrorChoice  where
  ppr :: TypeErrorChoice -> SDoc
ppr TypeError         = String -> SDoc
text "TypeError"
  ppr (TypeWarn reason :: WarnReason
reason) = String -> SDoc
text "TypeWarn" SDoc -> SDoc -> SDoc
<+> WarnReason -> SDoc
forall a. Outputable a => a -> SDoc
ppr WarnReason
reason
  ppr TypeDefer         = String -> SDoc
text "TypeDefer"

data ReportErrCtxt
    = CEC { ReportErrCtxt -> [Implication]
cec_encl :: [Implication]  -- Enclosing implications
                                       --   (innermost first)
                                       -- ic_skols and givens are tidied, rest are not
          , ReportErrCtxt -> TidyEnv
cec_tidy  :: TidyEnv

          , ReportErrCtxt -> EvBindsVar
cec_binds :: EvBindsVar    -- Make some errors (depending on cec_defer)
                                       -- into warnings, and emit evidence bindings
                                       -- into 'cec_binds' for unsolved constraints

          , ReportErrCtxt -> TypeErrorChoice
cec_defer_type_errors :: TypeErrorChoice -- Defer type errors until runtime

          -- 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'
          , ReportErrCtxt -> HoleChoice
cec_expr_holes :: HoleChoice           -- Holes in expressions
          , ReportErrCtxt -> HoleChoice
cec_type_holes :: HoleChoice           -- Holes in types
          , ReportErrCtxt -> HoleChoice
cec_out_of_scope_holes :: HoleChoice   -- Out of scope holes

          , ReportErrCtxt -> Bool
cec_warn_redundant :: Bool    -- True <=> -Wredundant-constraints

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

instance Outputable ReportErrCtxt where
  ppr :: ReportErrCtxt -> SDoc
ppr (CEC { cec_binds :: ReportErrCtxt -> EvBindsVar
cec_binds              = EvBindsVar
bvar
           , cec_defer_type_errors :: ReportErrCtxt -> TypeErrorChoice
cec_defer_type_errors  = TypeErrorChoice
dte
           , cec_expr_holes :: ReportErrCtxt -> HoleChoice
cec_expr_holes         = HoleChoice
eh
           , cec_type_holes :: ReportErrCtxt -> HoleChoice
cec_type_holes         = HoleChoice
th
           , cec_out_of_scope_holes :: ReportErrCtxt -> HoleChoice
cec_out_of_scope_holes = HoleChoice
osh
           , cec_warn_redundant :: ReportErrCtxt -> Bool
cec_warn_redundant     = Bool
wr
           , cec_suppress :: ReportErrCtxt -> Bool
cec_suppress           = Bool
sup })
    = String -> SDoc
text "CEC" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
braces ([SDoc] -> SDoc
vcat
         [ String -> SDoc
text "cec_binds"              SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> EvBindsVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr EvBindsVar
bvar
         , String -> SDoc
text "cec_defer_type_errors"  SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> TypeErrorChoice -> SDoc
forall a. Outputable a => a -> SDoc
ppr TypeErrorChoice
dte
         , String -> SDoc
text "cec_expr_holes"         SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> HoleChoice -> SDoc
forall a. Outputable a => a -> SDoc
ppr HoleChoice
eh
         , String -> SDoc
text "cec_type_holes"         SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> HoleChoice -> SDoc
forall a. Outputable a => a -> SDoc
ppr HoleChoice
th
         , String -> SDoc
text "cec_out_of_scope_holes" SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> HoleChoice -> SDoc
forall a. Outputable a => a -> SDoc
ppr HoleChoice
osh
         , String -> SDoc
text "cec_warn_redundant"     SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
wr
         , String -> SDoc
text "cec_suppress"           SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
sup ])

-- | 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 :: ReportErrCtxt -> Bool
deferringAnyBindings (CEC { cec_defer_type_errors :: ReportErrCtxt -> TypeErrorChoice
cec_defer_type_errors  = TypeErrorChoice
TypeError
                          , cec_expr_holes :: ReportErrCtxt -> HoleChoice
cec_expr_holes         = HoleChoice
HoleError
                          , cec_out_of_scope_holes :: ReportErrCtxt -> HoleChoice
cec_out_of_scope_holes = HoleChoice
HoleError }) = Bool
False
deferringAnyBindings _                                            = Bool
True

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

{- Note [Suppressing error messages]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The cec_suppress flag says "don't report any errors".  Instead, just create
evidence bindings (as usual).  It's used when more important errors have occurred.

Specifically (see reportWanteds)
  * If there are insoluble Givens, then we are in unreachable code and all bets
    are off.  So don't report any further errors.
  * If there are any insolubles (eg Int~Bool), here or in a nested implication,
    then suppress errors from the simple constraints here.  Sometimes the
    simple-constraint errors are a knock-on effect of the insolubles.

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
suppressing the essential addTcEvBind for them: Trac #15152). So in
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)
-}

reportImplic :: ReportErrCtxt -> Implication -> TcM ()
reportImplic :: ReportErrCtxt -> Implication -> TcM ()
reportImplic ctxt :: ReportErrCtxt
ctxt implic :: Implication
implic@(Implic { ic_skols :: Implication -> [TyCoVar]
ic_skols = [TyCoVar]
tvs, ic_telescope :: Implication -> Maybe SDoc
ic_telescope = Maybe SDoc
m_telescope
                                 , ic_given :: Implication -> [TyCoVar]
ic_given = [TyCoVar]
given
                                 , ic_wanted :: Implication -> WantedConstraints
ic_wanted = WantedConstraints
wanted, ic_binds :: Implication -> EvBindsVar
ic_binds = EvBindsVar
evb
                                 , ic_status :: Implication -> ImplicStatus
ic_status = ImplicStatus
status, ic_info :: Implication -> SkolemInfo
ic_info = SkolemInfo
info
                                 , ic_tclvl :: Implication -> TcLevel
ic_tclvl = TcLevel
tc_lvl })
  | SkolemInfo
BracketSkol <- SkolemInfo
info
  , Bool -> Bool
not Bool
insoluble
  = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()        -- For Template Haskell brackets report only
                     -- definite errors. The whole thing will be re-checked
                     -- later when we plug it in, and meanwhile there may
                     -- certainly be un-satisfied constraints

  | Bool
otherwise
  = do { String -> SDoc -> TcM ()
traceTc "reportImplic" (Implication -> SDoc
forall a. Outputable a => a -> SDoc
ppr Implication
implic')
       ; ReportErrCtxt -> TcLevel -> WantedConstraints -> TcM ()
reportWanteds ReportErrCtxt
ctxt' TcLevel
tc_lvl WantedConstraints
wanted
       ; Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ReportErrCtxt -> Bool
cec_warn_redundant ReportErrCtxt
ctxt) (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
         ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [TyCoVar] -> TcM ()
warnRedundantConstraints ReportErrCtxt
ctxt' TcLclEnv
tcl_env SkolemInfo
info' [TyCoVar]
dead_givens
       ; Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
bad_telescope (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$ ReportErrCtxt -> TcLclEnv -> Maybe SDoc -> [TyCoVar] -> TcM ()
reportBadTelescope ReportErrCtxt
ctxt TcLclEnv
tcl_env Maybe SDoc
m_telescope [TyCoVar]
tvs }
  where
    tcl_env :: TcLclEnv
tcl_env      = Implication -> TcLclEnv
implicLclEnv Implication
implic
    insoluble :: Bool
insoluble    = ImplicStatus -> Bool
isInsolubleStatus ImplicStatus
status
    (env1 :: TidyEnv
env1, tvs' :: [TyCoVar]
tvs') = (TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar))
-> TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar)
tidyVarBndr (ReportErrCtxt -> TidyEnv
cec_tidy ReportErrCtxt
ctxt) [TyCoVar]
tvs
    info' :: SkolemInfo
info'        = TidyEnv -> SkolemInfo -> SkolemInfo
tidySkolemInfo TidyEnv
env1 SkolemInfo
info
    implic' :: Implication
implic' = Implication
implic { ic_skols :: [TyCoVar]
ic_skols = [TyCoVar]
tvs'
                     , ic_given :: [TyCoVar]
ic_given = (TyCoVar -> TyCoVar) -> [TyCoVar] -> [TyCoVar]
forall a b. (a -> b) -> [a] -> [b]
map (TidyEnv -> TyCoVar -> TyCoVar
tidyEvVar TidyEnv
env1) [TyCoVar]
given
                     , ic_info :: SkolemInfo
ic_info  = SkolemInfo
info' }
    ctxt1 :: ReportErrCtxt
ctxt1 | CoEvBindsVar{} <- EvBindsVar
evb    = ReportErrCtxt -> ReportErrCtxt
noDeferredBindings ReportErrCtxt
ctxt
          | Bool
otherwise                = ReportErrCtxt
ctxt
          -- If we go inside an implication that has no term
          -- evidence (e.g. unifying under a forall), we can't defer
          -- 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
          -- switch off deferred type errors altogether.  See Trac #14605.

    ctxt' :: ReportErrCtxt
ctxt' = ReportErrCtxt
ctxt1 { cec_tidy :: TidyEnv
cec_tidy     = TidyEnv
env1
                  , cec_encl :: [Implication]
cec_encl     = Implication
implic' Implication -> [Implication] -> [Implication]
forall a. a -> [a] -> [a]
: ReportErrCtxt -> [Implication]
cec_encl ReportErrCtxt
ctxt

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

                  , cec_binds :: EvBindsVar
cec_binds    = EvBindsVar
evb }

    dead_givens :: [TyCoVar]
dead_givens = case ImplicStatus
status of
                    IC_Solved { ics_dead :: ImplicStatus -> [TyCoVar]
ics_dead = [TyCoVar]
dead } -> [TyCoVar]
dead
                    _                             -> []

    bad_telescope :: Bool
bad_telescope = case ImplicStatus
status of
              IC_BadTelescope -> Bool
True
              _               -> Bool
False

warnRedundantConstraints :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [EvVar] -> TcM ()
-- See Note [Tracking redundant constraints] in TcSimplify
warnRedundantConstraints :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [TyCoVar] -> TcM ()
warnRedundantConstraints ctxt :: ReportErrCtxt
ctxt env :: TcLclEnv
env info :: SkolemInfo
info ev_vars :: [TyCoVar]
ev_vars
 | [TyCoVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyCoVar]
redundant_evs
 = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

 | SigSkol {} <- SkolemInfo
info
 = TcLclEnv -> TcM () -> TcM ()
forall lcl' gbl a lcl.
lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
setLclEnv TcLclEnv
env (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$  -- We want to add "In the type signature for f"
                    -- to the error context, which is a bit tiresome
   SDoc -> TcM () -> TcM ()
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (String -> SDoc
text "In" SDoc -> SDoc -> SDoc
<+> SkolemInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr SkolemInfo
info) (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
   do { TcLclEnv
env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
      ; ErrMsg
msg <- ReportErrCtxt -> TcLclEnv -> Report -> TcM ErrMsg
mkErrorReport ReportErrCtxt
ctxt TcLclEnv
env (SDoc -> Report
important SDoc
doc)
      ; WarnReason -> ErrMsg -> TcM ()
reportWarning (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnRedundantConstraints) ErrMsg
msg }

 | Bool
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
 = do { ErrMsg
msg <- ReportErrCtxt -> TcLclEnv -> Report -> TcM ErrMsg
mkErrorReport ReportErrCtxt
ctxt TcLclEnv
env (SDoc -> Report
important SDoc
doc)
      ; WarnReason -> ErrMsg -> TcM ()
reportWarning (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnRedundantConstraints) ErrMsg
msg }
 where
   doc :: SDoc
doc = String -> SDoc
text "Redundant constraint" SDoc -> SDoc -> SDoc
<> [TyCoVar] -> SDoc
forall a. [a] -> SDoc
plural [TyCoVar]
redundant_evs SDoc -> SDoc -> SDoc
<> SDoc
colon
         SDoc -> SDoc -> SDoc
<+> [TyCoVar] -> SDoc
pprEvVarTheta [TyCoVar]
redundant_evs

   redundant_evs :: [TyCoVar]
redundant_evs =
       (TyCoVar -> Bool) -> [TyCoVar] -> [TyCoVar]
forall a. (a -> Bool) -> [a] -> [a]
filterOut TyCoVar -> Bool
is_type_error ([TyCoVar] -> [TyCoVar]) -> [TyCoVar] -> [TyCoVar]
forall a b. (a -> b) -> a -> b
$
       case SkolemInfo
info of -- See Note [Redundant constraints in instance decls]
         InstSkol -> (TyCoVar -> Bool) -> [TyCoVar] -> [TyCoVar]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (Type -> Bool
improving (Type -> Bool) -> (TyCoVar -> Type) -> TyCoVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCoVar -> Type
idType) [TyCoVar]
ev_vars
         _        -> [TyCoVar]
ev_vars

   -- See #15232
   is_type_error :: TyCoVar -> Bool
is_type_error = Maybe Type -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Type -> Bool) -> (TyCoVar -> Maybe Type) -> TyCoVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Maybe Type
userTypeError_maybe (Type -> Maybe Type) -> (TyCoVar -> Type) -> TyCoVar -> Maybe Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCoVar -> Type
idType

   improving :: Type -> Bool
improving pred :: Type
pred -- (transSuperClasses p) does not include p
     = (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Type -> Bool
isImprovementPred (Type
pred Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: Type -> [Type]
transSuperClasses Type
pred)

reportBadTelescope :: ReportErrCtxt -> TcLclEnv -> Maybe SDoc -> [TcTyVar] -> TcM ()
reportBadTelescope :: ReportErrCtxt -> TcLclEnv -> Maybe SDoc -> [TyCoVar] -> TcM ()
reportBadTelescope ctxt :: ReportErrCtxt
ctxt env :: TcLclEnv
env (Just telescope :: SDoc
telescope) skols :: [TyCoVar]
skols
  = do { ErrMsg
msg <- ReportErrCtxt -> TcLclEnv -> Report -> TcM ErrMsg
mkErrorReport ReportErrCtxt
ctxt TcLclEnv
env (SDoc -> Report
important SDoc
doc)
       ; ErrMsg -> TcM ()
reportError ErrMsg
msg }
  where
    doc :: SDoc
doc = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "These kind and type variables:" SDoc -> SDoc -> SDoc
<+> SDoc
telescope SDoc -> SDoc -> SDoc
$$
                String -> SDoc
text "are out of dependency order. Perhaps try this ordering:")
             2 ([TyCoVar] -> SDoc
pprTyVars [TyCoVar]
sorted_tvs)

    sorted_tvs :: [TyCoVar]
sorted_tvs = [TyCoVar] -> [TyCoVar]
scopedSort [TyCoVar]
skols

reportBadTelescope _ _ Nothing skols :: [TyCoVar]
skols
  = String -> SDoc -> TcM ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic "reportBadTelescope" ([TyCoVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyCoVar]
skols)

{- Note [Redundant constraints in instance decls]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For instance declarations, we don't report unused givens if
they can give rise to improvement.  Example (Trac #10100):
    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
of evidence, since the dictionary has no fields.  But it is still
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..
-}

reportWanteds :: ReportErrCtxt -> TcLevel -> WantedConstraints -> TcM ()
reportWanteds :: ReportErrCtxt -> TcLevel -> WantedConstraints -> TcM ()
reportWanteds ctxt :: ReportErrCtxt
ctxt tc_lvl :: TcLevel
tc_lvl (WC { wc_simple :: WantedConstraints -> Cts
wc_simple = Cts
simples, wc_impl :: WantedConstraints -> Bag Implication
wc_impl = Bag Implication
implics })
  = do { String -> SDoc -> TcM ()
traceTc "reportWanteds" ([SDoc] -> SDoc
vcat [ String -> SDoc
text "Simples =" SDoc -> SDoc -> SDoc
<+> Cts -> SDoc
forall a. Outputable a => a -> SDoc
ppr Cts
simples
                                       , String -> SDoc
text "Suppress =" SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ReportErrCtxt -> Bool
cec_suppress ReportErrCtxt
ctxt)])
       ; String -> SDoc -> TcM ()
traceTc "rw2" ([Ct] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Ct]
tidy_cts)

         -- First deal with things that are utterly wrong
         -- Like Int ~ Bool (incl nullary TyCons)
         -- or  Int ~ t a   (AppTy on one side)
         -- These /ones/ are not suppressed by the incoming context
       ; let ctxt_for_insols :: ReportErrCtxt
ctxt_for_insols = ReportErrCtxt
ctxt { cec_suppress :: Bool
cec_suppress = Bool
False }
       ; (ctxt1 :: ReportErrCtxt
ctxt1, cts1 :: [Ct]
cts1) <- ReportErrCtxt
-> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct])
tryReporters ReportErrCtxt
ctxt_for_insols [ReporterSpec]
report1 [Ct]
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 :: ReportErrCtxt
ctxt2 = ReportErrCtxt
ctxt { cec_suppress :: Bool
cec_suppress = ReportErrCtxt -> Bool
cec_suppress ReportErrCtxt
ctxt Bool -> Bool -> Bool
|| ReportErrCtxt -> Bool
cec_suppress ReportErrCtxt
ctxt1 }
       ; (_, leftovers :: [Ct]
leftovers) <- ReportErrCtxt
-> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct])
tryReporters ReportErrCtxt
ctxt2 [ReporterSpec]
report2 [Ct]
cts1
       ; MASSERT2( null leftovers, ppr leftovers )

            -- All the Derived ones have been filtered out of simples
            -- 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]

     ; (Implication -> TcM ()) -> Bag Implication -> TcM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Bag a -> m ()
mapBagM_ (ReportErrCtxt -> Implication -> TcM ()
reportImplic ReportErrCtxt
ctxt2) Bag Implication
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
    env :: TidyEnv
env = ReportErrCtxt -> TidyEnv
cec_tidy ReportErrCtxt
ctxt
    tidy_cts :: [Ct]
tidy_cts = Cts -> [Ct]
forall a. Bag a -> [a]
bagToList ((Ct -> Ct) -> Cts -> Cts
forall a b. (a -> b) -> Bag a -> Bag b
mapBag (TidyEnv -> Ct -> Ct
tidyCt TidyEnv
env) Cts
simples)

    -- report1: ones that should *not* be suppresed by
    --          an insoluble somewhere else in the tree
    -- It's crucial that anything that is considered insoluble
    -- (see TcRnTypes.insolubleCt) is caught here, otherwise
    -- we might suppress its error message, and proceed on past
    -- type checking to get a Lint error later
    report1 :: [ReporterSpec]
report1 = [ ("Out of scope", Ct -> PredTree -> Bool
forall p. Ct -> p -> Bool
is_out_of_scope,    Bool
True,  [Ct] -> Reporter
mkHoleReporter [Ct]
tidy_cts)
              , ("Holes",        Ct -> PredTree -> Bool
is_hole,            Bool
False, [Ct] -> Reporter
mkHoleReporter [Ct]
tidy_cts)
              , ("custom_error", Ct -> PredTree -> Bool
forall p. Ct -> p -> Bool
is_user_type_error, Bool
True,  Reporter
mkUserTypeErrorReporter)

              , ReporterSpec
given_eq_spec
              , ("insoluble2",   Ct -> PredTree -> Bool
forall p. p -> PredTree -> Bool
utterly_wrong,  Bool
True, (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter
mkGroupReporter ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkEqErr)
              , ("skolem eq1",   Ct -> PredTree -> Bool
forall p. p -> PredTree -> Bool
very_wrong,     Bool
True, Reporter
mkSkolReporter)
              , ("skolem eq2",   Ct -> PredTree -> Bool
forall p. p -> PredTree -> Bool
skolem_eq,      Bool
True, Reporter
mkSkolReporter)
              , ("non-tv eq",    Ct -> PredTree -> Bool
forall p. p -> PredTree -> Bool
non_tv_eq,      Bool
True, Reporter
mkSkolReporter)

                  -- The only remaining equalities are alpha ~ ty,
                  -- where alpha is untouchable; and representational equalities
                  -- Prefer homogeneous equalities over hetero, because the
                  -- former might be holding up the latter.
                  -- See Note [Equalities with incompatible kinds] in TcCanonical
              , ("Homo eqs",      Ct -> PredTree -> Bool
forall p. p -> PredTree -> Bool
is_homo_equality, Bool
True,  (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter
mkGroupReporter ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkEqErr)
              , ("Other eqs",     Ct -> PredTree -> Bool
is_equality,      Bool
False, (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter
mkGroupReporter ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkEqErr) ]

    -- report2: we suppress these if there are insolubles elsewhere in the tree
    report2 :: [ReporterSpec]
report2 = [ ("Implicit params", Ct -> PredTree -> Bool
is_ip,           Bool
False, (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter
mkGroupReporter ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkIPErr)
              , ("Irreds",          Ct -> PredTree -> Bool
is_irred,        Bool
False, (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter
mkGroupReporter ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkIrredErr)
              , ("Dicts",           Ct -> PredTree -> Bool
is_dict,         Bool
False, (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter
mkGroupReporter ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkDictErr) ]

    -- rigid_nom_eq, rigid_nom_tv_eq,
    is_hole, is_dict,
      is_equality, is_ip, is_irred :: Ct -> PredTree -> Bool

    is_given_eq :: Ct -> PredTree -> Bool
is_given_eq ct :: Ct
ct pred :: PredTree
pred
       | EqPred {} <- PredTree
pred = Ct -> Bool
arisesFromGivens Ct
ct
       | Bool
otherwise         = Bool
False
       -- I think all given residuals are equalities

    -- Things like (Int ~N Bool)
    utterly_wrong :: p -> PredTree -> Bool
utterly_wrong _ (EqPred NomEq ty1 :: Type
ty1 ty2 :: Type
ty2) = Type -> Bool
isRigidTy Type
ty1 Bool -> Bool -> Bool
&& Type -> Bool
isRigidTy Type
ty2
    utterly_wrong _ _                      = Bool
False

    -- Things like (a ~N Int)
    very_wrong :: p -> PredTree -> Bool
very_wrong _ (EqPred NomEq ty1 :: Type
ty1 ty2 :: Type
ty2) = TcLevel -> Type -> Bool
isSkolemTy TcLevel
tc_lvl Type
ty1 Bool -> Bool -> Bool
&& Type -> Bool
isRigidTy Type
ty2
    very_wrong _ _                      = Bool
False

    -- Things like (a ~N b) or (a  ~N  F Bool)
    skolem_eq :: p -> PredTree -> Bool
skolem_eq _ (EqPred NomEq ty1 :: Type
ty1 _) = TcLevel -> Type -> Bool
isSkolemTy TcLevel
tc_lvl Type
ty1
    skolem_eq _ _                    = Bool
False

    -- Things like (F a  ~N  Int)
    non_tv_eq :: p -> PredTree -> Bool
non_tv_eq _ (EqPred NomEq ty1 :: Type
ty1 _) = Bool -> Bool
not (Type -> Bool
isTyVarTy Type
ty1)
    non_tv_eq _ _                    = Bool
False

    is_out_of_scope :: Ct -> p -> Bool
is_out_of_scope ct :: Ct
ct _ = Ct -> Bool
isOutOfScopeCt Ct
ct
    is_hole :: Ct -> PredTree -> Bool
is_hole         ct :: Ct
ct _ = Ct -> Bool
isHoleCt Ct
ct

    is_user_type_error :: Ct -> p -> Bool
is_user_type_error ct :: Ct
ct _ = Ct -> Bool
isUserTypeErrorCt Ct
ct

    is_homo_equality :: p -> PredTree -> Bool
is_homo_equality _ (EqPred _ ty1 :: Type
ty1 ty2 :: Type
ty2) = HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind Type
ty1 HasDebugCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`tcEqType` HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind Type
ty2
    is_homo_equality _ _                  = Bool
False

    is_equality :: Ct -> PredTree -> Bool
is_equality _ (EqPred {}) = Bool
True
    is_equality _ _           = Bool
False

    is_dict :: Ct -> PredTree -> Bool
is_dict _ (ClassPred {}) = Bool
True
    is_dict _ _              = Bool
False

    is_ip :: Ct -> PredTree -> Bool
is_ip _ (ClassPred cls :: Class
cls _) = Class -> Bool
isIPClass Class
cls
    is_ip _ _                 = Bool
False

    is_irred :: Ct -> PredTree -> Bool
is_irred _ (IrredPred {}) = Bool
True
    is_irred _ _              = Bool
False

    given_eq_spec :: ReporterSpec
given_eq_spec  -- See Note [Given errors]
      | [Implication] -> Bool
has_gadt_match (ReportErrCtxt -> [Implication]
cec_encl ReportErrCtxt
ctxt)
      = ("insoluble1a", Ct -> PredTree -> Bool
is_given_eq, Bool
True,  Reporter
mkGivenErrorReporter)
      | Bool
otherwise
      = ("insoluble1b", Ct -> PredTree -> Bool
is_given_eq, Bool
False, Reporter
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!
          --         Trac #13446 is an example

    -- See Note [Given errors]
    has_gadt_match :: [Implication] -> Bool
has_gadt_match [] = Bool
False
    has_gadt_match (implic :: Implication
implic : implics :: [Implication]
implics)
      | PatSkol {} <- Implication -> SkolemInfo
ic_info Implication
implic
      , Bool -> Bool
not (Implication -> Bool
ic_no_eqs Implication
implic)
      , WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnInaccessibleCode (Implication -> DynFlags
implicDynFlags Implication
implic)
          -- Don't bother doing this if -Winaccessible-code isn't enabled.
          -- See Note [Avoid -Winaccessible-code when deriving] in TcInstDcls.
      = Bool
True
      | Bool
otherwise
      = [Implication] -> Bool
has_gadt_match [Implication]
implics

---------------
isSkolemTy :: TcLevel -> Type -> Bool
-- The type is a skolem tyvar
isSkolemTy :: TcLevel -> Type -> Bool
isSkolemTy tc_lvl :: TcLevel
tc_lvl ty :: Type
ty
  | Just tv :: TyCoVar
tv <- Type -> Maybe TyCoVar
getTyVar_maybe Type
ty
  =  TyCoVar -> Bool
isSkolemTyVar TyCoVar
tv
  Bool -> Bool -> Bool
|| (TyCoVar -> Bool
isTyVarTyVar TyCoVar
tv Bool -> Bool -> Bool
&& TcLevel -> TyCoVar -> Bool
isTouchableMetaTyVar TcLevel
tc_lvl TyCoVar
tv)
     -- The last case is for touchable TyVarTvs
     -- we postpone untouchables to a latter test (too obscure)

  | Bool
otherwise
  = Bool
False

isTyFun_maybe :: Type -> Maybe TyCon
isTyFun_maybe :: Type -> Maybe TyCon
isTyFun_maybe ty :: Type
ty = case HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty of
                      Just (tc :: TyCon
tc,_) | TyCon -> Bool
isTypeFamilyTyCon TyCon
tc -> TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just TyCon
tc
                      _ -> Maybe TyCon
forall a. Maybe a
Nothing

--------------------------------------------
--      Reporters
--------------------------------------------

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
-- Suppress duplicates with either the same LHS, or same location
mkSkolReporter :: Reporter
mkSkolReporter ctxt :: ReportErrCtxt
ctxt cts :: [Ct]
cts
  = ([Ct] -> TcM ()) -> [[Ct]] -> TcM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter
reportGroup ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkEqErr ReportErrCtxt
ctxt) ([Ct] -> [[Ct]]
group [Ct]
cts)
  where
     group :: [Ct] -> [[Ct]]
group [] = []
     group (ct :: Ct
ct:cts :: [Ct]
cts) = (Ct
ct Ct -> [Ct] -> [Ct]
forall a. a -> [a] -> [a]
: [Ct]
yeses) [Ct] -> [[Ct]] -> [[Ct]]
forall a. a -> [a] -> [a]
: [Ct] -> [[Ct]]
group [Ct]
noes
        where
          (yeses :: [Ct]
yeses, noes :: [Ct]
noes) = (Ct -> Bool) -> [Ct] -> ([Ct], [Ct])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Ct -> Ct -> Bool
group_with Ct
ct) [Ct]
cts

     group_with :: Ct -> Ct -> Bool
group_with ct1 :: Ct
ct1 ct2 :: Ct
ct2
       | Ordering
EQ <- Ct -> Ct -> Ordering
cmp_loc Ct
ct1 Ct
ct2 = Bool
True
       | Ct -> Ct -> Bool
eq_lhs_type   Ct
ct1 Ct
ct2 = Bool
True
       | Bool
otherwise             = Bool
False

mkHoleReporter :: [Ct] -> Reporter
-- Reports errors one at a time
mkHoleReporter :: [Ct] -> Reporter
mkHoleReporter tidy_simples :: [Ct]
tidy_simples ctxt :: ReportErrCtxt
ctxt
  = (Ct -> TcM ()) -> [Ct] -> TcM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Ct -> TcM ()) -> [Ct] -> TcM ())
-> (Ct -> TcM ()) -> [Ct] -> TcM ()
forall a b. (a -> b) -> a -> b
$ \ct :: Ct
ct -> do { ErrMsg
err <- [Ct] -> ReportErrCtxt -> Ct -> TcM ErrMsg
mkHoleError [Ct]
tidy_simples ReportErrCtxt
ctxt Ct
ct
                      ; ReportErrCtxt -> Ct -> ErrMsg -> TcM ()
maybeReportHoleError ReportErrCtxt
ctxt Ct
ct ErrMsg
err
                      ; ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
maybeAddDeferredHoleBinding ReportErrCtxt
ctxt ErrMsg
err Ct
ct }

mkUserTypeErrorReporter :: Reporter
mkUserTypeErrorReporter :: Reporter
mkUserTypeErrorReporter ctxt :: ReportErrCtxt
ctxt
  = (Ct -> TcM ()) -> [Ct] -> TcM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Ct -> TcM ()) -> [Ct] -> TcM ())
-> (Ct -> TcM ()) -> [Ct] -> TcM ()
forall a b. (a -> b) -> a -> b
$ \ct :: Ct
ct -> do { ErrMsg
err <- ReportErrCtxt -> Ct -> TcM ErrMsg
mkUserTypeError ReportErrCtxt
ctxt Ct
ct
                      ; ReportErrCtxt -> ErrMsg -> TcM ()
maybeReportError ReportErrCtxt
ctxt ErrMsg
err
                      ; ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
addDeferredBinding ReportErrCtxt
ctxt ErrMsg
err Ct
ct }

mkUserTypeError :: ReportErrCtxt -> Ct -> TcM ErrMsg
mkUserTypeError :: ReportErrCtxt -> Ct -> TcM ErrMsg
mkUserTypeError ctxt :: ReportErrCtxt
ctxt ct :: Ct
ct = ReportErrCtxt -> Ct -> Report -> TcM ErrMsg
mkErrorMsgFromCt ReportErrCtxt
ctxt Ct
ct
                        (Report -> TcM ErrMsg) -> Report -> TcM ErrMsg
forall a b. (a -> b) -> a -> b
$ SDoc -> Report
important
                        (SDoc -> Report) -> SDoc -> Report
forall a b. (a -> b) -> a -> b
$ Type -> SDoc
pprUserTypeErrorTy
                        (Type -> SDoc) -> Type -> SDoc
forall a b. (a -> b) -> a -> b
$ case Ct -> Maybe Type
getUserTypeErrorMsg Ct
ct of
                            Just msg :: Type
msg -> Type
msg
                            Nothing  -> String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic "mkUserTypeError" (Ct -> SDoc
forall a. Outputable a => a -> SDoc
ppr Ct
ct)


mkGivenErrorReporter :: Reporter
-- See Note [Given errors]
mkGivenErrorReporter :: Reporter
mkGivenErrorReporter ctxt :: ReportErrCtxt
ctxt cts :: [Ct]
cts
  = do { (ctxt :: ReportErrCtxt
ctxt, binds_msg :: SDoc
binds_msg, ct :: Ct
ct) <- Bool -> ReportErrCtxt -> Ct -> TcM (ReportErrCtxt, SDoc, Ct)
relevantBindings Bool
True ReportErrCtxt
ctxt Ct
ct
       ; DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; let (implic :: Implication
implic:_) = ReportErrCtxt -> [Implication]
cec_encl ReportErrCtxt
ctxt
                 -- Always non-empty when mkGivenErrorReporter is called
             ct' :: Ct
ct' = Ct -> CtLoc -> Ct
setCtLoc Ct
ct (CtLoc -> TcLclEnv -> CtLoc
setCtLocEnv (Ct -> CtLoc
ctLoc Ct
ct) (Implication -> TcLclEnv
implicLclEnv Implication
implic))
                   -- For given constraints we overwrite the env (and hence src-loc)
                   -- with one from the immediately-enclosing implication.
                   -- See Note [Inaccessible code]

             inaccessible_msg :: SDoc
inaccessible_msg = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Inaccessible code in")
                                   2 (SkolemInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Implication -> SkolemInfo
ic_info Implication
implic))
             report :: Report
report = SDoc -> Report
important SDoc
inaccessible_msg Report -> Report -> Report
forall a. Monoid a => a -> a -> a
`mappend`
                      SDoc -> Report
relevant_bindings SDoc
binds_msg

       ; ErrMsg
err <- DynFlags
-> ReportErrCtxt
-> Report
-> Ct
-> Maybe SwapFlag
-> Type
-> Type
-> TcM ErrMsg
mkEqErr_help DynFlags
dflags ReportErrCtxt
ctxt Report
report Ct
ct'
                             Maybe SwapFlag
forall a. Maybe a
Nothing Type
ty1 Type
ty2

       ; String -> SDoc -> TcM ()
traceTc "mkGivenErrorReporter" (Ct -> SDoc
forall a. Outputable a => a -> SDoc
ppr Ct
ct)
       ; WarnReason -> ErrMsg -> TcM ()
reportWarning (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnInaccessibleCode) ErrMsg
err }
  where
    (ct :: Ct
ct : _ )  = [Ct]
cts    -- Never empty
    (ty1 :: Type
ty1, ty2 :: Type
ty2) = Type -> (Type, Type)
getEqPredTys (Ct -> Type
ctPred Ct
ct)

ignoreErrorReporter :: Reporter
-- Discard Given errors that don't come from
-- a pattern match; maybe we should warn instead?
ignoreErrorReporter :: Reporter
ignoreErrorReporter ctxt :: ReportErrCtxt
ctxt cts :: [Ct]
cts
  = do { String -> SDoc -> TcM ()
traceTc "mkGivenErrorReporter no" ([Ct] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Ct]
cts SDoc -> SDoc -> SDoc
$$ [Implication] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ReportErrCtxt -> [Implication]
cec_encl ReportErrCtxt
ctxt))
       ; () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return () }


{- Note [Given errors]
~~~~~~~~~~~~~~~~~~~~~~
Given constraints represent things for which we have (or will have)
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
#12466 for a long discussion.  For example, if we aren't careful
we'll complain about
   f :: ((Int ~ Bool) => a -> a) -> Int
which arguably is OK.  It's more debatable for
   g :: (Int ~ Bool) => Int -> Int
but it's tricky to distinguish these cases so we don't report
either.

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

mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg)
                             -- Make error message for a group
                -> Reporter  -- Deal with lots of constraints
-- Group together errors from same location,
-- and report only the first (to avoid a cascade)
mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter
mkGroupReporter mk_err :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mk_err ctxt :: ReportErrCtxt
ctxt cts :: [Ct]
cts
  = (NonEmpty Ct -> TcM ()) -> [NonEmpty Ct] -> TcM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter
reportGroup ReportErrCtxt -> [Ct] -> TcM ErrMsg
mk_err ReportErrCtxt
ctxt ([Ct] -> TcM ()) -> (NonEmpty Ct -> [Ct]) -> NonEmpty Ct -> TcM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Ct -> [Ct]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList) ((Ct -> Ct -> Ordering) -> [Ct] -> [NonEmpty Ct]
forall a. (a -> a -> Ordering) -> [a] -> [NonEmpty a]
equivClasses Ct -> Ct -> Ordering
cmp_loc [Ct]
cts)

eq_lhs_type :: Ct -> Ct -> Bool
eq_lhs_type :: Ct -> Ct -> Bool
eq_lhs_type ct1 :: Ct
ct1 ct2 :: Ct
ct2
  = case (Type -> PredTree
classifyPredType (Ct -> Type
ctPred Ct
ct1), Type -> PredTree
classifyPredType (Ct -> Type
ctPred Ct
ct2)) of
       (EqPred eq_rel1 :: EqRel
eq_rel1 ty1 :: Type
ty1 _, EqPred eq_rel2 :: EqRel
eq_rel2 ty2 :: Type
ty2 _) ->
         (EqRel
eq_rel1 EqRel -> EqRel -> Bool
forall a. Eq a => a -> a -> Bool
== EqRel
eq_rel2) Bool -> Bool -> Bool
&& (Type
ty1 Type -> Type -> Bool
`eqType` Type
ty2)
       _ -> String -> SDoc -> Bool
forall a. HasCallStack => String -> SDoc -> a
pprPanic "mkSkolReporter" (Ct -> SDoc
forall a. Outputable a => a -> SDoc
ppr Ct
ct1 SDoc -> SDoc -> SDoc
$$ Ct -> SDoc
forall a. Outputable a => a -> SDoc
ppr Ct
ct2)

cmp_loc :: Ct -> Ct -> Ordering
cmp_loc :: Ct -> Ct -> Ordering
cmp_loc ct1 :: Ct
ct1 ct2 :: Ct
ct2 = CtLoc -> RealSrcSpan
ctLocSpan (Ct -> CtLoc
ctLoc Ct
ct1) RealSrcSpan -> RealSrcSpan -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` CtLoc -> RealSrcSpan
ctLocSpan (Ct -> CtLoc
ctLoc Ct
ct2)

reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> ReportErrCtxt
            -> [Ct] -> TcM ()
reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter
reportGroup mk_err :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mk_err ctxt :: ReportErrCtxt
ctxt cts :: [Ct]
cts =
  case (Ct -> Bool) -> [Ct] -> ([Ct], [Ct])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Ct -> Bool
isMonadFailInstanceMissing [Ct]
cts of
        -- Only warn about missing MonadFail constraint when
        -- there are no other missing constraints!
        (monadFailCts :: [Ct]
monadFailCts, []) ->
            do { ErrMsg
err <- ReportErrCtxt -> [Ct] -> TcM ErrMsg
mk_err ReportErrCtxt
ctxt [Ct]
monadFailCts
               ; WarnReason -> ErrMsg -> TcM ()
reportWarning (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnMissingMonadFailInstances) ErrMsg
err }

        (_, cts' :: [Ct]
cts') -> do { ErrMsg
err <- ReportErrCtxt -> [Ct] -> TcM ErrMsg
mk_err ReportErrCtxt
ctxt [Ct]
cts'
                        ; String -> SDoc -> TcM ()
traceTc "About to maybeReportErr" (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
                          [SDoc] -> SDoc
vcat [ String -> SDoc
text "Constraint:"             SDoc -> SDoc -> SDoc
<+> [Ct] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Ct]
cts'
                               , String -> SDoc
text "cec_suppress ="          SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ReportErrCtxt -> Bool
cec_suppress ReportErrCtxt
ctxt)
                               , String -> SDoc
text "cec_defer_type_errors =" SDoc -> SDoc -> SDoc
<+> TypeErrorChoice -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ReportErrCtxt -> TypeErrorChoice
cec_defer_type_errors ReportErrCtxt
ctxt) ]
                        ; ReportErrCtxt -> ErrMsg -> TcM ()
maybeReportError ReportErrCtxt
ctxt ErrMsg
err
                            -- But see Note [Always warn with -fdefer-type-errors]
                        ; String -> SDoc -> TcM ()
traceTc "reportGroup" ([Ct] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Ct]
cts')
                        ; (Ct -> TcM ()) -> [Ct] -> TcM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
addDeferredBinding ReportErrCtxt
ctxt ErrMsg
err) [Ct]
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
                            -- abort, we need bindings for all (e.g. Trac #12156)
  where
    isMonadFailInstanceMissing :: Ct -> Bool
isMonadFailInstanceMissing ct :: Ct
ct =
        case CtLoc -> CtOrigin
ctLocOrigin (Ct -> CtLoc
ctLoc Ct
ct) of
            FailablePattern _pat :: LPat GhcTcId
_pat -> Bool
True
            _otherwise :: CtOrigin
_otherwise           -> Bool
False

maybeReportHoleError :: ReportErrCtxt -> Ct -> ErrMsg -> TcM ()
-- Unlike maybeReportError, these "hole" errors are
-- /not/ suppressed by cec_suppress.  We want to see them!
maybeReportHoleError :: ReportErrCtxt -> Ct -> ErrMsg -> TcM ()
maybeReportHoleError ctxt :: ReportErrCtxt
ctxt ct :: Ct
ct err :: ErrMsg
err
  -- When -XPartialTypeSignatures is on, warnings (instead of errors) are
  -- generated for holes in partial type signatures.
  -- Unless -fwarn_partial_type_signatures is not on,
  -- in which case the messages are discarded.
  | Ct -> Bool
isTypeHoleCt Ct
ct
  = -- For partial type signatures, generate warnings only, and do that
    -- only if -fwarn_partial_type_signatures is on
    case ReportErrCtxt -> HoleChoice
cec_type_holes ReportErrCtxt
ctxt of
       HoleError -> ErrMsg -> TcM ()
reportError ErrMsg
err
       HoleWarn  -> WarnReason -> ErrMsg -> TcM ()
reportWarning (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnPartialTypeSignatures) ErrMsg
err
       HoleDefer -> () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  -- Always report an error for out-of-scope variables
  -- Unless -fdefer-out-of-scope-variables is on,
  -- in which case the messages are discarded.
  -- See Trac #12170, #12406
  | Ct -> Bool
isOutOfScopeCt Ct
ct
  = -- If deferring, report a warning only if -Wout-of-scope-variables is on
    case ReportErrCtxt -> HoleChoice
cec_out_of_scope_holes ReportErrCtxt
ctxt of
      HoleError -> ErrMsg -> TcM ()
reportError ErrMsg
err
      HoleWarn  ->
        WarnReason -> ErrMsg -> TcM ()
reportWarning (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnDeferredOutOfScopeVariables) ErrMsg
err
      HoleDefer -> () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  -- Otherwise this is a typed hole in an expression,
  -- but not for an out-of-scope variable
  | Bool
otherwise
  = -- If deferring, report a warning only if -Wtyped-holes is on
    case ReportErrCtxt -> HoleChoice
cec_expr_holes ReportErrCtxt
ctxt of
       HoleError -> ErrMsg -> TcM ()
reportError ErrMsg
err
       HoleWarn  -> WarnReason -> ErrMsg -> TcM ()
reportWarning (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnTypedHoles) ErrMsg
err
       HoleDefer -> () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

maybeReportError :: ReportErrCtxt -> ErrMsg -> TcM ()
-- Report the error and/or make a deferred binding for it
maybeReportError :: ReportErrCtxt -> ErrMsg -> TcM ()
maybeReportError ctxt :: ReportErrCtxt
ctxt err :: ErrMsg
err
  | ReportErrCtxt -> Bool
cec_suppress ReportErrCtxt
ctxt    -- Some worse error has occurred;
  = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()            -- so suppress this error/warning

  | Bool
otherwise
  = case ReportErrCtxt -> TypeErrorChoice
cec_defer_type_errors ReportErrCtxt
ctxt of
      TypeDefer       -> () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      TypeWarn reason :: WarnReason
reason -> WarnReason -> ErrMsg -> TcM ()
reportWarning WarnReason
reason ErrMsg
err
      TypeError       -> ErrMsg -> TcM ()
reportError ErrMsg
err

addDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
-- See Note [Deferring coercion errors to runtime]
addDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
addDeferredBinding ctxt :: ReportErrCtxt
ctxt err :: ErrMsg
err ct :: Ct
ct
  | ReportErrCtxt -> Bool
deferringAnyBindings ReportErrCtxt
ctxt
  , CtWanted { ctev_pred :: CtEvidence -> Type
ctev_pred = Type
pred, ctev_dest :: CtEvidence -> TcEvDest
ctev_dest = TcEvDest
dest } <- Ct -> CtEvidence
ctEvidence Ct
ct
    -- Only add deferred bindings for Wanted constraints
  = do { DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; let err_msg :: SDoc
err_msg = ErrMsg -> SDoc
pprLocErrMsg ErrMsg
err
             err_fs :: FastString
err_fs  = String -> FastString
mkFastString (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$
                       SDoc
err_msg SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "(deferred type error)"
             err_tm :: EvTerm
err_tm  = Type -> FastString -> EvTerm
evDelayedError Type
pred FastString
err_fs
             ev_binds_var :: EvBindsVar
ev_binds_var = ReportErrCtxt -> EvBindsVar
cec_binds ReportErrCtxt
ctxt

       ; case TcEvDest
dest of
           EvVarDest evar :: TyCoVar
evar
             -> EvBindsVar -> EvBind -> TcM ()
addTcEvBind EvBindsVar
ev_binds_var (EvBind -> TcM ()) -> EvBind -> TcM ()
forall a b. (a -> b) -> a -> b
$ TyCoVar -> EvTerm -> EvBind
mkWantedEvBind TyCoVar
evar EvTerm
err_tm
           HoleDest hole :: CoercionHole
hole
             -> do { -- See Note [Deferred errors for coercion holes]
                     let co_var :: TyCoVar
co_var = CoercionHole -> TyCoVar
coHoleCoVar CoercionHole
hole
                   ; EvBindsVar -> EvBind -> TcM ()
addTcEvBind EvBindsVar
ev_binds_var (EvBind -> TcM ()) -> EvBind -> TcM ()
forall a b. (a -> b) -> a -> b
$ TyCoVar -> EvTerm -> EvBind
mkWantedEvBind TyCoVar
co_var EvTerm
err_tm
                   ; CoercionHole -> Coercion -> TcM ()
fillCoercionHole CoercionHole
hole (TyCoVar -> Coercion
mkTcCoVarCo TyCoVar
co_var) }}

  | Bool
otherwise   -- Do not set any evidence for Given/Derived
  = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

maybeAddDeferredHoleBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
maybeAddDeferredHoleBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
maybeAddDeferredHoleBinding ctxt :: ReportErrCtxt
ctxt err :: ErrMsg
err ct :: Ct
ct
  | Ct -> Bool
isExprHoleCt Ct
ct
  = ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
addDeferredBinding ReportErrCtxt
ctxt ErrMsg
err Ct
ct  -- Only add bindings for holes in expressions
  | Bool
otherwise                       -- not for holes in partial type signatures
  = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct])
-- Use the first reporter in the list whose predicate says True
tryReporters :: ReportErrCtxt
-> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct])
tryReporters ctxt :: ReportErrCtxt
ctxt reporters :: [ReporterSpec]
reporters cts :: [Ct]
cts
  = do { let (vis_cts :: [Ct]
vis_cts, invis_cts :: [Ct]
invis_cts) = (Ct -> Bool) -> [Ct] -> ([Ct], [Ct])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (CtOrigin -> Bool
isVisibleOrigin (CtOrigin -> Bool) -> (Ct -> CtOrigin) -> Ct -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ct -> CtOrigin
ctOrigin) [Ct]
cts
       ; String -> SDoc -> TcM ()
traceTc "tryReporters {" ([Ct] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Ct]
vis_cts SDoc -> SDoc -> SDoc
$$ [Ct] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Ct]
invis_cts)
       ; (ctxt' :: ReportErrCtxt
ctxt', cts' :: [Ct]
cts') <- ReportErrCtxt
-> [ReporterSpec] -> [Ct] -> [Ct] -> TcM (ReportErrCtxt, [Ct])
go ReportErrCtxt
ctxt [ReporterSpec]
reporters [Ct]
vis_cts [Ct]
invis_cts
       ; String -> SDoc -> TcM ()
traceTc "tryReporters }" ([Ct] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Ct]
cts')
       ; (ReportErrCtxt, [Ct]) -> TcM (ReportErrCtxt, [Ct])
forall (m :: * -> *) a. Monad m => a -> m a
return (ReportErrCtxt
ctxt', [Ct]
cts') }
  where
    go :: ReportErrCtxt
-> [ReporterSpec] -> [Ct] -> [Ct] -> TcM (ReportErrCtxt, [Ct])
go ctxt :: ReportErrCtxt
ctxt [] vis_cts :: [Ct]
vis_cts invis_cts :: [Ct]
invis_cts
      = (ReportErrCtxt, [Ct]) -> TcM (ReportErrCtxt, [Ct])
forall (m :: * -> *) a. Monad m => a -> m a
return (ReportErrCtxt
ctxt, [Ct]
vis_cts [Ct] -> [Ct] -> [Ct]
forall a. [a] -> [a] -> [a]
++ [Ct]
invis_cts)

    go ctxt :: ReportErrCtxt
ctxt (r :: ReporterSpec
r : rs :: [ReporterSpec]
rs) vis_cts :: [Ct]
vis_cts invis_cts :: [Ct]
invis_cts
       -- always look at *visible* Origins before invisible ones
       -- this is the whole point of isVisibleOrigin
      = do { (ctxt' :: ReportErrCtxt
ctxt', vis_cts' :: [Ct]
vis_cts') <- ReportErrCtxt -> ReporterSpec -> [Ct] -> TcM (ReportErrCtxt, [Ct])
tryReporter ReportErrCtxt
ctxt ReporterSpec
r [Ct]
vis_cts
           ; (ctxt'' :: ReportErrCtxt
ctxt'', invis_cts' :: [Ct]
invis_cts') <- ReportErrCtxt -> ReporterSpec -> [Ct] -> TcM (ReportErrCtxt, [Ct])
tryReporter ReportErrCtxt
ctxt' ReporterSpec
r [Ct]
invis_cts
           ; ReportErrCtxt
-> [ReporterSpec] -> [Ct] -> [Ct] -> TcM (ReportErrCtxt, [Ct])
go ReportErrCtxt
ctxt'' [ReporterSpec]
rs [Ct]
vis_cts' [Ct]
invis_cts' }
                -- Carry on with the rest, because we must make
                -- deferred bindings for them if we have -fdefer-type-errors
                -- But suppress their error messages

tryReporter :: ReportErrCtxt -> ReporterSpec -> [Ct] -> TcM (ReportErrCtxt, [Ct])
tryReporter :: ReportErrCtxt -> ReporterSpec -> [Ct] -> TcM (ReportErrCtxt, [Ct])
tryReporter ctxt :: ReportErrCtxt
ctxt (str :: String
str, keep_me :: Ct -> PredTree -> Bool
keep_me,  suppress_after :: Bool
suppress_after, reporter :: Reporter
reporter) cts :: [Ct]
cts
  | [Ct] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Ct]
yeses
  = (ReportErrCtxt, [Ct]) -> TcM (ReportErrCtxt, [Ct])
forall (m :: * -> *) a. Monad m => a -> m a
return (ReportErrCtxt
ctxt, [Ct]
cts)
  | Bool
otherwise
  = do { String -> SDoc -> TcM ()
traceTc "tryReporter{ " (String -> SDoc
text String
str SDoc -> SDoc -> SDoc
<+> [Ct] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Ct]
yeses)
       ; (_, no_errs :: Bool
no_errs) <- TcM () -> TcRn ((), Bool)
forall a. TcRn a -> TcRn (a, Bool)
askNoErrs (Reporter
reporter ReportErrCtxt
ctxt [Ct]
yeses)
       ; let suppress_now :: Bool
suppress_now = Bool -> Bool
not Bool
no_errs Bool -> Bool -> Bool
&& Bool
suppress_after
                            -- See Note [Suppressing error messages]
             ctxt' :: ReportErrCtxt
ctxt' = ReportErrCtxt
ctxt { cec_suppress :: Bool
cec_suppress = Bool
suppress_now Bool -> Bool -> Bool
|| ReportErrCtxt -> Bool
cec_suppress ReportErrCtxt
ctxt }
       ; String -> SDoc -> TcM ()
traceTc "tryReporter end }" (String -> SDoc
text String
str SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ReportErrCtxt -> Bool
cec_suppress ReportErrCtxt
ctxt) SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
suppress_after)
       ; (ReportErrCtxt, [Ct]) -> TcM (ReportErrCtxt, [Ct])
forall (m :: * -> *) a. Monad m => a -> m a
return (ReportErrCtxt
ctxt', [Ct]
nos) }
  where
    (yeses :: [Ct]
yeses, nos :: [Ct]
nos) = (Ct -> Bool) -> [Ct] -> ([Ct], [Ct])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\ct :: Ct
ct -> Ct -> PredTree -> Bool
keep_me Ct
ct (Type -> PredTree
classifyPredType (Ct -> Type
ctPred Ct
ct))) [Ct]
cts


pprArising :: CtOrigin -> SDoc
-- Used for the main, top-level error message
-- We've done special processing for TypeEq, KindEq, Given
pprArising :: CtOrigin -> SDoc
pprArising (TypeEqOrigin {}) = SDoc
empty
pprArising (KindEqOrigin {}) = SDoc
empty
pprArising (GivenOrigin {})  = SDoc
empty
pprArising orig :: CtOrigin
orig              = CtOrigin -> SDoc
pprCtOrigin CtOrigin
orig

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

pprWithArising :: [Ct] -> (CtLoc, SDoc)
-- Print something like
--    (Eq a) arising from a use of x at y
--    (Show a) arising from a use of p at q
-- Also return a location for the error message
-- Works for Wanted/Derived only
pprWithArising :: [Ct] -> (CtLoc, SDoc)
pprWithArising []
  = String -> (CtLoc, SDoc)
forall a. String -> a
panic "pprWithArising"
pprWithArising (ct :: Ct
ct:cts :: [Ct]
cts)
  | [Ct] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Ct]
cts
  = (CtLoc
loc, CtOrigin -> SDoc -> SDoc
addArising (CtLoc -> CtOrigin
ctLocOrigin CtLoc
loc)
                     ([Type] -> SDoc
pprTheta [Ct -> Type
ctPred Ct
ct]))
  | Bool
otherwise
  = (CtLoc
loc, [SDoc] -> SDoc
vcat ((Ct -> SDoc) -> [Ct] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Ct -> SDoc
ppr_one (Ct
ctCt -> [Ct] -> [Ct]
forall a. a -> [a] -> [a]
:[Ct]
cts)))
  where
    loc :: CtLoc
loc = Ct -> CtLoc
ctLoc Ct
ct
    ppr_one :: Ct -> SDoc
ppr_one ct' :: Ct
ct' = SDoc -> Int -> SDoc -> SDoc
hang (SDoc -> SDoc
parens (Type -> SDoc
pprType (Ct -> Type
ctPred Ct
ct')))
                     2 (CtLoc -> SDoc
pprCtLoc (Ct -> CtLoc
ctLoc Ct
ct'))

mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> Report -> TcM ErrMsg
mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> Report -> TcM ErrMsg
mkErrorMsgFromCt ctxt :: ReportErrCtxt
ctxt ct :: Ct
ct report :: Report
report
  = ReportErrCtxt -> TcLclEnv -> Report -> TcM ErrMsg
mkErrorReport ReportErrCtxt
ctxt (CtLoc -> TcLclEnv
ctLocEnv (Ct -> CtLoc
ctLoc Ct
ct)) Report
report

mkErrorReport :: ReportErrCtxt -> TcLclEnv -> Report -> TcM ErrMsg
mkErrorReport :: ReportErrCtxt -> TcLclEnv -> Report -> TcM ErrMsg
mkErrorReport ctxt :: ReportErrCtxt
ctxt tcl_env :: TcLclEnv
tcl_env (Report important :: [SDoc]
important relevant_bindings :: [SDoc]
relevant_bindings valid_subs :: [SDoc]
valid_subs)
  = do { SDoc
context <- TidyEnv -> [ErrCtxt] -> TcM SDoc
mkErrInfo (ReportErrCtxt -> TidyEnv
cec_tidy ReportErrCtxt
ctxt) (TcLclEnv -> [ErrCtxt]
tcl_ctxt TcLclEnv
tcl_env)
       ; SrcSpan -> ErrDoc -> TcM ErrMsg
mkErrDocAt (RealSrcSpan -> SrcSpan
RealSrcSpan (TcLclEnv -> RealSrcSpan
tcl_loc TcLclEnv
tcl_env))
            ([SDoc] -> [SDoc] -> [SDoc] -> ErrDoc
errDoc [SDoc]
important [SDoc
context] ([SDoc]
relevant_bindings [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [SDoc]
valid_subs))
       }

type UserGiven = Implication

getUserGivens :: ReportErrCtxt -> [UserGiven]
-- One item for each enclosing implication
getUserGivens :: ReportErrCtxt -> [Implication]
getUserGivens (CEC {cec_encl :: ReportErrCtxt -> [Implication]
cec_encl = [Implication]
implics}) = [Implication] -> [Implication]
getUserGivensFromImplics [Implication]
implics

getUserGivensFromImplics :: [Implication] -> [UserGiven]
getUserGivensFromImplics :: [Implication] -> [Implication]
getUserGivensFromImplics implics :: [Implication]
implics
  = [Implication] -> [Implication]
forall a. [a] -> [a]
reverse ((Implication -> Bool) -> [Implication] -> [Implication]
forall a. (a -> Bool) -> [a] -> [a]
filterOut ([TyCoVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([TyCoVar] -> Bool)
-> (Implication -> [TyCoVar]) -> Implication -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Implication -> [TyCoVar]
ic_given) [Implication]
implics)

{- Note [Always warn with -fdefer-type-errors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When -fdefer-type-errors is on we warn about *all* type errors, even
if cec_suppress is on.  This can lead to a lot more warnings than you
would get errors without -fdefer-type-errors, but if we suppress any of
them you might get a runtime error that wasn't warned about at compile
time.

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

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

With #10283, you can now opt out of deferred type error warnings.

Note [Deferred errors for coercion holes]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we need to defer a type error where the destination for the evidence
is a coercion hole. We can't just put the error in the hole, because we can't
make an erroneous coercion. (Remember that coercions are erased for runtime.)
Instead, we invent a new EvVar, bind it to an error and then make a coercion
from that EvVar, filling the hole with that coercion. Because coercions'
types are unlifted, the error is guaranteed to be hit before we get to the
coercion.

Note [Do not report derived but soluble errors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The wc_simples include Derived constraints that have not been solved,
but are not insoluble (in that case they'd be reported by 'report1').
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_simple 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.


************************************************************************
*                                                                      *
                Irreducible predicate errors
*                                                                      *
************************************************************************
-}

mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkIrredErr ctxt :: ReportErrCtxt
ctxt cts :: [Ct]
cts
  = do { (ctxt :: ReportErrCtxt
ctxt, binds_msg :: SDoc
binds_msg, ct1 :: Ct
ct1) <- Bool -> ReportErrCtxt -> Ct -> TcM (ReportErrCtxt, SDoc, Ct)
relevantBindings Bool
True ReportErrCtxt
ctxt Ct
ct1
       ; let orig :: CtOrigin
orig = Ct -> CtOrigin
ctOrigin Ct
ct1
             msg :: SDoc
msg  = [Implication] -> ([Type], CtOrigin) -> SDoc
couldNotDeduce (ReportErrCtxt -> [Implication]
getUserGivens ReportErrCtxt
ctxt) ((Ct -> Type) -> [Ct] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Ct -> Type
ctPred [Ct]
cts, CtOrigin
orig)
       ; ReportErrCtxt -> Ct -> Report -> TcM ErrMsg
mkErrorMsgFromCt ReportErrCtxt
ctxt Ct
ct1 (Report -> TcM ErrMsg) -> Report -> TcM ErrMsg
forall a b. (a -> b) -> a -> b
$
            SDoc -> Report
important SDoc
msg Report -> Report -> Report
forall a. Monoid a => a -> a -> a
`mappend` SDoc -> Report
relevant_bindings SDoc
binds_msg }
  where
    (ct1 :: Ct
ct1:_) = [Ct]
cts

----------------
mkHoleError :: [Ct] -> ReportErrCtxt -> Ct -> TcM ErrMsg
mkHoleError :: [Ct] -> ReportErrCtxt -> Ct -> TcM ErrMsg
mkHoleError _ _ ct :: Ct
ct@(CHoleCan { cc_hole :: Ct -> Hole
cc_hole = ExprHole (OutOfScope occ :: OccName
occ rdr_env0 :: GlobalRdrEnv
rdr_env0) })
  -- Out-of-scope variables, like 'a', where 'a' isn't bound; suggest possible
  -- in-scope variables in the message, and note inaccessible exact matches
  = do { DynFlags
dflags   <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; ImportAvails
imp_info <- TcRn ImportAvails
getImports
       ; Module
curr_mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
       ; HomePackageTable
hpt <- TcRnIf TcGblEnv TcLclEnv HomePackageTable
forall gbl lcl. TcRnIf gbl lcl HomePackageTable
getHpt
       ; let suggs_msg :: SDoc
suggs_msg = DynFlags
-> HomePackageTable
-> Module
-> GlobalRdrEnv
-> LocalRdrEnv
-> ImportAvails
-> RdrName
-> SDoc
unknownNameSuggestions DynFlags
dflags HomePackageTable
hpt Module
curr_mod GlobalRdrEnv
rdr_env0
                                                (TcLclEnv -> LocalRdrEnv
tcl_rdr TcLclEnv
lcl_env) ImportAvails
imp_info RdrName
rdr
       ; GlobalRdrEnv
rdr_env     <- TcRn GlobalRdrEnv
getGlobalRdrEnv
       ; Set RealSrcSpan
splice_locs <- TcM (Set RealSrcSpan)
getTopLevelSpliceLocs
       ; let match_msgs :: [SDoc]
match_msgs = GlobalRdrEnv -> Set RealSrcSpan -> [SDoc]
mk_match_msgs GlobalRdrEnv
rdr_env Set RealSrcSpan
splice_locs
       ; SrcSpan -> ErrDoc -> TcM ErrMsg
mkErrDocAt (RealSrcSpan -> SrcSpan
RealSrcSpan RealSrcSpan
err_loc) (ErrDoc -> TcM ErrMsg) -> ErrDoc -> TcM ErrMsg
forall a b. (a -> b) -> a -> b
$
                    [SDoc] -> [SDoc] -> [SDoc] -> ErrDoc
errDoc [SDoc
out_of_scope_msg] [] ([SDoc]
match_msgs [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [SDoc
suggs_msg]) }

  where
    rdr :: RdrName
rdr         = OccName -> RdrName
mkRdrUnqual OccName
occ
    ct_loc :: CtLoc
ct_loc      = Ct -> CtLoc
ctLoc Ct
ct
    lcl_env :: TcLclEnv
lcl_env     = CtLoc -> TcLclEnv
ctLocEnv CtLoc
ct_loc
    err_loc :: RealSrcSpan
err_loc     = TcLclEnv -> RealSrcSpan
tcl_loc TcLclEnv
lcl_env
    hole_ty :: Type
hole_ty     = CtEvidence -> Type
ctEvPred (Ct -> CtEvidence
ctEvidence Ct
ct)
    boring_type :: Bool
boring_type = Type -> Bool
isTyVarTy Type
hole_ty

    out_of_scope_msg :: SDoc
out_of_scope_msg -- Print v :: ty only if the type has structure
      | Bool
boring_type = SDoc -> Int -> SDoc -> SDoc
hang SDoc
herald 2 (OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
occ)
      | Bool
otherwise   = SDoc -> Int -> SDoc -> SDoc
hang SDoc
herald 2 (OccName -> Type -> SDoc
pp_with_type OccName
occ Type
hole_ty)

    herald :: SDoc
herald | OccName -> Bool
isDataOcc OccName
occ = String -> SDoc
text "Data constructor not in scope:"
           | Bool
otherwise     = String -> SDoc
text "Variable not in scope:"

    -- Indicate if the out-of-scope variable exactly (and unambiguously) matches
    -- a top-level binding in a later inter-splice group; see Note [OutOfScope
    -- exact matches]
    mk_match_msgs :: GlobalRdrEnv -> Set RealSrcSpan -> [SDoc]
mk_match_msgs rdr_env :: GlobalRdrEnv
rdr_env splice_locs :: Set RealSrcSpan
splice_locs
      = let gres :: [GlobalRdrElt]
gres = (GlobalRdrElt -> Bool) -> [GlobalRdrElt] -> [GlobalRdrElt]
forall a. (a -> Bool) -> [a] -> [a]
filter GlobalRdrElt -> Bool
isLocalGRE (GlobalRdrEnv -> OccName -> [GlobalRdrElt]
lookupGlobalRdrEnv GlobalRdrEnv
rdr_env OccName
occ)
        in case [GlobalRdrElt]
gres of
             [gre :: GlobalRdrElt
gre]
               |  RealSrcSpan bind_loc :: RealSrcSpan
bind_loc <- GlobalRdrElt -> SrcSpan
greSrcSpan GlobalRdrElt
gre
                  -- Find splice between the unbound variable and the match; use
                  -- lookupLE, not lookupLT, since match could be in the splice
               ,  Just th_loc :: RealSrcSpan
th_loc <- RealSrcSpan -> Set RealSrcSpan -> Maybe RealSrcSpan
forall a. Ord a => a -> Set a -> Maybe a
Set.lookupLE RealSrcSpan
bind_loc Set RealSrcSpan
splice_locs
               ,  RealSrcSpan
err_loc RealSrcSpan -> RealSrcSpan -> Bool
forall a. Ord a => a -> a -> Bool
< RealSrcSpan
th_loc
               -> [RealSrcSpan -> RealSrcSpan -> SDoc
mk_bind_scope_msg RealSrcSpan
bind_loc RealSrcSpan
th_loc]
             _ -> []

    mk_bind_scope_msg :: RealSrcSpan -> RealSrcSpan -> SDoc
mk_bind_scope_msg bind_loc :: RealSrcSpan
bind_loc th_loc :: RealSrcSpan
th_loc
      | Bool
is_th_bind
      = SDoc -> Int -> SDoc -> SDoc
hang (SDoc -> SDoc
quotes (OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
occ) SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (String -> SDoc
text "splice on" SDoc -> SDoc -> SDoc
<+> SDoc
th_rng))
           2 (String -> SDoc
text "is not in scope before line" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
th_start_ln)
      | Bool
otherwise
      = SDoc -> Int -> SDoc -> SDoc
hang (SDoc -> SDoc
quotes (OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
occ) SDoc -> SDoc -> SDoc
<+> SDoc
bind_rng SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is not in scope")
           2 (String -> SDoc
text "before the splice on" SDoc -> SDoc -> SDoc
<+> SDoc
th_rng)
      where
        bind_rng :: SDoc
bind_rng = SDoc -> SDoc
parens (String -> SDoc
text "line" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
bind_ln)
        th_rng :: SDoc
th_rng
          | Int
th_start_ln Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
th_end_ln = SDoc
single
          | Bool
otherwise                = SDoc
multi
        single :: SDoc
single = String -> SDoc
text "line"  SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
th_start_ln
        multi :: SDoc
multi  = String -> SDoc
text "lines" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
th_start_ln SDoc -> SDoc -> SDoc
<> String -> SDoc
text "-" SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
th_end_ln
        bind_ln :: Int
bind_ln     = RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
bind_loc
        th_start_ln :: Int
th_start_ln = RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
th_loc
        th_end_ln :: Int
th_end_ln   = RealSrcSpan -> Int
srcSpanEndLine   RealSrcSpan
th_loc
        is_th_bind :: Bool
is_th_bind = RealSrcSpan
th_loc RealSrcSpan -> RealSrcSpan -> Bool
`containsSpan` RealSrcSpan
bind_loc

mkHoleError tidy_simples :: [Ct]
tidy_simples ctxt :: ReportErrCtxt
ctxt ct :: Ct
ct@(CHoleCan { cc_hole :: Ct -> Hole
cc_hole = Hole
hole })
  -- Explicit holes, like "_" or "_f"
  = do { (ctxt :: ReportErrCtxt
ctxt, binds_msg :: SDoc
binds_msg, ct :: Ct
ct) <- Bool -> ReportErrCtxt -> Ct -> TcM (ReportErrCtxt, SDoc, Ct)
relevantBindings Bool
False ReportErrCtxt
ctxt Ct
ct
               -- The 'False' means "don't filter the bindings"; see Trac #8191

       ; Bool
show_hole_constraints <- GeneralFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_ShowHoleConstraints
       ; let constraints_msg :: SDoc
constraints_msg
               | Ct -> Bool
isExprHoleCt Ct
ct, Bool
show_hole_constraints
                  = ReportErrCtxt -> SDoc
givenConstraintsMsg ReportErrCtxt
ctxt
               | Bool
otherwise = SDoc
empty

       ; Bool
show_valid_hole_fits <- GeneralFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_ShowValidHoleFits
       ; (ctxt :: ReportErrCtxt
ctxt, sub_msg :: SDoc
sub_msg) <- if Bool
show_valid_hole_fits
                            then ReportErrCtxt -> [Ct] -> Ct -> TcM (ReportErrCtxt, SDoc)
validHoleFits ReportErrCtxt
ctxt [Ct]
tidy_simples Ct
ct
                            else (ReportErrCtxt, SDoc) -> TcM (ReportErrCtxt, SDoc)
forall (m :: * -> *) a. Monad m => a -> m a
return (ReportErrCtxt
ctxt, SDoc
empty)
       ; ReportErrCtxt -> Ct -> Report -> TcM ErrMsg
mkErrorMsgFromCt ReportErrCtxt
ctxt Ct
ct (Report -> TcM ErrMsg) -> Report -> TcM ErrMsg
forall a b. (a -> b) -> a -> b
$
            SDoc -> Report
important SDoc
hole_msg Report -> Report -> Report
forall a. Monoid a => a -> a -> a
`mappend`
            SDoc -> Report
relevant_bindings (SDoc
binds_msg SDoc -> SDoc -> SDoc
$$ SDoc
constraints_msg) Report -> Report -> Report
forall a. Monoid a => a -> a -> a
`mappend`
            SDoc -> Report
valid_hole_fits SDoc
sub_msg}

  where
    occ :: OccName
occ       = Hole -> OccName
holeOcc Hole
hole
    hole_ty :: Type
hole_ty   = CtEvidence -> Type
ctEvPred (Ct -> CtEvidence
ctEvidence Ct
ct)
    hole_kind :: Type
hole_kind = HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind Type
hole_ty
    tyvars :: [TyCoVar]
tyvars    = Type -> [TyCoVar]
tyCoVarsOfTypeList Type
hole_ty

    hole_msg :: SDoc
hole_msg = case Hole
hole of
      ExprHole {} -> [SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Found hole:")
                               2 (OccName -> Type -> SDoc
pp_with_type OccName
occ Type
hole_ty)
                          , SDoc
tyvars_msg, SDoc
expr_hole_hint ]
      TypeHole {} -> [SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Found type wildcard" SDoc -> SDoc -> SDoc
<+>
                                  SDoc -> SDoc
quotes (OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
occ))
                               2 (String -> SDoc
text "standing for" SDoc -> SDoc -> SDoc
<+>
                                  SDoc -> SDoc
quotes SDoc
pp_hole_type_with_kind)
                          , SDoc
tyvars_msg, SDoc
type_hole_hint ]

    pp_hole_type_with_kind :: SDoc
pp_hole_type_with_kind
      | Type -> Bool
isLiftedTypeKind Type
hole_kind
        Bool -> Bool -> Bool
|| Type -> Bool
isCoVarType Type
hole_ty -- Don't print the kind of unlifted
                               -- equalities (#15039)
      = Type -> SDoc
pprType Type
hole_ty
      | Bool
otherwise
      = Type -> SDoc
pprType Type
hole_ty SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprKind Type
hole_kind

    tyvars_msg :: SDoc
tyvars_msg = Bool -> SDoc -> SDoc
ppUnless ([TyCoVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyCoVar]
tyvars) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                 String -> SDoc
text "Where:" SDoc -> SDoc -> SDoc
<+> ([SDoc] -> SDoc
vcat ((TyCoVar -> SDoc) -> [TyCoVar] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map TyCoVar -> SDoc
loc_msg [TyCoVar]
other_tvs)
                                    SDoc -> SDoc -> SDoc
$$ ReportErrCtxt -> [TyCoVar] -> SDoc
pprSkols ReportErrCtxt
ctxt [TyCoVar]
skol_tvs)
       where
         (skol_tvs :: [TyCoVar]
skol_tvs, other_tvs :: [TyCoVar]
other_tvs) = (TyCoVar -> Bool) -> [TyCoVar] -> ([TyCoVar], [TyCoVar])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition TyCoVar -> Bool
is_skol [TyCoVar]
tyvars
         is_skol :: TyCoVar -> Bool
is_skol tv :: TyCoVar
tv = TyCoVar -> Bool
isTcTyVar TyCoVar
tv Bool -> Bool -> Bool
&& TyCoVar -> Bool
isSkolemTyVar TyCoVar
tv
                      -- Coercion variables can be free in the
                      -- hole, via kind casts

    type_hole_hint :: SDoc
type_hole_hint
         | HoleChoice
HoleError <- ReportErrCtxt -> HoleChoice
cec_type_holes ReportErrCtxt
ctxt
         = String -> SDoc
text "To use the inferred type, enable PartialTypeSignatures"
         | Bool
otherwise
         = SDoc
empty

    expr_hole_hint :: SDoc
expr_hole_hint                       -- Give hint for, say,   f x = _x
         | FastString -> Int
lengthFS (OccName -> FastString
occNameFS OccName
occ) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 1  -- Don't give this hint for plain "_"
         = String -> SDoc
text "Or perhaps" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
occ)
           SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is mis-spelled, or not in scope"
         | Bool
otherwise
         = SDoc
empty

    loc_msg :: TyCoVar -> SDoc
loc_msg tv :: TyCoVar
tv
       | TyCoVar -> Bool
isTyVar TyCoVar
tv
       = case TyCoVar -> TcTyVarDetails
tcTyVarDetails TyCoVar
tv of
           MetaTv {} -> SDoc -> SDoc
quotes (TyCoVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCoVar
tv) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is an ambiguous type variable"
           _         -> SDoc
empty  -- Skolems dealt with already
       | Bool
otherwise  -- A coercion variable can be free in the hole type
       = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \dflags :: DynFlags
dflags ->
         if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_PrintExplicitCoercions DynFlags
dflags
         then SDoc -> SDoc
quotes (TyCoVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCoVar
tv) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is a coercion variable"
         else SDoc
empty

mkHoleError _ _ ct :: Ct
ct = String -> SDoc -> TcM ErrMsg
forall a. HasCallStack => String -> SDoc -> a
pprPanic "mkHoleError" (Ct -> SDoc
forall a. Outputable a => a -> SDoc
ppr Ct
ct)

-- We unwrap the ReportErrCtxt here, to avoid introducing a loop in module
-- imports
validHoleFits :: ReportErrCtxt -- The context we're in, i.e. the
                                        -- implications and the tidy environment
                       -> [Ct]          -- Unsolved simple constraints
                       -> Ct            -- The hole constraint.
                       -> TcM (ReportErrCtxt, SDoc) -- We return the new context
                                                    -- with a possibly updated
                                                    -- tidy environment, and
                                                    -- the message.
validHoleFits :: ReportErrCtxt -> [Ct] -> Ct -> TcM (ReportErrCtxt, SDoc)
validHoleFits ctxt :: ReportErrCtxt
ctxt@(CEC {cec_encl :: ReportErrCtxt -> [Implication]
cec_encl = [Implication]
implics
                             , cec_tidy :: ReportErrCtxt -> TidyEnv
cec_tidy = TidyEnv
lcl_env}) simps :: [Ct]
simps ct :: Ct
ct
  = do { (tidy_env :: TidyEnv
tidy_env, msg :: SDoc
msg) <- TidyEnv -> [Implication] -> [Ct] -> Ct -> TcM (TidyEnv, SDoc)
findValidHoleFits TidyEnv
lcl_env [Implication]
implics [Ct]
simps Ct
ct
       ; (ReportErrCtxt, SDoc) -> TcM (ReportErrCtxt, SDoc)
forall (m :: * -> *) a. Monad m => a -> m a
return (ReportErrCtxt
ctxt {cec_tidy :: TidyEnv
cec_tidy = TidyEnv
tidy_env}, SDoc
msg) }

-- See Note [Constraints include ...]
givenConstraintsMsg :: ReportErrCtxt -> SDoc
givenConstraintsMsg :: ReportErrCtxt -> SDoc
givenConstraintsMsg ctxt :: ReportErrCtxt
ctxt =
    let constraints :: [(Type, RealSrcSpan)]
        constraints :: [(Type, RealSrcSpan)]
constraints =
          do { implic :: Implication
implic@Implic{ ic_given :: Implication -> [TyCoVar]
ic_given = [TyCoVar]
given } <- ReportErrCtxt -> [Implication]
cec_encl ReportErrCtxt
ctxt
             ; TyCoVar
constraint <- [TyCoVar]
given
             ; (Type, RealSrcSpan) -> [(Type, RealSrcSpan)]
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCoVar -> Type
varType TyCoVar
constraint, TcLclEnv -> RealSrcSpan
tcl_loc (Implication -> TcLclEnv
implicLclEnv Implication
implic)) }

        pprConstraint :: (a, a) -> SDoc
pprConstraint (constraint :: a
constraint, loc :: a
loc) =
          a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
constraint SDoc -> SDoc -> SDoc
<+> Int -> SDoc -> SDoc
nest 2 (SDoc -> SDoc
parens (String -> SDoc
text "from" SDoc -> SDoc -> SDoc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
loc))

    in Bool -> SDoc -> SDoc
ppUnless ([(Type, RealSrcSpan)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Type, RealSrcSpan)]
constraints) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
         SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Constraints include")
            2 ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ ((Type, RealSrcSpan) -> SDoc) -> [(Type, RealSrcSpan)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Type, RealSrcSpan) -> SDoc
forall a a. (Outputable a, Outputable a) => (a, a) -> SDoc
pprConstraint [(Type, RealSrcSpan)]
constraints)

pp_with_type :: OccName -> Type -> SDoc
pp_with_type :: OccName -> Type -> SDoc
pp_with_type occ :: OccName
occ ty :: Type
ty = SDoc -> Int -> SDoc -> SDoc
hang (OccName -> SDoc
forall a. OutputableBndr a => a -> SDoc
pprPrefixOcc OccName
occ) 2 (SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprType Type
ty)

----------------
mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkIPErr ctxt :: ReportErrCtxt
ctxt cts :: [Ct]
cts
  = do { (ctxt :: ReportErrCtxt
ctxt, binds_msg :: SDoc
binds_msg, ct1 :: Ct
ct1) <- Bool -> ReportErrCtxt -> Ct -> TcM (ReportErrCtxt, SDoc, Ct)
relevantBindings Bool
True ReportErrCtxt
ctxt Ct
ct1
       ; let orig :: CtOrigin
orig    = Ct -> CtOrigin
ctOrigin Ct
ct1
             preds :: [Type]
preds   = (Ct -> Type) -> [Ct] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Ct -> Type
ctPred [Ct]
cts
             givens :: [Implication]
givens  = ReportErrCtxt -> [Implication]
getUserGivens ReportErrCtxt
ctxt
             msg :: SDoc
msg | [Implication] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Implication]
givens
                 = CtOrigin -> SDoc -> SDoc
addArising CtOrigin
orig (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                   [SDoc] -> SDoc
sep [ String -> SDoc
text "Unbound implicit parameter" SDoc -> SDoc -> SDoc
<> [Ct] -> SDoc
forall a. [a] -> SDoc
plural [Ct]
cts
                       , Int -> SDoc -> SDoc
nest 2 ([Type] -> SDoc
pprParendTheta [Type]
preds) ]
                 | Bool
otherwise
                 = [Implication] -> ([Type], CtOrigin) -> SDoc
couldNotDeduce [Implication]
givens ([Type]
preds, CtOrigin
orig)

       ; ReportErrCtxt -> Ct -> Report -> TcM ErrMsg
mkErrorMsgFromCt ReportErrCtxt
ctxt Ct
ct1 (Report -> TcM ErrMsg) -> Report -> TcM ErrMsg
forall a b. (a -> b) -> a -> b
$
            SDoc -> Report
important SDoc
msg Report -> Report -> Report
forall a. Monoid a => a -> a -> a
`mappend` SDoc -> Report
relevant_bindings SDoc
binds_msg }
  where
    (ct1 :: Ct
ct1:_) = [Ct]
cts

{-

Note [Constraints include ...]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'givenConstraintsMsg' returns the "Constraints include ..." message enabled by
-fshow-hole-constraints. For example, the following hole:

    foo :: (Eq a, Show a) => a -> String
    foo x = _

would generate the message:

    Constraints include
      Eq a (from foo.hs:1:1-36)
      Show a (from foo.hs:1:1-36)

Constraints are displayed in order from innermost (closest to the hole) to
outermost. There's currently no filtering or elimination of duplicates.


Note [OutOfScope exact matches]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When constructing an out-of-scope error message, we not only generate a list of
possible in-scope alternatives but also search for an exact, unambiguous match
in a later inter-splice group.  If we find such a match, we report its presence
(and indirectly, its scope) in the message.  For example, if a module A contains
the following declarations,

   foo :: Int
   foo = x

   $(return [])  -- Empty top-level splice

   x :: Int
   x = 23

we will issue an error similar to

   A.hs:6:7: error:
       • Variable not in scope: x :: Int
       • ‘x’ (line 11) is not in scope before the splice on line 8

By providing information about the match, we hope to clarify why declaring a
variable after a top-level splice but using it before the splice generates an
out-of-scope error (a situation which is often confusing to Haskell newcomers).

Note that if we find multiple exact matches to the out-of-scope variable
(hereafter referred to as x), we report nothing.  Such matches can only be
duplicate record fields, as the presence of any other duplicate top-level
declarations would have already halted compilation.  But if these record fields
are declared in a later inter-splice group, then so too are their corresponding
types.  Thus, these types must not occur in the inter-splice group containing x
(any unknown types would have already been reported), and so the matches to the
record fields are most likely coincidental.

One oddity of the exact match portion of the error message is that we specify
where the match to x is NOT in scope.  Why not simply state where the match IS
in scope?  It most cases, this would be just as easy and perhaps a little
clearer for the user.  But now consider the following example:

    {-# LANGUAGE TemplateHaskell #-}

    module A where

    import Language.Haskell.TH
    import Language.Haskell.TH.Syntax

    foo = x

    $(do -------------------------------------------------
        ds <- [d| ok1 = x
                |]
        addTopDecls ds
        return [])

    bar = $(do
            ds <- [d| x = 23
                      ok2 = x
                    |]
            addTopDecls ds
            litE $ stringL "hello")

    $(return []) -----------------------------------------

    ok3 = x

Here, x is out-of-scope in the declaration of foo, and so we report

    A.hs:8:7: error:
        • Variable not in scope: x
        • ‘x’ (line 16) is not in scope before the splice on lines 10-14

If we instead reported where x IS in scope, we would have to state that it is in
scope after the second top-level splice as well as among all the top-level
declarations added by both calls to addTopDecls.  But doing so would not only
add complexity to the code but also overwhelm the user with unneeded
information.

The logic which determines where x is not in scope is straightforward: it simply
finds the last top-level splice which occurs after x but before (or at) the
match to x (assuming such a splice exists).  In most cases, the check that the
splice occurs after x acts only as a sanity check.  For example, when the match
to x is a non-TH top-level declaration and a splice S occurs before the match,
then x must precede S; otherwise, it would be in scope.  But when dealing with
addTopDecls, this check serves a practical purpose.  Consider the following
declarations:

    $(do
        ds <- [d| ok = x
                  x = 23
                |]
        addTopDecls ds
        return [])

    foo = x

In this case, x is not in scope in the declaration for foo.  Since x occurs
AFTER the splice containing the match, the logic does not find any splices after
x but before or at its match, and so we report nothing about x's scope.  If we
had not checked whether x occurs before the splice, we would have instead
reported that x is not in scope before the splice.  While correct, such an error
message is more likely to confuse than to enlighten.
-}

{-
************************************************************************
*                                                                      *
                Equality errors
*                                                                      *
************************************************************************

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.

Note [Error messages for untouchables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider (Trac #9109)
  data G a where { GBool :: G Bool }
  foo x = case x of GBool -> True

Here we can't solve (t ~ Bool), where t is the untouchable result
meta-var 't', because of the (a ~ Bool) from the pattern match.
So we infer the type
   f :: forall a t. G a -> t
making the meta-var 't' into a skolem.  So when we come to report
the unsolved (t ~ Bool), t won't look like an untouchable meta-var
any more.  So we don't assert that it is.
-}

-- Don't have multiple equality errors from the same location
-- E.g.   (Int,Bool) ~ (Bool,Int)   one error will do!
mkEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkEqErr ctxt :: ReportErrCtxt
ctxt (ct :: Ct
ct:_) = ReportErrCtxt -> Ct -> TcM ErrMsg
mkEqErr1 ReportErrCtxt
ctxt Ct
ct
mkEqErr _ [] = String -> TcM ErrMsg
forall a. String -> a
panic "mkEqErr"

mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg
mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg
mkEqErr1 ctxt :: ReportErrCtxt
ctxt ct :: Ct
ct   -- Wanted or derived;
                   -- givens handled in mkGivenErrorReporter
  = do { (ctxt :: ReportErrCtxt
ctxt, binds_msg :: SDoc
binds_msg, ct :: Ct
ct) <- Bool -> ReportErrCtxt -> Ct -> TcM (ReportErrCtxt, SDoc, Ct)
relevantBindings Bool
True ReportErrCtxt
ctxt Ct
ct
       ; GlobalRdrEnv
rdr_env <- TcRn GlobalRdrEnv
getGlobalRdrEnv
       ; FamInstEnvs
fam_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
       ; Bool
exp_syns <- GeneralFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_PrintExpandedSynonyms
       ; let (keep_going :: Bool
keep_going, is_oriented :: Maybe SwapFlag
is_oriented, wanted_msg :: SDoc
wanted_msg)
                           = CtLoc -> Bool -> (Bool, Maybe SwapFlag, SDoc)
mk_wanted_extra (Ct -> CtLoc
ctLoc Ct
ct) Bool
exp_syns
             coercible_msg :: SDoc
coercible_msg = case Ct -> EqRel
ctEqRel Ct
ct of
               NomEq  -> SDoc
empty
               ReprEq -> GlobalRdrEnv -> FamInstEnvs -> Type -> Type -> SDoc
mkCoercibleExplanation GlobalRdrEnv
rdr_env FamInstEnvs
fam_envs Type
ty1 Type
ty2
       ; DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; String -> SDoc -> TcM ()
traceTc "mkEqErr1" (Ct -> SDoc
forall a. Outputable a => a -> SDoc
ppr Ct
ct SDoc -> SDoc -> SDoc
$$ CtOrigin -> SDoc
pprCtOrigin (Ct -> CtOrigin
ctOrigin Ct
ct) SDoc -> SDoc -> SDoc
$$ Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
keep_going)
       ; let report :: Report
report = [Report] -> Report
forall a. Monoid a => [a] -> a
mconcat [SDoc -> Report
important SDoc
wanted_msg, SDoc -> Report
important SDoc
coercible_msg,
                               SDoc -> Report
relevant_bindings SDoc
binds_msg]
       ; if Bool
keep_going
         then DynFlags
-> ReportErrCtxt
-> Report
-> Ct
-> Maybe SwapFlag
-> Type
-> Type
-> TcM ErrMsg
mkEqErr_help DynFlags
dflags ReportErrCtxt
ctxt Report
report Ct
ct Maybe SwapFlag
is_oriented Type
ty1 Type
ty2
         else ReportErrCtxt -> Ct -> Report -> TcM ErrMsg
mkErrorMsgFromCt ReportErrCtxt
ctxt Ct
ct Report
report }
  where
    (ty1 :: Type
ty1, ty2 :: Type
ty2) = Type -> (Type, Type)
getEqPredTys (Ct -> Type
ctPred Ct
ct)

       -- If the types in the error message are the same as the types
       -- we are unifying, don't add the extra expected/actual message
    mk_wanted_extra :: CtLoc -> Bool -> (Bool, Maybe SwapFlag, SDoc)
    mk_wanted_extra :: CtLoc -> Bool -> (Bool, Maybe SwapFlag, SDoc)
mk_wanted_extra loc :: CtLoc
loc expandSyns :: Bool
expandSyns
      = case CtLoc -> CtOrigin
ctLocOrigin CtLoc
loc of
          orig :: CtOrigin
orig@TypeEqOrigin {} -> Type
-> Type
-> CtOrigin
-> Maybe TypeOrKind
-> Bool
-> (Bool, Maybe SwapFlag, SDoc)
mkExpectedActualMsg Type
ty1 Type
ty2 CtOrigin
orig
                                                      Maybe TypeOrKind
t_or_k Bool
expandSyns
            where
              t_or_k :: Maybe TypeOrKind
t_or_k = CtLoc -> Maybe TypeOrKind
ctLocTypeOrKind_maybe CtLoc
loc

          KindEqOrigin cty1 :: Type
cty1 mb_cty2 :: Maybe Type
mb_cty2 sub_o :: CtOrigin
sub_o sub_t_or_k :: Maybe TypeOrKind
sub_t_or_k
            -> (Bool
True, Maybe SwapFlag
forall a. Maybe a
Nothing, SDoc
msg1 SDoc -> SDoc -> SDoc
$$ SDoc
msg2)
            where
              sub_what :: SDoc
sub_what = case Maybe TypeOrKind
sub_t_or_k of Just KindLevel -> String -> SDoc
text "kinds"
                                            _              -> String -> SDoc
text "types"
              msg1 :: SDoc
msg1 = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \dflags :: DynFlags
dflags ->
                     case Maybe Type
mb_cty2 of
                       Just cty2 :: Type
cty2
                         |  GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_PrintExplicitCoercions DynFlags
dflags
                         Bool -> Bool -> Bool
|| Bool -> Bool
not (Type
cty1 Type -> Type -> Bool
`pickyEqType` Type
cty2)
                         -> SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "When matching" SDoc -> SDoc -> SDoc
<+> SDoc
sub_what)
                               2 ([SDoc] -> SDoc
vcat [ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
cty1 SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+>
                                         Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind Type
cty1)
                                       , Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
cty2 SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+>
                                         Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind Type
cty2) ])
                       _ -> String -> SDoc
text "When matching the kind of" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
cty1)
              msg2 :: SDoc
msg2 = case CtOrigin
sub_o of
                       TypeEqOrigin {}
                         | Just cty2 :: Type
cty2 <- Maybe Type
mb_cty2 ->
                         (Bool, Maybe SwapFlag, SDoc) -> SDoc
forall a b c. (a, b, c) -> c
thdOf3 (Type
-> Type
-> CtOrigin
-> Maybe TypeOrKind
-> Bool
-> (Bool, Maybe SwapFlag, SDoc)
mkExpectedActualMsg Type
cty1 Type
cty2 CtOrigin
sub_o Maybe TypeOrKind
sub_t_or_k
                                                     Bool
expandSyns)
                       _ -> SDoc
empty
          _ -> (Bool
True, Maybe SwapFlag
forall a. Maybe a
Nothing, SDoc
empty)

-- | This function tries to reconstruct why a "Coercible ty1 ty2" constraint
-- is left over.
mkCoercibleExplanation :: GlobalRdrEnv -> FamInstEnvs
                       -> TcType -> TcType -> SDoc
mkCoercibleExplanation :: GlobalRdrEnv -> FamInstEnvs -> Type -> Type -> SDoc
mkCoercibleExplanation rdr_env :: GlobalRdrEnv
rdr_env fam_envs :: FamInstEnvs
fam_envs ty1 :: Type
ty1 ty2 :: Type
ty2
  | Just (tc :: TyCon
tc, tys :: [Type]
tys) <- HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty1
  , (rep_tc :: TyCon
rep_tc, _, _) <- FamInstEnvs -> TyCon -> [Type] -> (TyCon, [Type], Coercion)
tcLookupDataFamInst FamInstEnvs
fam_envs TyCon
tc [Type]
tys
  , Just msg :: SDoc
msg <- TyCon -> Maybe SDoc
coercible_msg_for_tycon TyCon
rep_tc
  = SDoc
msg
  | Just (tc :: TyCon
tc, tys :: [Type]
tys) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty2
  , (rep_tc :: TyCon
rep_tc, _, _) <- FamInstEnvs -> TyCon -> [Type] -> (TyCon, [Type], Coercion)
tcLookupDataFamInst FamInstEnvs
fam_envs TyCon
tc [Type]
tys
  , Just msg :: SDoc
msg <- TyCon -> Maybe SDoc
coercible_msg_for_tycon TyCon
rep_tc
  = SDoc
msg
  | Just (s1 :: Type
s1, _) <- Type -> Maybe (Type, Type)
tcSplitAppTy_maybe Type
ty1
  , Just (s2 :: Type
s2, _) <- Type -> Maybe (Type, Type)
tcSplitAppTy_maybe Type
ty2
  , Type
s1 Type -> Type -> Bool
`eqType` Type
s2
  , Type -> Bool
has_unknown_roles Type
s1
  = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "NB: We cannot know what roles the parameters to" SDoc -> SDoc -> SDoc
<+>
          SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
s1) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "have;")
       2 (String -> SDoc
text "we must assume that the role is nominal")
  | Bool
otherwise
  = SDoc
empty
  where
    coercible_msg_for_tycon :: TyCon -> Maybe SDoc
coercible_msg_for_tycon tc :: TyCon
tc
        | TyCon -> Bool
isAbstractTyCon TyCon
tc
        = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
hsep [ String -> SDoc
text "NB: The type constructor"
                      , SDoc -> SDoc
quotes (TyCon -> SDoc
pprSourceTyCon TyCon
tc)
                      , String -> SDoc
text "is abstract" ]
        | TyCon -> Bool
isNewTyCon TyCon
tc
        , [data_con :: DataCon
data_con] <- TyCon -> [DataCon]
tyConDataCons TyCon
tc
        , let dc_name :: Name
dc_name = DataCon -> Name
dataConName DataCon
data_con
        , Maybe GlobalRdrElt -> Bool
forall a. Maybe a -> Bool
isNothing (GlobalRdrEnv -> Name -> Maybe GlobalRdrElt
lookupGRE_Name GlobalRdrEnv
rdr_env Name
dc_name)
        = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "The data constructor" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
dc_name))
                    2 ([SDoc] -> SDoc
sep [ String -> SDoc
text "of newtype" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyCon -> SDoc
pprSourceTyCon TyCon
tc)
                           , String -> SDoc
text "is not in scope" ])
        | Bool
otherwise = Maybe SDoc
forall a. Maybe a
Nothing

    has_unknown_roles :: Type -> Bool
has_unknown_roles ty :: Type
ty
      | Just (tc :: TyCon
tc, tys :: [Type]
tys) <- HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty
      = [Type]
tys [Type] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthAtLeast` TyCon -> Int
tyConArity TyCon
tc  -- oversaturated tycon
      | Just (s :: Type
s, _) <- Type -> Maybe (Type, Type)
tcSplitAppTy_maybe Type
ty
      = Type -> Bool
has_unknown_roles Type
s
      | Type -> Bool
isTyVarTy Type
ty
      = Bool
True
      | Bool
otherwise
      = Bool
False

{-
-- | Make a listing of role signatures for all the parameterised tycons
-- used in the provided types


-- SLPJ Jun 15: I could not convince myself that these hints were really
-- useful.  Maybe they are, but I think we need more work to make them
-- actually helpful.
mkRoleSigs :: Type -> Type -> SDoc
mkRoleSigs ty1 ty2
  = ppUnless (null role_sigs) $
    hang (text "Relevant role signatures:")
       2 (vcat role_sigs)
  where
    tcs = nameEnvElts $ tyConsOfType ty1 `plusNameEnv` tyConsOfType ty2
    role_sigs = mapMaybe ppr_role_sig tcs

    ppr_role_sig tc
      | null roles  -- if there are no parameters, don't bother printing
      = Nothing
      | isBuiltInSyntax (tyConName tc)  -- don't print roles for (->), etc.
      = Nothing
      | otherwise
      = Just $ hsep $ [text "type role", ppr tc] ++ map ppr roles
      where
        roles = tyConRoles tc
-}

mkEqErr_help :: DynFlags -> ReportErrCtxt -> Report
             -> Ct
             -> Maybe SwapFlag   -- Nothing <=> not sure
             -> TcType -> TcType -> TcM ErrMsg
mkEqErr_help :: DynFlags
-> ReportErrCtxt
-> Report
-> Ct
-> Maybe SwapFlag
-> Type
-> Type
-> TcM ErrMsg
mkEqErr_help dflags :: DynFlags
dflags ctxt :: ReportErrCtxt
ctxt report :: Report
report ct :: Ct
ct oriented :: Maybe SwapFlag
oriented ty1 :: Type
ty1 ty2 :: Type
ty2
  | Just (tv1 :: TyCoVar
tv1, co1 :: Coercion
co1) <- Type -> Maybe (TyCoVar, Coercion)
tcGetCastedTyVar_maybe Type
ty1
  = DynFlags
-> ReportErrCtxt
-> Report
-> Ct
-> Maybe SwapFlag
-> TyCoVar
-> Coercion
-> Type
-> TcM ErrMsg
mkTyVarEqErr DynFlags
dflags ReportErrCtxt
ctxt Report
report Ct
ct Maybe SwapFlag
oriented TyCoVar
tv1 Coercion
co1 Type
ty2
  | Just (tv2 :: TyCoVar
tv2, co2 :: Coercion
co2) <- Type -> Maybe (TyCoVar, Coercion)
tcGetCastedTyVar_maybe Type
ty2
  = DynFlags
-> ReportErrCtxt
-> Report
-> Ct
-> Maybe SwapFlag
-> TyCoVar
-> Coercion
-> Type
-> TcM ErrMsg
mkTyVarEqErr DynFlags
dflags ReportErrCtxt
ctxt Report
report Ct
ct Maybe SwapFlag
swapped  TyCoVar
tv2 Coercion
co2 Type
ty1
  | Bool
otherwise
  = ReportErrCtxt
-> Report -> Ct -> Maybe SwapFlag -> Type -> Type -> TcM ErrMsg
reportEqErr ReportErrCtxt
ctxt Report
report Ct
ct Maybe SwapFlag
oriented Type
ty1 Type
ty2
  where
    swapped :: Maybe SwapFlag
swapped = (SwapFlag -> SwapFlag) -> Maybe SwapFlag -> Maybe SwapFlag
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SwapFlag -> SwapFlag
flipSwap Maybe SwapFlag
oriented

reportEqErr :: ReportErrCtxt -> Report
            -> Ct
            -> Maybe SwapFlag   -- Nothing <=> not sure
            -> TcType -> TcType -> TcM ErrMsg
reportEqErr :: ReportErrCtxt
-> Report -> Ct -> Maybe SwapFlag -> Type -> Type -> TcM ErrMsg
reportEqErr ctxt :: ReportErrCtxt
ctxt report :: Report
report ct :: Ct
ct oriented :: Maybe SwapFlag
oriented ty1 :: Type
ty1 ty2 :: Type
ty2
  = ReportErrCtxt -> Ct -> Report -> TcM ErrMsg
mkErrorMsgFromCt ReportErrCtxt
ctxt Ct
ct ([Report] -> Report
forall a. Monoid a => [a] -> a
mconcat [Report
misMatch, Report
report, Report
eqInfo])
  where misMatch :: Report
misMatch = SDoc -> Report
important (SDoc -> Report) -> SDoc -> Report
forall a b. (a -> b) -> a -> b
$ ReportErrCtxt -> Ct -> Maybe SwapFlag -> Type -> Type -> SDoc
misMatchOrCND ReportErrCtxt
ctxt Ct
ct Maybe SwapFlag
oriented Type
ty1 Type
ty2
        eqInfo :: Report
eqInfo = SDoc -> Report
important (SDoc -> Report) -> SDoc -> Report
forall a b. (a -> b) -> a -> b
$ Ct -> Type -> Type -> SDoc
mkEqInfoMsg Ct
ct Type
ty1 Type
ty2

mkTyVarEqErr, mkTyVarEqErr'
  :: DynFlags -> ReportErrCtxt -> Report -> Ct
             -> Maybe SwapFlag -> TcTyVar -> TcCoercionN -> TcType -> TcM ErrMsg
-- tv1 and ty2 are already tidied
mkTyVarEqErr :: DynFlags
-> ReportErrCtxt
-> Report
-> Ct
-> Maybe SwapFlag
-> TyCoVar
-> Coercion
-> Type
-> TcM ErrMsg
mkTyVarEqErr dflags :: DynFlags
dflags ctxt :: ReportErrCtxt
ctxt report :: Report
report ct :: Ct
ct oriented :: Maybe SwapFlag
oriented tv1 :: TyCoVar
tv1 co1 :: Coercion
co1 ty2 :: Type
ty2
  = do { String -> SDoc -> TcM ()
traceTc "mkTyVarEqErr" (Ct -> SDoc
forall a. Outputable a => a -> SDoc
ppr Ct
ct SDoc -> SDoc -> SDoc
$$ TyCoVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCoVar
tv1 SDoc -> SDoc -> SDoc
$$ Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co1 SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty2)
       ; DynFlags
-> ReportErrCtxt
-> Report
-> Ct
-> Maybe SwapFlag
-> TyCoVar
-> Coercion
-> Type
-> TcM ErrMsg
mkTyVarEqErr' DynFlags
dflags ReportErrCtxt
ctxt Report
report Ct
ct Maybe SwapFlag
oriented TyCoVar
tv1 Coercion
co1 Type
ty2 }

mkTyVarEqErr' :: DynFlags
-> ReportErrCtxt
-> Report
-> Ct
-> Maybe SwapFlag
-> TyCoVar
-> Coercion
-> Type
-> TcM ErrMsg
mkTyVarEqErr' dflags :: DynFlags
dflags ctxt :: ReportErrCtxt
ctxt report :: Report
report ct :: Ct
ct oriented :: Maybe SwapFlag
oriented tv1 :: TyCoVar
tv1 co1 :: Coercion
co1 ty2 :: Type
ty2
  | Bool -> Bool
not Bool
insoluble_occurs_check   -- See Note [Occurs check wins]
  , ReportErrCtxt -> TyCoVar -> Bool
isUserSkolem ReportErrCtxt
ctxt TyCoVar
tv1   -- ty2 won't be a meta-tyvar, or else the thing would
                            -- be oriented the other way round;
                            -- see TcCanonical.canEqTyVarTyVar
    Bool -> Bool -> Bool
|| TyCoVar -> Bool
isTyVarTyVar TyCoVar
tv1 Bool -> Bool -> Bool
&& Bool -> Bool
not (Type -> Bool
isTyVarTy Type
ty2)
    Bool -> Bool -> Bool
|| Ct -> EqRel
ctEqRel Ct
ct EqRel -> EqRel -> Bool
forall a. Eq a => a -> a -> Bool
== EqRel
ReprEq
     -- the cases below don't really apply to ReprEq (except occurs check)
  = ReportErrCtxt -> Ct -> Report -> TcM ErrMsg
mkErrorMsgFromCt ReportErrCtxt
ctxt Ct
ct (Report -> TcM ErrMsg) -> Report -> TcM ErrMsg
forall a b. (a -> b) -> a -> b
$ [Report] -> Report
forall a. Monoid a => [a] -> a
mconcat
        [ SDoc -> Report
important (SDoc -> Report) -> SDoc -> Report
forall a b. (a -> b) -> a -> b
$ ReportErrCtxt -> Ct -> Maybe SwapFlag -> Type -> Type -> SDoc
misMatchOrCND ReportErrCtxt
ctxt Ct
ct Maybe SwapFlag
oriented Type
ty1 Type
ty2
        , SDoc -> Report
important (SDoc -> Report) -> SDoc -> Report
forall a b. (a -> b) -> a -> b
$ ReportErrCtxt -> TyCoVar -> Type -> SDoc
extraTyVarEqInfo ReportErrCtxt
ctxt TyCoVar
tv1 Type
ty2
        , Report
report
        ]

  | OccCheckResult ()
OC_Occurs <- OccCheckResult ()
occ_check_expand
    -- We report an "occurs check" even for  a ~ F t a, where F is a type
    -- function; it's not insoluble (because in principle F could reduce)
    -- but we have certainly been unable to solve it
    -- See Note [Occurs check error] in TcCanonical
  = do { let main_msg :: SDoc
main_msg = CtOrigin -> SDoc -> SDoc
addArising (Ct -> CtOrigin
ctOrigin Ct
ct) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                        SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Occurs check: cannot construct the infinite" SDoc -> SDoc -> SDoc
<+> SDoc
what SDoc -> SDoc -> SDoc
<> SDoc
colon)
                              2 ([SDoc] -> SDoc
sep [Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty1, Char -> SDoc
char '~', Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty2])

             extra2 :: Report
extra2 = SDoc -> Report
important (SDoc -> Report) -> SDoc -> Report
forall a b. (a -> b) -> a -> b
$ Ct -> Type -> Type -> SDoc
mkEqInfoMsg Ct
ct Type
ty1 Type
ty2

             interesting_tyvars :: [TyCoVar]
interesting_tyvars = (TyCoVar -> Bool) -> [TyCoVar] -> [TyCoVar]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (TyCoVar -> Bool) -> TyCoVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Bool
noFreeVarsOfType (Type -> Bool) -> (TyCoVar -> Type) -> TyCoVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCoVar -> Type
tyVarKind) ([TyCoVar] -> [TyCoVar]) -> [TyCoVar] -> [TyCoVar]
forall a b. (a -> b) -> a -> b
$
                                  (TyCoVar -> Bool) -> [TyCoVar] -> [TyCoVar]
forall a. (a -> Bool) -> [a] -> [a]
filter TyCoVar -> Bool
isTyVar ([TyCoVar] -> [TyCoVar]) -> [TyCoVar] -> [TyCoVar]
forall a b. (a -> b) -> a -> b
$
                                  FV -> [TyCoVar]
fvVarList (FV -> [TyCoVar]) -> FV -> [TyCoVar]
forall a b. (a -> b) -> a -> b
$
                                  Type -> FV
tyCoFVsOfType Type
ty1 FV -> FV -> FV
`unionFV` Type -> FV
tyCoFVsOfType Type
ty2
             extra3 :: Report
extra3 = SDoc -> Report
relevant_bindings (SDoc -> Report) -> SDoc -> Report
forall a b. (a -> b) -> a -> b
$
                      Bool -> SDoc -> SDoc
ppWhen (Bool -> Bool
not ([TyCoVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyCoVar]
interesting_tyvars)) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                      SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Type variable kinds:") 2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                      [SDoc] -> SDoc
vcat ((TyCoVar -> SDoc) -> [TyCoVar] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (TyCoVar -> SDoc
tyvar_binding (TyCoVar -> SDoc) -> (TyCoVar -> TyCoVar) -> TyCoVar -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TidyEnv -> TyCoVar -> TyCoVar
tidyTyCoVarOcc (ReportErrCtxt -> TidyEnv
cec_tidy ReportErrCtxt
ctxt))
                                [TyCoVar]
interesting_tyvars)

             tyvar_binding :: TyCoVar -> SDoc
tyvar_binding tv :: TyCoVar
tv = TyCoVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCoVar
tv SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCoVar -> Type
tyVarKind TyCoVar
tv)
       ; ReportErrCtxt -> Ct -> Report -> TcM ErrMsg
mkErrorMsgFromCt ReportErrCtxt
ctxt Ct
ct (Report -> TcM ErrMsg) -> Report -> TcM ErrMsg
forall a b. (a -> b) -> a -> b
$
         [Report] -> Report
forall a. Monoid a => [a] -> a
mconcat [SDoc -> Report
important SDoc
main_msg, Report
extra2, Report
extra3, Report
report] }

  | OccCheckResult ()
OC_Bad <- OccCheckResult ()
occ_check_expand
  = do { let msg :: SDoc
msg = [SDoc] -> SDoc
vcat [ String -> SDoc
text "Cannot instantiate unification variable"
                          SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyCoVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCoVar
tv1)
                        , SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "with a" SDoc -> SDoc -> SDoc
<+> SDoc
what SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "involving foralls:") 2 (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty2)
                        , Int -> SDoc -> SDoc
nest 2 (String -> SDoc
text "GHC doesn't yet support impredicative polymorphism") ]
       -- Unlike the other reports, this discards the old 'report_important'
       -- instead of augmenting it.  This is because the details are not likely
       -- to be helpful since this is just an unimplemented feature.
       ; ReportErrCtxt -> Ct -> Report -> TcM ErrMsg
mkErrorMsgFromCt ReportErrCtxt
ctxt Ct
ct (Report -> TcM ErrMsg) -> Report -> TcM ErrMsg
forall a b. (a -> b) -> a -> b
$ Report
report { report_important :: [SDoc]
report_important = [SDoc
msg] } }

   -- check for heterogeneous equality next; see Note [Equalities with incompatible kinds]
   -- in TcCanonical
  | Bool -> Bool
not (Type
k1 HasDebugCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`tcEqType` Type
k2)
  = do { let main_msg :: SDoc
main_msg = CtOrigin -> SDoc -> SDoc
addArising (Ct -> CtOrigin
ctOrigin Ct
ct) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                        [SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Kind mismatch: cannot unify" SDoc -> SDoc -> SDoc
<+>
                                     SDoc -> SDoc
parens (TyCoVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCoVar
tv1 SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCoVar -> Type
tyVarKind TyCoVar
tv1)) SDoc -> SDoc -> SDoc
<+>
                                     String -> SDoc
text "with:")
                                  2 ([SDoc] -> SDoc
sep [Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty2, SDoc
dcolon, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
k2])
                             , String -> SDoc
text "Their kinds differ." ]
             cast_msg :: SDoc
cast_msg
               | Coercion -> Bool
isTcReflexiveCo Coercion
co1 = SDoc
empty
               | Bool
otherwise           = String -> SDoc
text "NB:" SDoc -> SDoc -> SDoc
<+> TyCoVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCoVar
tv1 SDoc -> SDoc -> SDoc
<+>
                                       String -> SDoc
text "was casted to have kind" SDoc -> SDoc -> SDoc
<+>
                                       SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
k1)

       ; ReportErrCtxt -> Ct -> Report -> TcM ErrMsg
mkErrorMsgFromCt ReportErrCtxt
ctxt Ct
ct ([Report] -> Report
forall a. Monoid a => [a] -> a
mconcat [SDoc -> Report
important SDoc
main_msg, SDoc -> Report
important SDoc
cast_msg, Report
report]) }

  -- If the immediately-enclosing implication has 'tv' a skolem, and
  -- we know by now its an InferSkol kind of skolem, then presumably
  -- it started life as a TyVarTv, else it'd have been unified, given
  -- that there's no occurs-check or forall problem
  | (implic :: Implication
implic:_) <- ReportErrCtxt -> [Implication]
cec_encl ReportErrCtxt
ctxt
  , Implic { ic_skols :: Implication -> [TyCoVar]
ic_skols = [TyCoVar]
skols } <- Implication
implic
  , TyCoVar
tv1 TyCoVar -> [TyCoVar] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TyCoVar]
skols
  = ReportErrCtxt -> Ct -> Report -> TcM ErrMsg
mkErrorMsgFromCt ReportErrCtxt
ctxt Ct
ct (Report -> TcM ErrMsg) -> Report -> TcM ErrMsg
forall a b. (a -> b) -> a -> b
$ [Report] -> Report
forall a. Monoid a => [a] -> a
mconcat
        [ SDoc -> Report
important (SDoc -> Report) -> SDoc -> Report
forall a b. (a -> b) -> a -> b
$ Ct -> Maybe SwapFlag -> Type -> Type -> SDoc
misMatchMsg Ct
ct Maybe SwapFlag
oriented Type
ty1 Type
ty2
        , SDoc -> Report
important (SDoc -> Report) -> SDoc -> Report
forall a b. (a -> b) -> a -> b
$ ReportErrCtxt -> TyCoVar -> Type -> SDoc
extraTyVarEqInfo ReportErrCtxt
ctxt TyCoVar
tv1 Type
ty2
        , Report
report
        ]

  -- Check for skolem escape
  | (implic :: Implication
implic:_) <- ReportErrCtxt -> [Implication]
cec_encl ReportErrCtxt
ctxt   -- Get the innermost context
  , Implic { ic_skols :: Implication -> [TyCoVar]
ic_skols = [TyCoVar]
skols, ic_info :: Implication -> SkolemInfo
ic_info = SkolemInfo
skol_info } <- Implication
implic
  , let esc_skols :: [TyCoVar]
esc_skols = (TyCoVar -> Bool) -> [TyCoVar] -> [TyCoVar]
forall a. (a -> Bool) -> [a] -> [a]
filter (TyCoVar -> VarSet -> Bool
`elemVarSet` (Type -> VarSet
tyCoVarsOfType Type
ty2)) [TyCoVar]
skols
  , Bool -> Bool
not ([TyCoVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyCoVar]
esc_skols)
  = do { let msg :: Report
msg = SDoc -> Report
important (SDoc -> Report) -> SDoc -> Report
forall a b. (a -> b) -> a -> b
$ Ct -> Maybe SwapFlag -> Type -> Type -> SDoc
misMatchMsg Ct
ct Maybe SwapFlag
oriented Type
ty1 Type
ty2
             esc_doc :: SDoc
esc_doc = [SDoc] -> SDoc
sep [ String -> SDoc
text "because" SDoc -> SDoc -> SDoc
<+> SDoc
what SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "variable" SDoc -> SDoc -> SDoc
<> [TyCoVar] -> SDoc
forall a. [a] -> SDoc
plural [TyCoVar]
esc_skols
                             SDoc -> SDoc -> SDoc
<+> [TyCoVar] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [TyCoVar]
esc_skols
                           , String -> SDoc
text "would escape" SDoc -> SDoc -> SDoc
<+>
                             if [TyCoVar] -> Bool
forall a. [a] -> Bool
isSingleton [TyCoVar]
esc_skols then String -> SDoc
text "its scope"
                                                      else String -> SDoc
text "their scope" ]
             tv_extra :: Report
tv_extra = SDoc -> Report
important (SDoc -> Report) -> SDoc -> Report
forall a b. (a -> b) -> a -> b
$
                        [SDoc] -> SDoc
vcat [ Int -> SDoc -> SDoc
nest 2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc
esc_doc
                             , [SDoc] -> SDoc
sep [ (if [TyCoVar] -> Bool
forall a. [a] -> Bool
isSingleton [TyCoVar]
esc_skols
                                      then String -> SDoc
text "This (rigid, skolem)" SDoc -> SDoc -> SDoc
<+>
                                           SDoc
what SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "variable is"
                                      else String -> SDoc
text "These (rigid, skolem)" SDoc -> SDoc -> SDoc
<+>
                                           SDoc
what SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "variables are")
                               SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "bound by"
                             , Int -> SDoc -> SDoc
nest 2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ SkolemInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr SkolemInfo
skol_info
                             , Int -> SDoc -> SDoc
nest 2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text "at" SDoc -> SDoc -> SDoc
<+>
                               RealSrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TcLclEnv -> RealSrcSpan
tcl_loc (Implication -> TcLclEnv
implicLclEnv Implication
implic)) ] ]
       ; ReportErrCtxt -> Ct -> Report -> TcM ErrMsg
mkErrorMsgFromCt ReportErrCtxt
ctxt Ct
ct ([Report] -> Report
forall a. Monoid a => [a] -> a
mconcat [Report
msg, Report
tv_extra, Report
report]) }

  -- Nastiest case: attempt to unify an untouchable variable
  -- So tv is a meta tyvar (or started that way before we
  -- generalised it).  So presumably it is an *untouchable*
  -- meta tyvar or a TyVarTv, else it'd have been unified
  -- See Note [Error messages for untouchables]
  | (implic :: Implication
implic:_) <- ReportErrCtxt -> [Implication]
cec_encl ReportErrCtxt
ctxt   -- Get the innermost context
  , Implic { ic_given :: Implication -> [TyCoVar]
ic_given = [TyCoVar]
given, ic_tclvl :: Implication -> TcLevel
ic_tclvl = TcLevel
lvl, ic_info :: Implication -> SkolemInfo
ic_info = SkolemInfo
skol_info } <- Implication
implic
  = ASSERT2( not (isTouchableMetaTyVar lvl tv1)
           , ppr tv1 $$ ppr lvl )  -- See Note [Error messages for untouchables]
    do { let msg :: Report
msg = SDoc -> Report
important (SDoc -> Report) -> SDoc -> Report
forall a b. (a -> b) -> a -> b
$ Ct -> Maybe SwapFlag -> Type -> Type -> SDoc
misMatchMsg Ct
ct Maybe SwapFlag
oriented Type
ty1 Type
ty2
             tclvl_extra :: Report
tclvl_extra = SDoc -> Report
important (SDoc -> Report) -> SDoc -> Report
forall a b. (a -> b) -> a -> b
$
                  Int -> SDoc -> SDoc
nest 2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                  [SDoc] -> SDoc
sep [ SDoc -> SDoc
quotes (TyCoVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCoVar
tv1) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is untouchable"
                      , Int -> SDoc -> SDoc
nest 2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text "inside the constraints:" SDoc -> SDoc -> SDoc
<+> [TyCoVar] -> SDoc
pprEvVarTheta [TyCoVar]
given
                      , Int -> SDoc -> SDoc
nest 2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text "bound by" SDoc -> SDoc -> SDoc
<+> SkolemInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr SkolemInfo
skol_info
                      , Int -> SDoc -> SDoc
nest 2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text "at" SDoc -> SDoc -> SDoc
<+>
                        RealSrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TcLclEnv -> RealSrcSpan
tcl_loc (Implication -> TcLclEnv
implicLclEnv Implication
implic)) ]
             tv_extra :: Report
tv_extra = SDoc -> Report
important (SDoc -> Report) -> SDoc -> Report
forall a b. (a -> b) -> a -> b
$ ReportErrCtxt -> TyCoVar -> Type -> SDoc
extraTyVarEqInfo ReportErrCtxt
ctxt TyCoVar
tv1 Type
ty2
             add_sig :: Report
add_sig  = SDoc -> Report
important (SDoc -> Report) -> SDoc -> Report
forall a b. (a -> b) -> a -> b
$ ReportErrCtxt -> Type -> Type -> SDoc
suggestAddSig ReportErrCtxt
ctxt Type
ty1 Type
ty2
       ; ReportErrCtxt -> Ct -> Report -> TcM ErrMsg
mkErrorMsgFromCt ReportErrCtxt
ctxt Ct
ct (Report -> TcM ErrMsg) -> Report -> TcM ErrMsg
forall a b. (a -> b) -> a -> b
$ [Report] -> Report
forall a. Monoid a => [a] -> a
mconcat
            [Report
msg, Report
tclvl_extra, Report
tv_extra, Report
add_sig, Report
report] }

  | Bool
otherwise
  = ReportErrCtxt
-> Report -> Ct -> Maybe SwapFlag -> Type -> Type -> TcM ErrMsg
reportEqErr ReportErrCtxt
ctxt Report
report Ct
ct Maybe SwapFlag
oriented (TyCoVar -> Type
mkTyVarTy TyCoVar
tv1) Type
ty2
        -- This *can* happen (Trac #6123, and test T2627b)
        -- Consider an ambiguous top-level constraint (a ~ F a)
        -- Not an occurs check, because F is a type function.
  where
    Pair _ k1 :: Type
k1 = Coercion -> Pair Type
tcCoercionKind Coercion
co1
    k2 :: Type
k2        = HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind Type
ty2

    ty1 :: Type
ty1 = TyCoVar -> Type
mkTyVarTy TyCoVar
tv1
    occ_check_expand :: OccCheckResult ()
occ_check_expand       = DynFlags -> TyCoVar -> Type -> OccCheckResult ()
occCheckForErrors DynFlags
dflags TyCoVar
tv1 Type
ty2
    insoluble_occurs_check :: Bool
insoluble_occurs_check = EqRel -> TyCoVar -> Type -> Bool
isInsolubleOccursCheck (Ct -> EqRel
ctEqRel Ct
ct) TyCoVar
tv1 Type
ty2

    what :: SDoc
what = case CtLoc -> Maybe TypeOrKind
ctLocTypeOrKind_maybe (Ct -> CtLoc
ctLoc Ct
ct) of
      Just KindLevel -> String -> SDoc
text "kind"
      _              -> String -> SDoc
text "type"

mkEqInfoMsg :: Ct -> TcType -> TcType -> SDoc
-- 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 :: Ct -> Type -> Type -> SDoc
mkEqInfoMsg ct :: Ct
ct ty1 :: Type
ty1 ty2 :: Type
ty2
  = SDoc
tyfun_msg SDoc -> SDoc -> SDoc
$$ SDoc
ambig_msg
  where
    mb_fun1 :: Maybe TyCon
mb_fun1 = Type -> Maybe TyCon
isTyFun_maybe Type
ty1
    mb_fun2 :: Maybe TyCon
mb_fun2 = Type -> Maybe TyCon
isTyFun_maybe Type
ty2

    ambig_msg :: SDoc
ambig_msg | Maybe TyCon -> Bool
forall a. Maybe a -> Bool
isJust Maybe TyCon
mb_fun1 Bool -> Bool -> Bool
|| Maybe TyCon -> Bool
forall a. Maybe a -> Bool
isJust Maybe TyCon
mb_fun2
              = (Bool, SDoc) -> SDoc
forall a b. (a, b) -> b
snd (Bool -> Ct -> (Bool, SDoc)
mkAmbigMsg Bool
False Ct
ct)
              | Bool
otherwise = SDoc
empty

    tyfun_msg :: SDoc
tyfun_msg | Just tc1 :: TyCon
tc1 <- Maybe TyCon
mb_fun1
              , Just tc2 :: TyCon
tc2 <- Maybe TyCon
mb_fun2
              , TyCon
tc1 TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tc2
              , Bool -> Bool
not (TyCon -> Role -> Bool
isInjectiveTyCon TyCon
tc1 Role
Nominal)
              = String -> SDoc
text "NB:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc1)
                SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is a non-injective type family"
              | Bool
otherwise = SDoc
empty

isUserSkolem :: ReportErrCtxt -> TcTyVar -> Bool
-- See Note [Reporting occurs-check errors]
isUserSkolem :: ReportErrCtxt -> TyCoVar -> Bool
isUserSkolem ctxt :: ReportErrCtxt
ctxt tv :: TyCoVar
tv
  = TyCoVar -> Bool
isSkolemTyVar TyCoVar
tv Bool -> Bool -> Bool
&& (Implication -> Bool) -> [Implication] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Implication -> Bool
is_user_skol_tv (ReportErrCtxt -> [Implication]
cec_encl ReportErrCtxt
ctxt)
  where
    is_user_skol_tv :: Implication -> Bool
is_user_skol_tv (Implic { ic_skols :: Implication -> [TyCoVar]
ic_skols = [TyCoVar]
sks, ic_info :: Implication -> SkolemInfo
ic_info = SkolemInfo
skol_info })
      = TyCoVar
tv TyCoVar -> [TyCoVar] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TyCoVar]
sks Bool -> Bool -> Bool
&& SkolemInfo -> Bool
is_user_skol_info SkolemInfo
skol_info

    is_user_skol_info :: SkolemInfo -> Bool
is_user_skol_info (InferSkol {}) = Bool
False
    is_user_skol_info _ = Bool
True

misMatchOrCND :: ReportErrCtxt -> Ct
              -> Maybe SwapFlag -> TcType -> TcType -> SDoc
-- If oriented then ty1 is actual, ty2 is expected
misMatchOrCND :: ReportErrCtxt -> Ct -> Maybe SwapFlag -> Type -> Type -> SDoc
misMatchOrCND ctxt :: ReportErrCtxt
ctxt ct :: Ct
ct oriented :: Maybe SwapFlag
oriented ty1 :: Type
ty1 ty2 :: Type
ty2
  | [Implication] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Implication]
givens Bool -> Bool -> Bool
||
    (Type -> Bool
isRigidTy Type
ty1 Bool -> Bool -> Bool
&& Type -> Bool
isRigidTy Type
ty2) Bool -> Bool -> Bool
||
    Ct -> Bool
isGivenCt Ct
ct
       -- If the equality is unconditionally insoluble
       -- or there is no context, don't report the context
  = Ct -> Maybe SwapFlag -> Type -> Type -> SDoc
misMatchMsg Ct
ct Maybe SwapFlag
oriented Type
ty1 Type
ty2
  | Bool
otherwise
  = [Implication] -> ([Type], CtOrigin) -> SDoc
couldNotDeduce [Implication]
givens ([Type
eq_pred], CtOrigin
orig)
  where
    ev :: CtEvidence
ev      = Ct -> CtEvidence
ctEvidence Ct
ct
    eq_pred :: Type
eq_pred = CtEvidence -> Type
ctEvPred CtEvidence
ev
    orig :: CtOrigin
orig    = CtEvidence -> CtOrigin
ctEvOrigin CtEvidence
ev
    givens :: [Implication]
givens  = [ Implication
given | Implication
given <- ReportErrCtxt -> [Implication]
getUserGivens ReportErrCtxt
ctxt, Bool -> Bool
not (Implication -> Bool
ic_no_eqs Implication
given)]
              -- Keep only UserGivens that have some equalities.
              -- See Note [Suppress redundant givens during error reporting]

couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc
couldNotDeduce :: [Implication] -> ([Type], CtOrigin) -> SDoc
couldNotDeduce givens :: [Implication]
givens (wanteds :: [Type]
wanteds, orig :: CtOrigin
orig)
  = [SDoc] -> SDoc
vcat [ CtOrigin -> SDoc -> SDoc
addArising CtOrigin
orig (String -> SDoc
text "Could not deduce:" SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
pprTheta [Type]
wanteds)
         , [SDoc] -> SDoc
vcat ([Implication] -> [SDoc]
pp_givens [Implication]
givens)]

pp_givens :: [UserGiven] -> [SDoc]
pp_givens :: [Implication] -> [SDoc]
pp_givens givens :: [Implication]
givens
   = case [Implication]
givens of
         []     -> []
         (g :: Implication
g:gs :: [Implication]
gs) ->      SDoc -> Implication -> SDoc
ppr_given (String -> SDoc
text "from the context:") Implication
g
                 SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: (Implication -> SDoc) -> [Implication] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (SDoc -> Implication -> SDoc
ppr_given (String -> SDoc
text "or from:")) [Implication]
gs
    where
       ppr_given :: SDoc -> Implication -> SDoc
ppr_given herald :: SDoc
herald implic :: Implication
implic@(Implic { ic_given :: Implication -> [TyCoVar]
ic_given = [TyCoVar]
gs, ic_info :: Implication -> SkolemInfo
ic_info = SkolemInfo
skol_info })
           = SDoc -> Int -> SDoc -> SDoc
hang (SDoc
herald SDoc -> SDoc -> SDoc
<+> [TyCoVar] -> SDoc
pprEvVarTheta ((TyCoVar -> Type) -> [TyCoVar] -> [TyCoVar]
forall a. (a -> Type) -> [a] -> [a]
mkMinimalBySCs TyCoVar -> Type
evVarPred [TyCoVar]
gs))
             -- See Note [Suppress redundant givens during error reporting]
             -- for why we use mkMinimalBySCs above.
                2 ([SDoc] -> SDoc
sep [ String -> SDoc
text "bound by" SDoc -> SDoc -> SDoc
<+> SkolemInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr SkolemInfo
skol_info
                       , String -> SDoc
text "at" SDoc -> SDoc -> SDoc
<+> RealSrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TcLclEnv -> RealSrcSpan
tcl_loc (Implication -> TcLclEnv
implicLclEnv Implication
implic)) ])

{-
Note [Suppress redundant givens during error reporting]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When GHC is unable to solve a constraint and prints out an error message, it
will print out what given constraints are in scope to provide some context to
the programmer. But we shouldn't print out /every/ given, since some of them
are not terribly helpful to diagnose type errors. Consider this example:

  foo :: Int :~: Int -> a :~: b -> a :~: c
  foo Refl Refl = Refl

When reporting that GHC can't solve (a ~ c), there are two givens in scope:
(Int ~ Int) and (a ~ b). But (Int ~ Int) is trivially soluble (i.e.,
redundant), so it's not terribly useful to report it in an error message.
To accomplish this, we discard any Implications that do not bind any
equalities by filtering the `givens` selected in `misMatchOrCND` (based on
the `ic_no_eqs` field of the Implication).

But this is not enough to avoid all redundant givens! Consider this example,
from #15361:

  goo :: forall (a :: Type) (b :: Type) (c :: Type).
         a :~~: b -> a :~~: c
  goo HRefl = HRefl

Matching on HRefl brings the /single/ given (* ~ *, a ~ b) into scope.
The (* ~ *) part arises due the kinds of (:~~:) being unified. More
importantly, (* ~ *) is redundant, so we'd like not to report it. However,
the Implication (* ~ *, a ~ b) /does/ bind an equality (as reported by its
ic_no_eqs field), so the test above will keep it wholesale.

To refine this given, we apply mkMinimalBySCs on it to extract just the (a ~ b)
part. This works because mkMinimalBySCs eliminates reflexive equalities in
addition to superclasses (see Note [Remove redundant provided dicts]
in TcPatSyn).
-}

extraTyVarEqInfo :: ReportErrCtxt -> TcTyVar -> TcType -> SDoc
-- Add on extra info about skolem constants
-- NB: The types themselves are already tidied
extraTyVarEqInfo :: ReportErrCtxt -> TyCoVar -> Type -> SDoc
extraTyVarEqInfo ctxt :: ReportErrCtxt
ctxt tv1 :: TyCoVar
tv1 ty2 :: Type
ty2
  = ReportErrCtxt -> TyCoVar -> SDoc
extraTyVarInfo ReportErrCtxt
ctxt TyCoVar
tv1 SDoc -> SDoc -> SDoc
$$ Type -> SDoc
ty_extra Type
ty2
  where
    ty_extra :: Type -> SDoc
ty_extra ty :: Type
ty = case Type -> Maybe TyCoVar
tcGetTyVar_maybe Type
ty of
                    Just tv :: TyCoVar
tv -> ReportErrCtxt -> TyCoVar -> SDoc
extraTyVarInfo ReportErrCtxt
ctxt TyCoVar
tv
                    Nothing -> SDoc
empty

extraTyVarInfo :: ReportErrCtxt -> TcTyVar -> SDoc
extraTyVarInfo :: ReportErrCtxt -> TyCoVar -> SDoc
extraTyVarInfo ctxt :: ReportErrCtxt
ctxt tv :: TyCoVar
tv
  = ASSERT2( isTyVar tv, ppr tv )
    case TyCoVar -> TcTyVarDetails
tcTyVarDetails TyCoVar
tv of
          SkolemTv {}   -> ReportErrCtxt -> [TyCoVar] -> SDoc
pprSkols ReportErrCtxt
ctxt [TyCoVar
tv]
          RuntimeUnk {} -> SDoc -> SDoc
quotes (TyCoVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCoVar
tv) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is an interactive-debugger skolem"
          MetaTv {}     -> SDoc
empty

suggestAddSig :: ReportErrCtxt -> TcType -> TcType -> SDoc
-- See Note [Suggest adding a type signature]
suggestAddSig :: ReportErrCtxt -> Type -> Type -> SDoc
suggestAddSig ctxt :: ReportErrCtxt
ctxt ty1 :: Type
ty1 ty2 :: Type
ty2
  | [Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
inferred_bndrs
  = SDoc
empty
  | [bndr :: Name
bndr] <- [Name]
inferred_bndrs
  = String -> SDoc
text "Possible fix: add a type signature for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
bndr)
  | Bool
otherwise
  = String -> SDoc
text "Possible fix: add type signatures for some or all of" SDoc -> SDoc -> SDoc
<+> ([Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Name]
inferred_bndrs)
  where
    inferred_bndrs :: [Name]
inferred_bndrs = [Name] -> [Name]
forall a. Eq a => [a] -> [a]
nub (Type -> [Name]
get_inf Type
ty1 [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ Type -> [Name]
get_inf Type
ty2)
    get_inf :: Type -> [Name]
get_inf ty :: Type
ty | Just tv :: TyCoVar
tv <- Type -> Maybe TyCoVar
tcGetTyVar_maybe Type
ty
               , TyCoVar -> Bool
isSkolemTyVar TyCoVar
tv
               , (implic :: Implication
implic, _) : _ <- [Implication] -> [TyCoVar] -> [(Implication, [TyCoVar])]
getSkolemInfo (ReportErrCtxt -> [Implication]
cec_encl ReportErrCtxt
ctxt) [TyCoVar
tv]
               , InferSkol prs :: [(Name, Type)]
prs <- Implication -> SkolemInfo
ic_info Implication
implic
               = ((Name, Type) -> Name) -> [(Name, Type)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Type) -> Name
forall a b. (a, b) -> a
fst [(Name, Type)]
prs
               | Bool
otherwise
               = []

--------------------
misMatchMsg :: Ct -> Maybe SwapFlag -> TcType -> TcType -> SDoc
-- Types are already tidy
-- If oriented then ty1 is actual, ty2 is expected
misMatchMsg :: Ct -> Maybe SwapFlag -> Type -> Type -> SDoc
misMatchMsg ct :: Ct
ct oriented :: Maybe SwapFlag
oriented ty1 :: Type
ty1 ty2 :: Type
ty2
  | Just NotSwapped <- Maybe SwapFlag
oriented
  = Ct -> Maybe SwapFlag -> Type -> Type -> SDoc
misMatchMsg Ct
ct (SwapFlag -> Maybe SwapFlag
forall a. a -> Maybe a
Just SwapFlag
IsSwapped) Type
ty2 Type
ty1

  -- These next two cases are when we're about to report, e.g., that
  -- 'LiftedRep doesn't match 'VoidRep. Much better just to say
  -- lifted vs. unlifted
  | Type -> Bool
isLiftedRuntimeRep Type
ty1
  = SDoc
lifted_vs_unlifted

  | Type -> Bool
isLiftedRuntimeRep Type
ty2
  = SDoc
lifted_vs_unlifted

  | Bool
otherwise  -- So now we have Nothing or (Just IsSwapped)
               -- For some reason we treat Nothing like IsSwapped
  = CtOrigin -> SDoc -> SDoc
addArising CtOrigin
orig (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
    Type -> Type -> CtOrigin -> SDoc -> SDoc
pprWithExplicitKindsWhenMismatch Type
ty1 Type
ty2 (Ct -> CtOrigin
ctOrigin Ct
ct) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
    [SDoc] -> SDoc
sep [ String -> SDoc
text String
herald1 SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty1)
        , Int -> SDoc -> SDoc
nest Int
padding (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
          String -> SDoc
text String
herald2 SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty2)
        , Type -> Type -> SDoc
sameOccExtra Type
ty2 Type
ty1 ]
  where
    herald1 :: String
herald1 = [String] -> String
conc [ "Couldn't match"
                   , if Bool
is_repr     then "representation of" else ""
                   , if Bool
is_oriented then "expected"          else ""
                   , String
what ]
    herald2 :: String
herald2 = [String] -> String
conc [ "with"
                   , if Bool
is_repr     then "that of"           else ""
                   , if Bool
is_oriented then ("actual " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
what) else "" ]
    padding :: Int
padding = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
herald1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
herald2

    is_repr :: Bool
is_repr = case Ct -> EqRel
ctEqRel Ct
ct of { ReprEq -> Bool
True; NomEq -> Bool
False }
    is_oriented :: Bool
is_oriented = Maybe SwapFlag -> Bool
forall a. Maybe a -> Bool
isJust Maybe SwapFlag
oriented

    orig :: CtOrigin
orig = Ct -> CtOrigin
ctOrigin Ct
ct
    what :: String
what = case CtLoc -> Maybe TypeOrKind
ctLocTypeOrKind_maybe (Ct -> CtLoc
ctLoc Ct
ct) of
      Just KindLevel -> "kind"
      _              -> "type"

    conc :: [String] -> String
    conc :: [String] -> String
conc = (String -> String -> String) -> [String] -> String
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 String -> String -> String
add_space

    add_space :: String -> String -> String
    add_space :: String -> String -> String
add_space s1 :: String
s1 s2 :: String
s2 | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s1   = String
s2
                    | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s2   = String
s1
                    | Bool
otherwise = String
s1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ (' ' Char -> String -> String
forall a. a -> [a] -> [a]
: String
s2)

    lifted_vs_unlifted :: SDoc
lifted_vs_unlifted
      = CtOrigin -> SDoc -> SDoc
addArising CtOrigin
orig (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
        String -> SDoc
text "Couldn't match a lifted type with an unlifted type"

-- | Prints explicit kinds (with @-fprint-explicit-kinds@) in an 'SDoc' when a
-- type mismatch occurs to due invisible kind arguments.
--
-- This function first checks to see if the 'CtOrigin' argument is a
-- 'TypeEqOrigin', and if so, uses the expected/actual types from that to
-- check for a kind mismatch (as these types typically have more surrounding
-- types and are likelier to be able to glean information about whether a
-- mismatch occurred in an invisible argument position or not). If the
-- 'CtOrigin' is not a 'TypeEqOrigin', fall back on the actual mismatched types
-- themselves.
pprWithExplicitKindsWhenMismatch :: Type -> Type -> CtOrigin
                                 -> SDoc -> SDoc
pprWithExplicitKindsWhenMismatch :: Type -> Type -> CtOrigin -> SDoc -> SDoc
pprWithExplicitKindsWhenMismatch ty1 :: Type
ty1 ty2 :: Type
ty2 ct :: CtOrigin
ct =
  Bool -> SDoc -> SDoc
pprWithExplicitKindsWhen Bool
mismatch
  where
    (act_ty :: Type
act_ty, exp_ty :: Type
exp_ty) = case CtOrigin
ct of
      TypeEqOrigin { uo_actual :: CtOrigin -> Type
uo_actual = Type
act
                   , uo_expected :: CtOrigin -> Type
uo_expected = Type
exp } -> (Type
act, Type
exp)
      _                                  -> (Type
ty1, Type
ty2)
    mismatch :: Bool
mismatch | Just vis :: Bool
vis <- Type -> Type -> Maybe Bool
tcEqTypeVis Type
act_ty Type
exp_ty
             = Bool -> Bool
not Bool
vis
             | Bool
otherwise
             = Bool
False

mkExpectedActualMsg :: Type -> Type -> CtOrigin -> Maybe TypeOrKind -> Bool
                    -> (Bool, Maybe SwapFlag, SDoc)
-- NotSwapped means (actual, expected), IsSwapped is the reverse
-- First return val is whether or not to print a herald above this msg
mkExpectedActualMsg :: Type
-> Type
-> CtOrigin
-> Maybe TypeOrKind
-> Bool
-> (Bool, Maybe SwapFlag, SDoc)
mkExpectedActualMsg ty1 :: Type
ty1 ty2 :: Type
ty2 ct :: CtOrigin
ct@(TypeEqOrigin { uo_actual :: CtOrigin -> Type
uo_actual = Type
act
                                             , uo_expected :: CtOrigin -> Type
uo_expected = Type
exp
                                             , uo_thing :: CtOrigin -> Maybe SDoc
uo_thing = Maybe SDoc
maybe_thing })
                    m_level :: Maybe TypeOrKind
m_level printExpanded :: Bool
printExpanded
  | TypeOrKind
KindLevel <- TypeOrKind
level, Bool
occurs_check_error       = (Bool
True, Maybe SwapFlag
forall a. Maybe a
Nothing, SDoc
empty)
  | Type -> Bool
isUnliftedTypeKind Type
act, Type -> Bool
isLiftedTypeKind Type
exp = (Bool
False, Maybe SwapFlag
forall a. Maybe a
Nothing, SDoc
msg2)
  | Type -> Bool
isLiftedTypeKind Type
act, Type -> Bool
isUnliftedTypeKind Type
exp = (Bool
False, Maybe SwapFlag
forall a. Maybe a
Nothing, SDoc
msg3)
  | Type -> Bool
tcIsLiftedTypeKind Type
exp                       = (Bool
False, Maybe SwapFlag
forall a. Maybe a
Nothing, SDoc
msg4)
  | Just msg :: SDoc
msg <- Maybe SDoc
num_args_msg                     = (Bool
False, Maybe SwapFlag
forall a. Maybe a
Nothing, SDoc
msg SDoc -> SDoc -> SDoc
$$ SDoc
msg1)
  | TypeOrKind
KindLevel <- TypeOrKind
level, Just th :: SDoc
th <- Maybe SDoc
maybe_thing   = (Bool
False, Maybe SwapFlag
forall a. Maybe a
Nothing, SDoc -> SDoc
msg5 SDoc
th)
  | Type
act Type -> Type -> Bool
`pickyEqType` Type
ty1, Type
exp Type -> Type -> Bool
`pickyEqType` Type
ty2 = (Bool
True, SwapFlag -> Maybe SwapFlag
forall a. a -> Maybe a
Just SwapFlag
NotSwapped, SDoc
empty)
  | Type
exp Type -> Type -> Bool
`pickyEqType` Type
ty1, Type
act Type -> Type -> Bool
`pickyEqType` Type
ty2 = (Bool
True, SwapFlag -> Maybe SwapFlag
forall a. a -> Maybe a
Just SwapFlag
IsSwapped, SDoc
empty)
  | Bool
otherwise                                    = (Bool
True, Maybe SwapFlag
forall a. Maybe a
Nothing, SDoc
msg1)
  where
    level :: TypeOrKind
level = Maybe TypeOrKind
m_level Maybe TypeOrKind -> TypeOrKind -> TypeOrKind
forall a. Maybe a -> a -> a
`orElse` TypeOrKind
TypeLevel

    occurs_check_error :: Bool
occurs_check_error
      | Just act_tv :: TyCoVar
act_tv <- Type -> Maybe TyCoVar
tcGetTyVar_maybe Type
act
      , TyCoVar
act_tv TyCoVar -> VarSet -> Bool
`elemVarSet` Type -> VarSet
tyCoVarsOfType Type
exp
      = Bool
True
      | Just exp_tv :: TyCoVar
exp_tv <- Type -> Maybe TyCoVar
tcGetTyVar_maybe Type
exp
      , TyCoVar
exp_tv TyCoVar -> VarSet -> Bool
`elemVarSet` Type -> VarSet
tyCoVarsOfType Type
act
      = Bool
True
      | Bool
otherwise
      = Bool
False

    sort :: SDoc
sort = case TypeOrKind
level of
      TypeLevel -> String -> SDoc
text "type"
      KindLevel -> String -> SDoc
text "kind"

    msg1 :: SDoc
msg1 = case TypeOrKind
level of
      KindLevel
        | Just th :: SDoc
th <- Maybe SDoc
maybe_thing
        -> SDoc -> SDoc
msg5 SDoc
th

      _ | Bool -> Bool
not (Type
act Type -> Type -> Bool
`pickyEqType` Type
exp)
        -> Type -> Type -> CtOrigin -> SDoc -> SDoc
pprWithExplicitKindsWhenMismatch Type
ty1 Type
ty2 CtOrigin
ct (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
           [SDoc] -> SDoc
vcat [ String -> SDoc
text "Expected" SDoc -> SDoc -> SDoc
<+> SDoc
sort SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
exp
                , String -> SDoc
text "  Actual" SDoc -> SDoc -> SDoc
<+> SDoc
sort SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
act
                , if Bool
printExpanded then SDoc
expandedTys else SDoc
empty ]

        | Bool
otherwise
        -> SDoc
empty

    thing_msg :: Bool -> SDoc
thing_msg = case Maybe SDoc
maybe_thing of
                  Just thing :: SDoc
thing -> \_ -> SDoc -> SDoc
quotes SDoc
thing SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is"
                  Nothing    -> \vowel :: Bool
vowel -> String -> SDoc
text "got a" SDoc -> SDoc -> SDoc
<>
                                          if Bool
vowel then Char -> SDoc
char 'n' else SDoc
empty
    msg2 :: SDoc
msg2 = [SDoc] -> SDoc
sep [ String -> SDoc
text "Expecting a lifted type, but"
               , Bool -> SDoc
thing_msg Bool
True, String -> SDoc
text "unlifted" ]
    msg3 :: SDoc
msg3 = [SDoc] -> SDoc
sep [ String -> SDoc
text "Expecting an unlifted type, but"
               , Bool -> SDoc
thing_msg Bool
False, String -> SDoc
text "lifted" ]
    msg4 :: SDoc
msg4 = SDoc
maybe_num_args_msg SDoc -> SDoc -> SDoc
$$
           [SDoc] -> SDoc
sep [ String -> SDoc
text "Expected a type, but"
               , SDoc -> (SDoc -> SDoc) -> Maybe SDoc -> SDoc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> SDoc
text "found something with kind")
                       (\thing :: SDoc
thing -> SDoc -> SDoc
quotes SDoc
thing SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "has kind")
                       Maybe SDoc
maybe_thing
               , SDoc -> SDoc
quotes (Type -> SDoc
pprWithTYPE Type
act) ]

    msg5 :: SDoc -> SDoc
msg5 th :: SDoc
th = Type -> Type -> CtOrigin -> SDoc -> SDoc
pprWithExplicitKindsWhenMismatch Type
ty1 Type
ty2 CtOrigin
ct (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
              SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Expected" SDoc -> SDoc -> SDoc
<+> SDoc
kind_desc SDoc -> SDoc -> SDoc
<> SDoc
comma)
                 2 (String -> SDoc
text "but" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes SDoc
th SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "has kind" SDoc -> SDoc -> SDoc
<+>
                    SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
act))
      where
        kind_desc :: SDoc
kind_desc | Type -> Bool
tcIsConstraintKind Type
exp = String -> SDoc
text "a constraint"

                    -- TYPE t0
                  | Just arg :: Type
arg <- HasDebugCallStack => Type -> Maybe Type
Type -> Maybe Type
kindRep_maybe Type
exp
                  , Type -> Bool
tcIsTyVarTy Type
arg = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \dflags :: DynFlags
dflags ->
                                      if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_PrintExplicitRuntimeReps DynFlags
dflags
                                      then String -> SDoc
text "kind" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
exp)
                                      else String -> SDoc
text "a type"

                  | Bool
otherwise       = String -> SDoc
text "kind" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
exp)

    num_args_msg :: Maybe SDoc
num_args_msg = case TypeOrKind
level of
      KindLevel
        | Bool -> Bool
not (Type -> Bool
isMetaTyVarTy Type
exp) Bool -> Bool -> Bool
&& Bool -> Bool
not (Type -> Bool
isMetaTyVarTy Type
act)
           -- if one is a meta-tyvar, then it's possible that the user
           -- has asked for something impredicative, and we couldn't unify.
           -- Don't bother with counting arguments.
        -> let n_act :: Int
n_act = Type -> Int
count_args Type
act
               n_exp :: Int
n_exp = Type -> Int
count_args Type
exp in
           case Int
n_act Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n_exp of
             n :: Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0   -- we don't know how many args there are, so don't
                         -- recommend removing args that aren't
               , Just thing :: SDoc
thing <- Maybe SDoc
maybe_thing
               -> SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text "Expecting" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
speakN (Int -> Int
forall a. Num a => a -> a
abs Int
n) SDoc -> SDoc -> SDoc
<+>
                         SDoc
more SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes SDoc
thing
               where
                 more :: SDoc
more
                  | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1    = String -> SDoc
text "more argument to"
                  | Bool
otherwise = String -> SDoc
text "more arguments to"  -- n > 1
             _ -> Maybe SDoc
forall a. Maybe a
Nothing

      _ -> Maybe SDoc
forall a. Maybe a
Nothing

    maybe_num_args_msg :: SDoc
maybe_num_args_msg = case Maybe SDoc
num_args_msg of
      Nothing -> SDoc
empty
      Just m :: SDoc
m  -> SDoc
m

    count_args :: Type -> Int
count_args ty :: Type
ty = (TyCoBinder -> Bool) -> [TyCoBinder] -> Int
forall a. (a -> Bool) -> [a] -> Int
count TyCoBinder -> Bool
isVisibleBinder ([TyCoBinder] -> Int) -> [TyCoBinder] -> Int
forall a b. (a -> b) -> a -> b
$ ([TyCoBinder], Type) -> [TyCoBinder]
forall a b. (a, b) -> a
fst (([TyCoBinder], Type) -> [TyCoBinder])
-> ([TyCoBinder], Type) -> [TyCoBinder]
forall a b. (a -> b) -> a -> b
$ Type -> ([TyCoBinder], Type)
splitPiTys Type
ty

    expandedTys :: SDoc
expandedTys =
      Bool -> SDoc -> SDoc
ppUnless (Type
expTy1 Type -> Type -> Bool
`pickyEqType` Type
exp Bool -> Bool -> Bool
&& Type
expTy2 Type -> Type -> Bool
`pickyEqType` Type
act) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
        [ String -> SDoc
text "Type synonyms expanded:"
        , String -> SDoc
text "Expected type:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
expTy1
        , String -> SDoc
text "  Actual type:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
expTy2
        ]

    (expTy1 :: Type
expTy1, expTy2 :: Type
expTy2) = Type -> Type -> (Type, Type)
expandSynonymsToMatch Type
exp Type
act

mkExpectedActualMsg _ _ _ _ _ = String -> (Bool, Maybe SwapFlag, SDoc)
forall a. String -> a
panic "mkExpectedAcutalMsg"

{- Note [Insoluble occurs check wins]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider [G] a ~ [a],  [W] a ~ [a] (Trac #13674).  The Given is insoluble
so we don't use it for rewriting.  The Wanted is also insoluble, and
we don't solve it from the Given.  It's very confusing to say
    Cannot solve a ~ [a] from given constraints a ~ [a]

And indeed even thinking about the Givens is silly; [W] a ~ [a] is
just as insoluble as Int ~ Bool.

Conclusion: if there's an insoluble occurs check (isInsolubleOccursCheck)
then report it first.

(NB: there are potentially-soluble ones, like (a ~ F a b), and we don't
want to be as draconian with them.)

Note [Expanding type synonyms to make types similar]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

In type error messages, if -fprint-expanded-types is used, we want to expand
type synonyms to make expected and found types as similar as possible, but we
shouldn't expand types too much to make type messages even more verbose and
harder to understand. The whole point here is to make the difference in expected
and found types clearer.

`expandSynonymsToMatch` does this, it takes two types, and expands type synonyms
only as much as necessary. Given two types t1 and t2:

  * If they're already same, it just returns the types.

  * If they're in form `C1 t1_1 .. t1_n` and `C2 t2_1 .. t2_m` (C1 and C2 are
    type constructors), it expands C1 and C2 if they're different type synonyms.
    Then it recursively does the same thing on expanded types. If C1 and C2 are
    same, then it applies the same procedure to arguments of C1 and arguments of
    C2 to make them as similar as possible.

    Most important thing here is to keep number of synonym expansions at
    minimum. For example, if t1 is `T (T3, T5, Int)` and t2 is `T (T5, T3,
    Bool)` where T5 = T4, T4 = T3, ..., T1 = X, it returns `T (T3, T3, Int)` and
    `T (T3, T3, Bool)`.

  * Otherwise types don't have same shapes and so the difference is clearly
    visible. It doesn't do any expansions and show these types.

Note that we only expand top-layer type synonyms. Only when top-layer
constructors are the same we start expanding inner type synonyms.

Suppose top-layer type synonyms of t1 and t2 can expand N and M times,
respectively. If their type-synonym-expanded forms will meet at some point (i.e.
will have same shapes according to `sameShapes` function), it's possible to find
where they meet in O(N+M) top-layer type synonym expansions and O(min(N,M))
comparisons. We first collect all the top-layer expansions of t1 and t2 in two
lists, then drop the prefix of the longer list so that they have same lengths.
Then we search through both lists in parallel, and return the first pair of
types that have same shapes. Inner types of these two types with same shapes
are then expanded using the same algorithm.

In case they don't meet, we return the last pair of types in the lists, which
has top-layer type synonyms completely expanded. (in this case the inner types
are not expanded at all, as the current form already shows the type error)
-}

-- | Expand type synonyms in given types only enough to make them as similar as
-- possible. Returned types are the same in terms of used type synonyms.
--
-- To expand all synonyms, see 'Type.expandTypeSynonyms'.
--
-- See `ExpandSynsFail` tests in tests testsuite/tests/typecheck/should_fail for
-- some examples of how this should work.
expandSynonymsToMatch :: Type -> Type -> (Type, Type)
expandSynonymsToMatch :: Type -> Type -> (Type, Type)
expandSynonymsToMatch ty1 :: Type
ty1 ty2 :: Type
ty2 = (Type
ty1_ret, Type
ty2_ret)
  where
    (ty1_ret :: Type
ty1_ret, ty2_ret :: Type
ty2_ret) = Type -> Type -> (Type, Type)
go Type
ty1 Type
ty2

    -- | Returns (type synonym expanded version of first type,
    --            type synonym expanded version of second type)
    go :: Type -> Type -> (Type, Type)
    go :: Type -> Type -> (Type, Type)
go t1 :: Type
t1 t2 :: Type
t2
      | Type
t1 Type -> Type -> Bool
`pickyEqType` Type
t2 =
        -- Types are same, nothing to do
        (Type
t1, Type
t2)

    go (TyConApp tc1 :: TyCon
tc1 tys1 :: [Type]
tys1) (TyConApp tc2 :: TyCon
tc2 tys2 :: [Type]
tys2)
      | TyCon
tc1 TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tc2 =
        -- Type constructors are same. They may be synonyms, but we don't
        -- expand further.
        let (tys1' :: [Type]
tys1', tys2' :: [Type]
tys2') =
              [(Type, Type)] -> ([Type], [Type])
forall a b. [(a, b)] -> ([a], [b])
unzip ((Type -> Type -> (Type, Type))
-> [Type] -> [Type] -> [(Type, Type)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ty1 :: Type
ty1 ty2 :: Type
ty2 -> Type -> Type -> (Type, Type)
go Type
ty1 Type
ty2) [Type]
tys1 [Type]
tys2)
         in (TyCon -> [Type] -> Type
TyConApp TyCon
tc1 [Type]
tys1', TyCon -> [Type] -> Type
TyConApp TyCon
tc2 [Type]
tys2')

    go (AppTy t1_1 :: Type
t1_1 t1_2 :: Type
t1_2) (AppTy t2_1 :: Type
t2_1 t2_2 :: Type
t2_2) =
      let (t1_1' :: Type
t1_1', t2_1' :: Type
t2_1') = Type -> Type -> (Type, Type)
go Type
t1_1 Type
t2_1
          (t1_2' :: Type
t1_2', t2_2' :: Type
t2_2') = Type -> Type -> (Type, Type)
go Type
t1_2 Type
t2_2
       in (Type -> Type -> Type
mkAppTy Type
t1_1' Type
t1_2', Type -> Type -> Type
mkAppTy Type
t2_1' Type
t2_2')

    go (FunTy t1_1 :: Type
t1_1 t1_2 :: Type
t1_2) (FunTy t2_1 :: Type
t2_1 t2_2 :: Type
t2_2) =
      let (t1_1' :: Type
t1_1', t2_1' :: Type
t2_1') = Type -> Type -> (Type, Type)
go Type
t1_1 Type
t2_1
          (t1_2' :: Type
t1_2', t2_2' :: Type
t2_2') = Type -> Type -> (Type, Type)
go Type
t1_2 Type
t2_2
       in (Type -> Type -> Type
mkFunTy Type
t1_1' Type
t1_2', Type -> Type -> Type
mkFunTy Type
t2_1' Type
t2_2')

    go (ForAllTy b1 :: TyCoVarBinder
b1 t1 :: Type
t1) (ForAllTy b2 :: TyCoVarBinder
b2 t2 :: Type
t2) =
      -- NOTE: We may have a bug here, but we just can't reproduce it easily.
      -- See D1016 comments for details and our attempts at producing a test
      -- case. Short version: We probably need RnEnv2 to really get this right.
      let (t1' :: Type
t1', t2' :: Type
t2') = Type -> Type -> (Type, Type)
go Type
t1 Type
t2
       in (TyCoVarBinder -> Type -> Type
ForAllTy TyCoVarBinder
b1 Type
t1', TyCoVarBinder -> Type -> Type
ForAllTy TyCoVarBinder
b2 Type
t2')

    go (CastTy ty1 :: Type
ty1 _) ty2 :: Type
ty2 = Type -> Type -> (Type, Type)
go Type
ty1 Type
ty2
    go ty1 :: Type
ty1 (CastTy ty2 :: Type
ty2 _) = Type -> Type -> (Type, Type)
go Type
ty1 Type
ty2

    go t1 :: Type
t1 t2 :: Type
t2 =
      -- See Note [Expanding type synonyms to make types similar] for how this
      -- works
      let
        t1_exp_tys :: [Type]
t1_exp_tys = Type
t1 Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: Type -> [Type]
tyExpansions Type
t1
        t2_exp_tys :: [Type]
t2_exp_tys = Type
t2 Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: Type -> [Type]
tyExpansions Type
t2
        t1_exps :: Int
t1_exps    = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
t1_exp_tys
        t2_exps :: Int
t2_exps    = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
t2_exp_tys
        dif :: Int
dif        = Int -> Int
forall a. Num a => a -> a
abs (Int
t1_exps Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
t2_exps)
      in
        [(Type, Type)] -> (Type, Type)
followExpansions ([(Type, Type)] -> (Type, Type)) -> [(Type, Type)] -> (Type, Type)
forall a b. (a -> b) -> a -> b
$
          String -> [Type] -> [Type] -> [(Type, Type)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual "expandSynonymsToMatch.go"
            (if Int
t1_exps Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
t2_exps then Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
drop Int
dif [Type]
t1_exp_tys else [Type]
t1_exp_tys)
            (if Int
t2_exps Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
t1_exps then Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
drop Int
dif [Type]
t2_exp_tys else [Type]
t2_exp_tys)

    -- | Expand the top layer type synonyms repeatedly, collect expansions in a
    -- list. The list does not include the original type.
    --
    -- Example, if you have:
    --
    --   type T10 = T9
    --   type T9  = T8
    --   ...
    --   type T0  = Int
    --
    -- `tyExpansions T10` returns [T9, T8, T7, ... Int]
    --
    -- This only expands the top layer, so if you have:
    --
    --   type M a = Maybe a
    --
    -- `tyExpansions (M T10)` returns [Maybe T10] (T10 is not expanded)
    tyExpansions :: Type -> [Type]
    tyExpansions :: Type -> [Type]
tyExpansions = (Type -> Maybe (Type, Type)) -> Type -> [Type]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr (\t :: Type
t -> (\x :: Type
x -> (Type
x, Type
x)) (Type -> (Type, Type)) -> Maybe Type -> Maybe (Type, Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Type -> Maybe Type
tcView Type
t)

    -- | Drop the type pairs until types in a pair look alike (i.e. the outer
    -- constructors are the same).
    followExpansions :: [(Type, Type)] -> (Type, Type)
    followExpansions :: [(Type, Type)] -> (Type, Type)
followExpansions [] = String -> SDoc -> (Type, Type)
forall a. HasCallStack => String -> SDoc -> a
pprPanic "followExpansions" SDoc
empty
    followExpansions [(t1 :: Type
t1, t2 :: Type
t2)]
      | Type -> Type -> Bool
sameShapes Type
t1 Type
t2 = Type -> Type -> (Type, Type)
go Type
t1 Type
t2 -- expand subtrees
      | Bool
otherwise        = (Type
t1, Type
t2) -- the difference is already visible
    followExpansions ((t1 :: Type
t1, t2 :: Type
t2) : tss :: [(Type, Type)]
tss)
      -- Traverse subtrees when the outer shapes are the same
      | Type -> Type -> Bool
sameShapes Type
t1 Type
t2 = Type -> Type -> (Type, Type)
go Type
t1 Type
t2
      -- Otherwise follow the expansions until they look alike
      | Bool
otherwise = [(Type, Type)] -> (Type, Type)
followExpansions [(Type, Type)]
tss

    sameShapes :: Type -> Type -> Bool
    sameShapes :: Type -> Type -> Bool
sameShapes AppTy{}          AppTy{}          = Bool
True
    sameShapes (TyConApp tc1 :: TyCon
tc1 _) (TyConApp tc2 :: TyCon
tc2 _) = TyCon
tc1 TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tc2
    sameShapes (FunTy {})       (FunTy {})       = Bool
True
    sameShapes (ForAllTy {})    (ForAllTy {})    = Bool
True
    sameShapes (CastTy ty1 :: Type
ty1 _)   ty2 :: Type
ty2              = Type -> Type -> Bool
sameShapes Type
ty1 Type
ty2
    sameShapes ty1 :: Type
ty1              (CastTy ty2 :: Type
ty2 _)   = Type -> Type -> Bool
sameShapes Type
ty1 Type
ty2
    sameShapes _                _                = Bool
False

sameOccExtra :: TcType -> TcType -> SDoc
-- See Note [Disambiguating (X ~ X) errors]
sameOccExtra :: Type -> Type -> SDoc
sameOccExtra ty1 :: Type
ty1 ty2 :: Type
ty2
  | Just (tc1 :: TyCon
tc1, _) <- HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty1
  , Just (tc2 :: TyCon
tc2, _) <- HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty2
  , let n1 :: Name
n1 = TyCon -> Name
tyConName TyCon
tc1
        n2 :: Name
n2 = TyCon -> Name
tyConName TyCon
tc2
        same_occ :: Bool
same_occ = Name -> OccName
nameOccName Name
n1                   OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> OccName
nameOccName Name
n2
        same_pkg :: Bool
same_pkg = Module -> UnitId
moduleUnitId (HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
n1) UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== Module -> UnitId
moduleUnitId (HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
n2)
  , Name
n1 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
n2   -- Different Names
  , Bool
same_occ   -- but same OccName
  = String -> SDoc
text "NB:" SDoc -> SDoc -> SDoc
<+> (Bool -> Name -> SDoc
ppr_from Bool
same_pkg Name
n1 SDoc -> SDoc -> SDoc
$$ Bool -> Name -> SDoc
ppr_from Bool
same_pkg Name
n2)
  | Bool
otherwise
  = SDoc
empty
  where
    ppr_from :: Bool -> Name -> SDoc
ppr_from same_pkg :: Bool
same_pkg nm :: Name
nm
      | SrcSpan -> Bool
isGoodSrcSpan SrcSpan
loc
      = SDoc -> Int -> SDoc -> SDoc
hang (SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
nm) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is defined at")
           2 (SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
loc)
      | Bool
otherwise  -- Imported things have an UnhelpfulSrcSpan
      = SDoc -> Int -> SDoc -> SDoc
hang (SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
nm))
           2 ([SDoc] -> SDoc
sep [ String -> SDoc
text "is defined in" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Module -> ModuleName
moduleName Module
mod))
                  , Bool -> SDoc -> SDoc
ppUnless (Bool
same_pkg Bool -> Bool -> Bool
|| UnitId
pkg UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitId
mainUnitId) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                    Int -> SDoc -> SDoc
nest 4 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text "in package" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
pkg) ])
       where
         pkg :: UnitId
pkg = Module -> UnitId
moduleUnitId Module
mod
         mod :: Module
mod = HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
nm
         loc :: SrcSpan
loc = Name -> SrcSpan
nameSrcSpan Name
nm

{-
Note [Suggest adding a type signature]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The OutsideIn algorithm rejects GADT programs that don't have a principal
type, and indeed some that do.  Example:
   data T a where
     MkT :: Int -> T Int

   f (MkT n) = n

Does this have type f :: T a -> a, or f :: T a -> Int?
The error that shows up tends to be an attempt to unify an
untouchable type variable.  So suggestAddSig sees if the offending
type variable is bound by an *inferred* signature, and suggests
adding a declared signature instead.

This initially came up in Trac #8968, concerning pattern synonyms.

Note [Disambiguating (X ~ X) errors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See Trac #8278

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 something like
   f :: forall a. a -> [a]
with a deferred error of (a ~ [a]).  So in the deferred unsolved constraint
'a' is now a skolem, but not one bound by the programmer in the context!
Here we really should report an occurs check.

So isUserSkolem distinguishes the two.

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

mkDictErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkDictErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkDictErr ctxt :: ReportErrCtxt
ctxt cts :: [Ct]
cts
  = ASSERT( not (null cts) )
    do { InstEnvs
inst_envs <- TcM InstEnvs
tcGetInstEnvs
       ; let (ct1 :: Ct
ct1:_) = [Ct]
cts  -- ct1 just for its location
             min_cts :: [Ct]
min_cts = [Ct] -> [Ct]
elim_superclasses [Ct]
cts
             lookups :: [(Ct, ClsInstLookupResult)]
lookups = (Ct -> (Ct, ClsInstLookupResult))
-> [Ct] -> [(Ct, ClsInstLookupResult)]
forall a b. (a -> b) -> [a] -> [b]
map (InstEnvs -> Ct -> (Ct, ClsInstLookupResult)
lookup_cls_inst InstEnvs
inst_envs) [Ct]
min_cts
             (no_inst_cts :: [(Ct, ClsInstLookupResult)]
no_inst_cts, overlap_cts :: [(Ct, ClsInstLookupResult)]
overlap_cts) = ((Ct, ClsInstLookupResult) -> Bool)
-> [(Ct, ClsInstLookupResult)]
-> ([(Ct, ClsInstLookupResult)], [(Ct, ClsInstLookupResult)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Ct, ClsInstLookupResult) -> Bool
forall (t :: * -> *) (t :: * -> *) a a c.
(Foldable t, Foldable t) =>
(Ct, (t a, t a, c)) -> Bool
is_no_inst [(Ct, ClsInstLookupResult)]
lookups

       -- Report definite no-instance errors,
       -- or (iff there are none) overlap errors
       -- But we report only one of them (hence 'head') because they all
       -- have the same source-location origin, to try avoid a cascade
       -- of error from one location
       ; (ctxt :: ReportErrCtxt
ctxt, err :: SDoc
err) <- ReportErrCtxt
-> (Ct, ClsInstLookupResult) -> TcM (ReportErrCtxt, SDoc)
mk_dict_err ReportErrCtxt
ctxt ([(Ct, ClsInstLookupResult)] -> (Ct, ClsInstLookupResult)
forall a. [a] -> a
head ([(Ct, ClsInstLookupResult)]
no_inst_cts [(Ct, ClsInstLookupResult)]
-> [(Ct, ClsInstLookupResult)] -> [(Ct, ClsInstLookupResult)]
forall a. [a] -> [a] -> [a]
++ [(Ct, ClsInstLookupResult)]
overlap_cts))
       ; ReportErrCtxt -> Ct -> Report -> TcM ErrMsg
mkErrorMsgFromCt ReportErrCtxt
ctxt Ct
ct1 (SDoc -> Report
important SDoc
err) }
  where
    no_givens :: Bool
no_givens = [Implication] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (ReportErrCtxt -> [Implication]
getUserGivens ReportErrCtxt
ctxt)

    is_no_inst :: (Ct, (t a, t a, c)) -> Bool
is_no_inst (ct :: Ct
ct, (matches :: t a
matches, unifiers :: t a
unifiers, _))
      =  Bool
no_givens
      Bool -> Bool -> Bool
&& t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
matches
      Bool -> Bool -> Bool
&& (t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
unifiers Bool -> Bool -> Bool
|| (TyCoVar -> Bool) -> [TyCoVar] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not (Bool -> Bool) -> (TyCoVar -> Bool) -> TyCoVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCoVar -> Bool
isAmbiguousTyVar) (Ct -> [TyCoVar]
tyCoVarsOfCtList Ct
ct))

    lookup_cls_inst :: InstEnvs -> Ct -> (Ct, ClsInstLookupResult)
lookup_cls_inst inst_envs :: InstEnvs
inst_envs ct :: Ct
ct
                -- Note [Flattening in error message generation]
      = (Ct
ct, Bool -> InstEnvs -> Class -> [Type] -> ClsInstLookupResult
lookupInstEnv Bool
True InstEnvs
inst_envs Class
clas (InScopeSet -> [Type] -> [Type]
flattenTys InScopeSet
emptyInScopeSet [Type]
tys))
      where
        (clas :: Class
clas, tys :: [Type]
tys) = HasDebugCallStack => Type -> (Class, [Type])
Type -> (Class, [Type])
getClassPredTys (Ct -> Type
ctPred Ct
ct)


    -- When simplifying [W] Ord (Set a), we need
    --    [W] Eq a, [W] Ord a
    -- but we really only want to report the latter
    elim_superclasses :: [Ct] -> [Ct]
elim_superclasses cts :: [Ct]
cts = (Ct -> Type) -> [Ct] -> [Ct]
forall a. (a -> Type) -> [a] -> [a]
mkMinimalBySCs Ct -> Type
ctPred [Ct]
cts

mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult)
            -> TcM (ReportErrCtxt, SDoc)
-- Report an overlap error if this class constraint results
-- from an overlap (returning Left clas), otherwise return (Right pred)
mk_dict_err :: ReportErrCtxt
-> (Ct, ClsInstLookupResult) -> TcM (ReportErrCtxt, SDoc)
mk_dict_err ctxt :: ReportErrCtxt
ctxt@(CEC {cec_encl :: ReportErrCtxt -> [Implication]
cec_encl = [Implication]
implics}) (ct :: Ct
ct, (matches :: [InstMatch]
matches, unifiers :: [ClsInst]
unifiers, unsafe_overlapped :: [InstMatch]
unsafe_overlapped))
  | [InstMatch] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InstMatch]
matches  -- No matches but perhaps several unifiers
  = do { (ctxt :: ReportErrCtxt
ctxt, binds_msg :: SDoc
binds_msg, ct :: Ct
ct) <- Bool -> ReportErrCtxt -> Ct -> TcM (ReportErrCtxt, SDoc, Ct)
relevantBindings Bool
True ReportErrCtxt
ctxt Ct
ct
       ; [ClsInst]
candidate_insts <- TcM [ClsInst]
get_candidate_instances
       ; (ReportErrCtxt, SDoc) -> TcM (ReportErrCtxt, SDoc)
forall (m :: * -> *) a. Monad m => a -> m a
return (ReportErrCtxt
ctxt, Ct -> [ClsInst] -> SDoc -> SDoc
cannot_resolve_msg Ct
ct [ClsInst]
candidate_insts SDoc
binds_msg) }

  | [InstMatch] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InstMatch]
unsafe_overlapped   -- Some matches => overlap errors
  = (ReportErrCtxt, SDoc) -> TcM (ReportErrCtxt, SDoc)
forall (m :: * -> *) a. Monad m => a -> m a
return (ReportErrCtxt
ctxt, SDoc
overlap_msg)

  | Bool
otherwise
  = (ReportErrCtxt, SDoc) -> TcM (ReportErrCtxt, SDoc)
forall (m :: * -> *) a. Monad m => a -> m a
return (ReportErrCtxt
ctxt, SDoc
safe_haskell_msg)
  where
    orig :: CtOrigin
orig          = Ct -> CtOrigin
ctOrigin Ct
ct
    pred :: Type
pred          = Ct -> Type
ctPred Ct
ct
    (clas :: Class
clas, tys :: [Type]
tys)   = HasDebugCallStack => Type -> (Class, [Type])
Type -> (Class, [Type])
getClassPredTys Type
pred
    ispecs :: [ClsInst]
ispecs        = [ClsInst
ispec | (ispec :: ClsInst
ispec, _) <- [InstMatch]
matches]
    unsafe_ispecs :: [ClsInst]
unsafe_ispecs = [ClsInst
ispec | (ispec :: ClsInst
ispec, _) <- [InstMatch]
unsafe_overlapped]
    useful_givens :: [Implication]
useful_givens = CtOrigin -> [Implication] -> [Implication]
discardProvCtxtGivens CtOrigin
orig ([Implication] -> [Implication]
getUserGivensFromImplics [Implication]
implics)
         -- useful_givens are the enclosing implications with non-empty givens,
         -- modulo the horrid discardProvCtxtGivens

    get_candidate_instances :: TcM [ClsInst]
    -- See Note [Report candidate instances]
    get_candidate_instances :: TcM [ClsInst]
get_candidate_instances
      | [ty :: Type
ty] <- [Type]
tys   -- Only try for single-parameter classes
      = do { InstEnvs
instEnvs <- TcM InstEnvs
tcGetInstEnvs
           ; [ClsInst] -> TcM [ClsInst]
forall (m :: * -> *) a. Monad m => a -> m a
return ((ClsInst -> Bool) -> [ClsInst] -> [ClsInst]
forall a. (a -> Bool) -> [a] -> [a]
filter (Type -> ClsInst -> Bool
is_candidate_inst Type
ty)
                            (InstEnvs -> Class -> [ClsInst]
classInstances InstEnvs
instEnvs Class
clas)) }
      | Bool
otherwise = [ClsInst] -> TcM [ClsInst]
forall (m :: * -> *) a. Monad m => a -> m a
return []

    is_candidate_inst :: Type -> ClsInst -> Bool
is_candidate_inst ty :: Type
ty inst :: ClsInst
inst -- See Note [Report candidate instances]
      | [other_ty :: Type
other_ty] <- ClsInst -> [Type]
is_tys ClsInst
inst
      , Just (tc1 :: TyCon
tc1, _) <- HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty
      , Just (tc2 :: TyCon
tc2, _) <- HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
other_ty
      = let n1 :: Name
n1 = TyCon -> Name
tyConName TyCon
tc1
            n2 :: Name
n2 = TyCon -> Name
tyConName TyCon
tc2
            different_names :: Bool
different_names = Name
n1 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
n2
            same_occ_names :: Bool
same_occ_names = Name -> OccName
nameOccName Name
n1 OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> OccName
nameOccName Name
n2
        in Bool
different_names Bool -> Bool -> Bool
&& Bool
same_occ_names
      | Bool
otherwise = Bool
False

    cannot_resolve_msg :: Ct -> [ClsInst] -> SDoc -> SDoc
    cannot_resolve_msg :: Ct -> [ClsInst] -> SDoc -> SDoc
cannot_resolve_msg ct :: Ct
ct candidate_insts :: [ClsInst]
candidate_insts binds_msg :: SDoc
binds_msg
      = [SDoc] -> SDoc
vcat [ SDoc
no_inst_msg
             , Int -> SDoc -> SDoc
nest 2 SDoc
extra_note
             , [SDoc] -> SDoc
vcat ([Implication] -> [SDoc]
pp_givens [Implication]
useful_givens)
             , Maybe SDoc
mb_patsyn_prov Maybe SDoc -> SDoc -> SDoc
forall a. Maybe a -> a -> a
`orElse` SDoc
empty
             , Bool -> SDoc -> SDoc
ppWhen (Bool
has_ambig_tvs Bool -> Bool -> Bool
&& Bool -> Bool
not ([ClsInst] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClsInst]
unifiers Bool -> Bool -> Bool
&& [Implication] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Implication]
useful_givens))
               ([SDoc] -> SDoc
vcat [ Bool -> SDoc -> SDoc
ppUnless Bool
lead_with_ambig SDoc
ambig_msg, SDoc
binds_msg, SDoc
potential_msg ])

             , Bool -> SDoc -> SDoc
ppWhen (Maybe SDoc -> Bool
forall a. Maybe a -> Bool
isNothing Maybe SDoc
mb_patsyn_prov) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                   -- Don't suggest fixes for the provided context of a pattern
                   -- synonym; the right fix is to bind more in the pattern
               [SDoc] -> SDoc
show_fixes (Bool -> Type -> [Implication] -> [SDoc]
ctxtFixes Bool
has_ambig_tvs Type
pred [Implication]
implics
                           [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [SDoc]
drv_fixes)
             , Bool -> SDoc -> SDoc
ppWhen (Bool -> Bool
not ([ClsInst] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClsInst]
candidate_insts))
               (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "There are instances for similar types:")
                   2 ([SDoc] -> SDoc
vcat ((ClsInst -> SDoc) -> [ClsInst] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ClsInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ClsInst]
candidate_insts))) ]
                   -- See Note [Report candidate instances]
      where
        orig :: CtOrigin
orig = Ct -> CtOrigin
ctOrigin Ct
ct
        -- See Note [Highlighting ambiguous type variables]
        lead_with_ambig :: Bool
lead_with_ambig = Bool
has_ambig_tvs Bool -> Bool -> Bool
&& Bool -> Bool
not ((TyCoVar -> Bool) -> [TyCoVar] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TyCoVar -> Bool
isRuntimeUnkSkol [TyCoVar]
ambig_tvs)
                        Bool -> Bool -> Bool
&& Bool -> Bool
not ([ClsInst] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClsInst]
unifiers) Bool -> Bool -> Bool
&& [Implication] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Implication]
useful_givens

        (has_ambig_tvs :: Bool
has_ambig_tvs, ambig_msg :: SDoc
ambig_msg) = Bool -> Ct -> (Bool, SDoc)
mkAmbigMsg Bool
lead_with_ambig Ct
ct
        ambig_tvs :: [TyCoVar]
ambig_tvs = ([TyCoVar] -> [TyCoVar] -> [TyCoVar])
-> ([TyCoVar], [TyCoVar]) -> [TyCoVar]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [TyCoVar] -> [TyCoVar] -> [TyCoVar]
forall a. [a] -> [a] -> [a]
(++) (Ct -> ([TyCoVar], [TyCoVar])
getAmbigTkvs Ct
ct)

        no_inst_msg :: SDoc
no_inst_msg
          | Bool
lead_with_ambig
          = SDoc
ambig_msg SDoc -> SDoc -> SDoc
<+> CtOrigin -> SDoc
pprArising CtOrigin
orig
              SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "prevents the constraint" SDoc -> SDoc -> SDoc
<+>  SDoc -> SDoc
quotes (Type -> SDoc
pprParendType Type
pred)
              SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "from being solved."

          | [Implication] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Implication]
useful_givens
          = CtOrigin -> SDoc -> SDoc
addArising CtOrigin
orig (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text "No instance for"
            SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprParendType Type
pred

          | Bool
otherwise
          = CtOrigin -> SDoc -> SDoc
addArising CtOrigin
orig (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text "Could not deduce"
            SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprParendType Type
pred

        potential_msg :: SDoc
potential_msg
          = Bool -> SDoc -> SDoc
ppWhen (Bool -> Bool
not ([ClsInst] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClsInst]
unifiers) Bool -> Bool -> Bool
&& CtOrigin -> Bool
want_potential CtOrigin
orig) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
            (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \dflags :: DynFlags
dflags ->
            (PprStyle -> SDoc) -> SDoc
getPprStyle ((PprStyle -> SDoc) -> SDoc) -> (PprStyle -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \sty :: PprStyle
sty ->
            DynFlags -> PprStyle -> SDoc -> [ClsInst] -> SDoc
pprPotentials DynFlags
dflags PprStyle
sty SDoc
potential_hdr [ClsInst]
unifiers

        potential_hdr :: SDoc
potential_hdr
          = [SDoc] -> SDoc
vcat [ Bool -> SDoc -> SDoc
ppWhen Bool
lead_with_ambig (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                     String -> SDoc
text "Probable fix: use a type annotation to specify what"
                     SDoc -> SDoc -> SDoc
<+> [TyCoVar] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [TyCoVar]
ambig_tvs SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "should be."
                 , String -> SDoc
text "These potential instance" SDoc -> SDoc -> SDoc
<> [ClsInst] -> SDoc
forall a. [a] -> SDoc
plural [ClsInst]
unifiers
                   SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "exist:"]

        mb_patsyn_prov :: Maybe SDoc
        mb_patsyn_prov :: Maybe SDoc
mb_patsyn_prov
          | Bool -> Bool
not Bool
lead_with_ambig
          , ProvCtxtOrigin PSB{ psb_def :: forall idL idR. PatSynBind idL idR -> LPat idR
psb_def = (LPat GhcRn -> Located (SrcSpanLess (LPat GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ pat :: SrcSpanLess (LPat GhcRn)
pat) } <- CtOrigin
orig
          = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just ([SDoc] -> SDoc
vcat [ String -> SDoc
text "In other words, a successful match on the pattern"
                       , Int -> SDoc -> SDoc
nest 2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ LPat GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpanLess (LPat GhcRn)
LPat GhcRn
pat
                       , String -> SDoc
text "does not provide the constraint" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprParendType Type
pred ])
          | Bool
otherwise = Maybe SDoc
forall a. Maybe a
Nothing

    -- Report "potential instances" only when the constraint arises
    -- directly from the user's use of an overloaded function
    want_potential :: CtOrigin -> Bool
want_potential (TypeEqOrigin {}) = Bool
False
    want_potential _                 = Bool
True

    extra_note :: SDoc
extra_note | (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Type -> Bool
isFunTy (TyCon -> [Type] -> [Type]
filterOutInvisibleTypes (Class -> TyCon
classTyCon Class
clas) [Type]
tys)
               = String -> SDoc
text "(maybe you haven't applied a function to enough arguments?)"
               | Class -> Name
className Class
clas Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
typeableClassName  -- Avoid mysterious "No instance for (Typeable T)
               , [_,ty :: Type
ty] <- [Type]
tys                        -- Look for (Typeable (k->*) (T k))
               , Just (tc :: TyCon
tc,_) <- HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty
               , Bool -> Bool
not (TyCon -> Bool
isTypeFamilyTyCon TyCon
tc)
               = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "GHC can't yet do polykinded")
                    2 (String -> SDoc
text "Typeable" SDoc -> SDoc -> SDoc
<+>
                       SDoc -> SDoc
parens (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind Type
ty)))
               | Bool
otherwise
               = SDoc
empty

    drv_fixes :: [SDoc]
drv_fixes = case CtOrigin
orig of
                   DerivClauseOrigin                  -> [Bool -> SDoc
drv_fix Bool
False]
                   StandAloneDerivOrigin              -> [Bool -> SDoc
drv_fix Bool
True]
                   DerivOriginDC _ _       standalone :: Bool
standalone -> [Bool -> SDoc
drv_fix Bool
standalone]
                   DerivOriginCoerce _ _ _ standalone :: Bool
standalone -> [Bool -> SDoc
drv_fix Bool
standalone]
                   _                -> []

    drv_fix :: Bool -> SDoc
drv_fix standalone_wildcard :: Bool
standalone_wildcard
      | Bool
standalone_wildcard
      = String -> SDoc
text "fill in the wildcard constraint yourself"
      | Bool
otherwise
      = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "use a standalone 'deriving instance' declaration,")
           2 (String -> SDoc
text "so you can specify the instance context yourself")

    -- Normal overlap error
    overlap_msg :: SDoc
overlap_msg
      = ASSERT( not (null matches) )
        [SDoc] -> SDoc
vcat [  CtOrigin -> SDoc -> SDoc
addArising CtOrigin
orig (String -> SDoc
text "Overlapping instances for"
                                SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprType (Class -> [Type] -> Type
mkClassPred Class
clas [Type]
tys))

             ,  Bool -> SDoc -> SDoc
ppUnless ([SDoc] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SDoc]
matching_givens) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                  [SDoc] -> SDoc
sep [String -> SDoc
text "Matching givens (or their superclasses):"
                      , Int -> SDoc -> SDoc
nest 2 ([SDoc] -> SDoc
vcat [SDoc]
matching_givens)]

             ,  (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \dflags :: DynFlags
dflags ->
                (PprStyle -> SDoc) -> SDoc
getPprStyle ((PprStyle -> SDoc) -> SDoc) -> (PprStyle -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \sty :: PprStyle
sty ->
                DynFlags -> PprStyle -> SDoc -> [ClsInst] -> SDoc
pprPotentials DynFlags
dflags PprStyle
sty (String -> SDoc
text "Matching instances:") ([ClsInst] -> SDoc) -> [ClsInst] -> SDoc
forall a b. (a -> b) -> a -> b
$
                [ClsInst]
ispecs [ClsInst] -> [ClsInst] -> [ClsInst]
forall a. [a] -> [a] -> [a]
++ [ClsInst]
unifiers

             ,  Bool -> SDoc -> SDoc
ppWhen ([SDoc] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SDoc]
matching_givens Bool -> Bool -> Bool
&& [InstMatch] -> Bool
forall a. [a] -> Bool
isSingleton [InstMatch]
matches Bool -> Bool -> Bool
&& [ClsInst] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClsInst]
unifiers) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                -- 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.
                  [SDoc] -> SDoc
sep [ String -> SDoc
text "There exists a (perhaps superclass) match:"
                      , Int -> SDoc -> SDoc
nest 2 ([SDoc] -> SDoc
vcat ([Implication] -> [SDoc]
pp_givens [Implication]
useful_givens))]

             ,  Bool -> SDoc -> SDoc
ppWhen ([InstMatch] -> Bool
forall a. [a] -> Bool
isSingleton [InstMatch]
matches) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                SDoc -> SDoc
parens ([SDoc] -> SDoc
vcat [ String -> SDoc
text "The choice depends on the instantiation of" SDoc -> SDoc -> SDoc
<+>
                                  SDoc -> SDoc
quotes ((TyCoVar -> SDoc) -> [TyCoVar] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas TyCoVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([Type] -> [TyCoVar]
tyCoVarsOfTypesList [Type]
tys))
                             , Bool -> SDoc -> SDoc
ppWhen ([SDoc] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([SDoc]
matching_givens)) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                               [SDoc] -> SDoc
vcat [ String -> SDoc
text "To pick the first instance above, use IncoherentInstances"
                                    , String -> SDoc
text "when compiling the other instance declarations"]
                        ])]

    matching_givens :: [SDoc]
matching_givens = (Implication -> Maybe SDoc) -> [Implication] -> [SDoc]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Implication -> Maybe SDoc
matchable [Implication]
useful_givens

    matchable :: Implication -> Maybe SDoc
matchable implic :: Implication
implic@(Implic { ic_given :: Implication -> [TyCoVar]
ic_given = [TyCoVar]
evvars, ic_info :: Implication -> SkolemInfo
ic_info = SkolemInfo
skol_info })
      = case [Type]
ev_vars_matching of
             [] -> Maybe SDoc
forall a. Maybe a
Nothing
             _  -> SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> Int -> SDoc -> SDoc
hang ([Type] -> SDoc
pprTheta [Type]
ev_vars_matching)
                            2 ([SDoc] -> SDoc
sep [ String -> SDoc
text "bound by" SDoc -> SDoc -> SDoc
<+> SkolemInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr SkolemInfo
skol_info
                                   , String -> SDoc
text "at" SDoc -> SDoc -> SDoc
<+>
                                     RealSrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TcLclEnv -> RealSrcSpan
tcl_loc (Implication -> TcLclEnv
implicLclEnv Implication
implic)) ])
        where ev_vars_matching :: [Type]
ev_vars_matching = (Type -> Bool) -> [Type] -> [Type]
forall a. (a -> Bool) -> [a] -> [a]
filter Type -> Bool
ev_var_matches ((TyCoVar -> Type) -> [TyCoVar] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyCoVar -> Type
evVarPred [TyCoVar]
evvars)
              ev_var_matches :: Type -> Bool
ev_var_matches ty :: Type
ty = case Type -> Maybe (Class, [Type])
getClassPredTys_maybe Type
ty of
                 Just (clas' :: Class
clas', tys' :: [Type]
tys')
                   | Class
clas' Class -> Class -> Bool
forall a. Eq a => a -> a -> Bool
== Class
clas
                   , Just _ <- [Type] -> [Type] -> Maybe TCvSubst
tcMatchTys [Type]
tys [Type]
tys'
                   -> Bool
True
                   | Bool
otherwise
                   -> (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Type -> Bool
ev_var_matches (Class -> [Type] -> [Type]
immSuperClasses Class
clas' [Type]
tys')
                 Nothing -> Bool
False

    -- Overlap error because of Safe Haskell (first
    -- match should be the most specific match)
    safe_haskell_msg :: SDoc
safe_haskell_msg
     = ASSERT( matches `lengthIs` 1 && not (null unsafe_ispecs) )
       [SDoc] -> SDoc
vcat [ CtOrigin -> SDoc -> SDoc
addArising CtOrigin
orig (String -> SDoc
text "Unsafe overlapping instances for"
                       SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprType (Class -> [Type] -> Type
mkClassPred Class
clas [Type]
tys))
            , [SDoc] -> SDoc
sep [String -> SDoc
text "The matching instance is:",
                   Int -> SDoc -> SDoc
nest 2 (ClsInst -> SDoc
pprInstance (ClsInst -> SDoc) -> ClsInst -> SDoc
forall a b. (a -> b) -> a -> b
$ [ClsInst] -> ClsInst
forall a. [a] -> a
head [ClsInst]
ispecs)]
            , [SDoc] -> SDoc
vcat [ String -> SDoc
text "It is compiled in a Safe module and as such can only"
                   , String -> SDoc
text "overlap instances from the same module, however it"
                   , String -> SDoc
text "overlaps the following instances from different" SDoc -> SDoc -> SDoc
<+>
                     String -> SDoc
text "modules:"
                   , Int -> SDoc -> SDoc
nest 2 ([SDoc] -> SDoc
vcat [[ClsInst] -> SDoc
pprInstances ([ClsInst] -> SDoc) -> [ClsInst] -> SDoc
forall a b. (a -> b) -> a -> b
$ [ClsInst]
unsafe_ispecs])
                   ]
            ]


ctxtFixes :: Bool -> PredType -> [Implication] -> [SDoc]
ctxtFixes :: Bool -> Type -> [Implication] -> [SDoc]
ctxtFixes has_ambig_tvs :: Bool
has_ambig_tvs pred :: Type
pred implics :: [Implication]
implics
  | Bool -> Bool
not Bool
has_ambig_tvs
  , Type -> Bool
isTyVarClassPred Type
pred
  , (skol :: SkolemInfo
skol:skols :: [SkolemInfo]
skols) <- [Implication] -> Type -> [SkolemInfo]
usefulContext [Implication]
implics Type
pred
  , let what :: SDoc
what | [SkolemInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SkolemInfo]
skols
             , SigSkol (PatSynCtxt {}) _ _ <- SkolemInfo
skol
             = String -> SDoc
text "\"required\""
             | Bool
otherwise
             = SDoc
empty
  = [[SDoc] -> SDoc
sep [ String -> SDoc
text "add" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprParendType Type
pred
           SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "to the" SDoc -> SDoc -> SDoc
<+> SDoc
what SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "context of"
         , Int -> SDoc -> SDoc
nest 2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ SkolemInfo -> SDoc
ppr_skol SkolemInfo
skol SDoc -> SDoc -> SDoc
$$
                    [SDoc] -> SDoc
vcat [ String -> SDoc
text "or" SDoc -> SDoc -> SDoc
<+> SkolemInfo -> SDoc
ppr_skol SkolemInfo
skol
                         | SkolemInfo
skol <- [SkolemInfo]
skols ] ] ]
  | Bool
otherwise = []
  where
    ppr_skol :: SkolemInfo -> SDoc
ppr_skol (PatSkol (RealDataCon dc :: DataCon
dc) _) = String -> SDoc
text "the data constructor" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
dc)
    ppr_skol (PatSkol (PatSynCon ps :: PatSyn
ps)   _) = String -> SDoc
text "the pattern synonym"  SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (PatSyn -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatSyn
ps)
    ppr_skol skol_info :: SkolemInfo
skol_info = SkolemInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr SkolemInfo
skol_info

discardProvCtxtGivens :: CtOrigin -> [UserGiven] -> [UserGiven]
discardProvCtxtGivens :: CtOrigin -> [Implication] -> [Implication]
discardProvCtxtGivens orig :: CtOrigin
orig givens :: [Implication]
givens  -- See Note [discardProvCtxtGivens]
  | ProvCtxtOrigin (PSB {psb_id :: forall idL idR. PatSynBind idL idR -> Located (IdP idL)
psb_id = (Located (IdP GhcRn) -> Located (SrcSpanLess (Located Name))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ name :: SrcSpanLess (Located Name)
name)}) <- CtOrigin
orig
  = (Implication -> Bool) -> [Implication] -> [Implication]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (Name -> Implication -> Bool
discard Name
SrcSpanLess (Located Name)
name) [Implication]
givens
  | Bool
otherwise
  = [Implication]
givens
  where
    discard :: Name -> Implication -> Bool
discard n :: Name
n (Implic { ic_info :: Implication -> SkolemInfo
ic_info = SigSkol (PatSynCtxt n' :: Name
n') _ _ }) = Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n'
    discard _ _                                                  = Bool
False

usefulContext :: [Implication] -> PredType -> [SkolemInfo]
-- usefulContext picks out the implications whose context
-- the programmer might plausibly augment to solve 'pred'
usefulContext :: [Implication] -> Type -> [SkolemInfo]
usefulContext implics :: [Implication]
implics pred :: Type
pred
  = [Implication] -> [SkolemInfo]
go [Implication]
implics
  where
    pred_tvs :: VarSet
pred_tvs = Type -> VarSet
tyCoVarsOfType Type
pred
    go :: [Implication] -> [SkolemInfo]
go [] = []
    go (ic :: Implication
ic : ics :: [Implication]
ics)
       | Implication -> Bool
implausible Implication
ic = [SkolemInfo]
rest
       | Bool
otherwise      = Implication -> SkolemInfo
ic_info Implication
ic SkolemInfo -> [SkolemInfo] -> [SkolemInfo]
forall a. a -> [a] -> [a]
: [SkolemInfo]
rest
       where
          -- Stop when the context binds a variable free in the predicate
          rest :: [SkolemInfo]
rest | (TyCoVar -> Bool) -> [TyCoVar] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TyCoVar -> VarSet -> Bool
`elemVarSet` VarSet
pred_tvs) (Implication -> [TyCoVar]
ic_skols Implication
ic) = []
               | Bool
otherwise                                 = [Implication] -> [SkolemInfo]
go [Implication]
ics

    implausible :: Implication -> Bool
implausible ic :: Implication
ic
      | [TyCoVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Implication -> [TyCoVar]
ic_skols Implication
ic)            = Bool
True
      | SkolemInfo -> Bool
implausible_info (Implication -> SkolemInfo
ic_info Implication
ic) = Bool
True
      | Bool
otherwise                     = Bool
False

    implausible_info :: SkolemInfo -> Bool
implausible_info (SigSkol (InfSigCtxt {}) _ _) = Bool
True
    implausible_info _                             = Bool
False
    -- Do not suggest adding constraints to an *inferred* type signature

{- Note [Report candidate instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If we have an unsolved (Num Int), where `Int` is not the Prelude Int,
but comes from some other module, then it may be helpful to point out
that there are some similarly named instances elsewhere.  So we get
something like
    No instance for (Num Int) arising from the literal ‘3’
    There are instances for similar types:
      instance Num GHC.Types.Int -- Defined in ‘GHC.Num’
Discussion in Trac #9611.

Note [Highlighting ambiguous type variables]
~-------------------------------------------
When we encounter ambiguous type variables (i.e. type variables
that remain metavariables after type inference), we need a few more
conditions before we can reason that *ambiguity* prevents constraints
from being solved:
  - We can't have any givens, as encountering a typeclass error
    with given constraints just means we couldn't deduce
    a solution satisfying those constraints and as such couldn't
    bind the type variable to a known type.
  - If we don't have any unifiers, we don't even have potential
    instances from which an ambiguity could arise.
  - Lastly, I don't want to mess with error reporting for
    unknown runtime types so we just fall back to the old message there.
Once these conditions are satisfied, we can safely say that ambiguity prevents
the constraint from being solved.

Note [discardProvCtxtGivens]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
In most situations we call all enclosing implications "useful". There is one
exception, and that is when the constraint that causes the error is from the
"provided" context of a pattern synonym declaration:

  pattern Pat :: (Num a, Eq a) => Show a   => a -> Maybe a
             --  required      => provided => type
  pattern Pat x <- (Just x, 4)

When checking the pattern RHS we must check that it does actually bind all
the claimed "provided" constraints; in this case, does the pattern (Just x, 4)
bind the (Show a) constraint.  Answer: no!

But the implication we generate for this will look like
   forall a. (Num a, Eq a) => [W] Show a
because when checking the pattern we must make the required
constraints available, since they are needed to match the pattern (in
this case the literal '4' needs (Num a, Eq a)).

BUT we don't want to suggest adding (Show a) to the "required" constraints
of the pattern synonym, thus:
  pattern Pat :: (Num a, Eq a, Show a) => Show a => a -> Maybe a
It would then typecheck but it's silly.  We want the /pattern/ to bind
the alleged "provided" constraints, Show a.

So we suppress that Implication in discardProvCtxtGivens.  It's
painfully ad-hoc but the truth is that adding it to the "required"
constraints would work.  Suprressing it solves two problems.  First,
we never tell the user that we could not deduce a "provided"
constraint from the "required" context. Second, we never give a
possible fix that suggests to add a "provided" constraint to the
"required" context.

For example, without this distinction the above code gives a bad error
message (showing both problems):

  error: Could not deduce (Show a) ... from the context: (Eq a)
         ... Possible fix: add (Show a) to the context of
         the signature for pattern synonym `Pat' ...

-}

show_fixes :: [SDoc] -> SDoc
show_fixes :: [SDoc] -> SDoc
show_fixes []     = SDoc
empty
show_fixes (f :: SDoc
f:fs :: [SDoc]
fs) = [SDoc] -> SDoc
sep [ String -> SDoc
text "Possible fix:"
                        , Int -> SDoc -> SDoc
nest 2 ([SDoc] -> SDoc
vcat (SDoc
f SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: (SDoc -> SDoc) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> SDoc
text "or" SDoc -> SDoc -> SDoc
<+>) [SDoc]
fs))]

pprPotentials :: DynFlags -> PprStyle -> SDoc -> [ClsInst] -> SDoc
-- See Note [Displaying potential instances]
pprPotentials :: DynFlags -> PprStyle -> SDoc -> [ClsInst] -> SDoc
pprPotentials dflags :: DynFlags
dflags sty :: PprStyle
sty herald :: SDoc
herald insts :: [ClsInst]
insts
  | [ClsInst] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClsInst]
insts
  = SDoc
empty

  | [ClsInst] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClsInst]
show_these
  = SDoc -> Int -> SDoc -> SDoc
hang SDoc
herald
       2 ([SDoc] -> SDoc
vcat [ SDoc -> SDoc
not_in_scope_msg SDoc
empty
               , SDoc
flag_hint ])

  | Bool
otherwise
  = SDoc -> Int -> SDoc -> SDoc
hang SDoc
herald
       2 ([SDoc] -> SDoc
vcat [ [ClsInst] -> SDoc
pprInstances [ClsInst]
show_these
               , Bool -> SDoc -> SDoc
ppWhen (Int
n_in_scope_hidden Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                 String -> SDoc
text "...plus"
                   SDoc -> SDoc -> SDoc
<+> Int -> SDoc -> SDoc
speakNOf Int
n_in_scope_hidden (String -> SDoc
text "other")
               , SDoc -> SDoc
not_in_scope_msg (String -> SDoc
text "...plus")
               , SDoc
flag_hint ])
  where
    n_show :: Int
n_show = 3 :: Int
    show_potentials :: Bool
show_potentials = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_PrintPotentialInstances DynFlags
dflags

    (in_scope :: [ClsInst]
in_scope, not_in_scope :: [ClsInst]
not_in_scope) = (ClsInst -> Bool) -> [ClsInst] -> ([ClsInst], [ClsInst])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ClsInst -> Bool
inst_in_scope [ClsInst]
insts
    sorted :: [ClsInst]
sorted = (ClsInst -> ClsInst -> Ordering) -> [ClsInst] -> [ClsInst]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ClsInst -> ClsInst -> Ordering
fuzzyClsInstCmp [ClsInst]
in_scope
    show_these :: [ClsInst]
show_these | Bool
show_potentials = [ClsInst]
sorted
               | Bool
otherwise       = Int -> [ClsInst] -> [ClsInst]
forall a. Int -> [a] -> [a]
take Int
n_show [ClsInst]
sorted
    n_in_scope_hidden :: Int
n_in_scope_hidden = [ClsInst] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ClsInst]
sorted Int -> Int -> Int
forall a. Num a => a -> a -> a
- [ClsInst] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ClsInst]
show_these

       -- "in scope" means that all the type constructors
       -- are lexically in scope; these instances are likely
       -- to be more useful
    inst_in_scope :: ClsInst -> Bool
    inst_in_scope :: ClsInst -> Bool
inst_in_scope cls_inst :: ClsInst
cls_inst = (Name -> Bool) -> NameSet -> Bool
nameSetAll Name -> Bool
name_in_scope (NameSet -> Bool) -> NameSet -> Bool
forall a b. (a -> b) -> a -> b
$
                             [Type] -> NameSet
orphNamesOfTypes (ClsInst -> [Type]
is_tys ClsInst
cls_inst)

    name_in_scope :: Name -> Bool
name_in_scope name :: Name
name
      | Name -> Bool
isBuiltInSyntax Name
name
      = Bool
True -- E.g. (->)
      | Just mod :: Module
mod <- Name -> Maybe Module
nameModule_maybe Name
name
      = QualifyName -> Bool
qual_in_scope (PprStyle -> QueryQualifyName
qualName PprStyle
sty Module
mod (Name -> OccName
nameOccName Name
name))
      | Bool
otherwise
      = Bool
True

    qual_in_scope :: QualifyName -> Bool
    qual_in_scope :: QualifyName -> Bool
qual_in_scope NameUnqual    = Bool
True
    qual_in_scope (NameQual {}) = Bool
True
    qual_in_scope _             = Bool
False

    not_in_scope_msg :: SDoc -> SDoc
not_in_scope_msg herald :: SDoc
herald
      | [ClsInst] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClsInst]
not_in_scope
      = SDoc
empty
      | Bool
otherwise
      = SDoc -> Int -> SDoc -> SDoc
hang (SDoc
herald SDoc -> SDoc -> SDoc
<+> Int -> SDoc -> SDoc
speakNOf ([ClsInst] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ClsInst]
not_in_scope) (String -> SDoc
text "instance")
                     SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "involving out-of-scope types")
           2 (Bool -> SDoc -> SDoc
ppWhen Bool
show_potentials ([ClsInst] -> SDoc
pprInstances [ClsInst]
not_in_scope))

    flag_hint :: SDoc
flag_hint = Bool -> SDoc -> SDoc
ppUnless (Bool
show_potentials Bool -> Bool -> Bool
|| [ClsInst] -> [ClsInst] -> Bool
forall a b. [a] -> [b] -> Bool
equalLength [ClsInst]
show_these [ClsInst]
insts) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                String -> SDoc
text "(use -fprint-potential-instances to see them all)"

{- Note [Displaying potential instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When showing a list of instances for
  - overlapping instances (show ones that match)
  - no such instance (show ones that could match)
we want to give it a bit of structure.  Here's the plan

* Say that an instance is "in scope" if all of the
  type constructors it mentions are lexically in scope.
  These are the ones most likely to be useful to the programmer.

* Show at most n_show in-scope instances,
  and summarise the rest ("plus 3 others")

* Summarise the not-in-scope instances ("plus 4 not in scope")

* Add the flag -fshow-potential-instances which replaces the
  summary with the full list
-}

{-
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 the code in TcCanonical because that's in
the TcS monad, and we are in TcM here.

Note [Kind arguments in error messages]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It can be terribly confusing to get an error message like (Trac #9171)

    Couldn't match expected type ‘GetParam Base (GetParam Base Int)’
                with actual type ‘GetParam Base (GetParam Base Int)’

The reason may be that the kinds don't match up.  Typically you'll get
more useful information, but not when it's as a result of ambiguity.

To mitigate this, GHC attempts to enable the -fprint-explicit-kinds flag
whenever any error message arises due to a kind mismatch. This means that
the above error message would instead be displayed as:

    Couldn't match expected type
                  ‘GetParam @* @k2 @* Base (GetParam @* @* @k2 Base Int)’
                with actual type
                  ‘GetParam @* @k20 @* Base (GetParam @* @* @k20 Base Int)’

Which makes it clearer that the culprit is the mismatch between `k2` and `k20`.
-}

mkAmbigMsg :: Bool -- True when message has to be at beginning of sentence
           -> Ct -> (Bool, SDoc)
mkAmbigMsg :: Bool -> Ct -> (Bool, SDoc)
mkAmbigMsg prepend_msg :: Bool
prepend_msg ct :: Ct
ct
  | [TyCoVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyCoVar]
ambig_kvs Bool -> Bool -> Bool
&& [TyCoVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyCoVar]
ambig_tvs = (Bool
False, SDoc
empty)
  | Bool
otherwise                        = (Bool
True,  SDoc
msg)
  where
    (ambig_kvs :: [TyCoVar]
ambig_kvs, ambig_tvs :: [TyCoVar]
ambig_tvs) = Ct -> ([TyCoVar], [TyCoVar])
getAmbigTkvs Ct
ct

    msg :: SDoc
msg |  (TyCoVar -> Bool) -> [TyCoVar] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TyCoVar -> Bool
isRuntimeUnkSkol [TyCoVar]
ambig_kvs  -- See Note [Runtime skolems]
        Bool -> Bool -> Bool
|| (TyCoVar -> Bool) -> [TyCoVar] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TyCoVar -> Bool
isRuntimeUnkSkol [TyCoVar]
ambig_tvs
        = [SDoc] -> SDoc
vcat [ String -> SDoc
text "Cannot resolve unknown runtime type"
                 SDoc -> SDoc -> SDoc
<> [TyCoVar] -> SDoc
forall a. [a] -> SDoc
plural [TyCoVar]
ambig_tvs SDoc -> SDoc -> SDoc
<+> [TyCoVar] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [TyCoVar]
ambig_tvs
               , String -> SDoc
text "Use :print or :force to determine these types"]

        | Bool -> Bool
not ([TyCoVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyCoVar]
ambig_tvs)
        = SDoc -> [TyCoVar] -> SDoc
forall a. Outputable a => SDoc -> [a] -> SDoc
pp_ambig (String -> SDoc
text "type") [TyCoVar]
ambig_tvs

        | Bool
otherwise
        = SDoc -> [TyCoVar] -> SDoc
forall a. Outputable a => SDoc -> [a] -> SDoc
pp_ambig (String -> SDoc
text "kind") [TyCoVar]
ambig_kvs

    pp_ambig :: SDoc -> [a] -> SDoc
pp_ambig what :: SDoc
what tkvs :: [a]
tkvs
      | Bool
prepend_msg -- "Ambiguous type variable 't0'"
      = String -> SDoc
text "Ambiguous" SDoc -> SDoc -> SDoc
<+> SDoc
what SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "variable"
        SDoc -> SDoc -> SDoc
<> [a] -> SDoc
forall a. [a] -> SDoc
plural [a]
tkvs SDoc -> SDoc -> SDoc
<+> [a] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [a]
tkvs

      | Bool
otherwise -- "The type variable 't0' is ambiguous"
      = String -> SDoc
text "The" SDoc -> SDoc -> SDoc
<+> SDoc
what SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "variable" SDoc -> SDoc -> SDoc
<> [a] -> SDoc
forall a. [a] -> SDoc
plural [a]
tkvs
        SDoc -> SDoc -> SDoc
<+> [a] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [a]
tkvs SDoc -> SDoc -> SDoc
<+> [a] -> SDoc
forall a. [a] -> SDoc
is_or_are [a]
tkvs SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "ambiguous"

    is_or_are :: [a] -> SDoc
is_or_are [_] = String -> SDoc
text "is"
    is_or_are _   = String -> SDoc
text "are"

pprSkols :: ReportErrCtxt -> [TcTyVar] -> SDoc
pprSkols :: ReportErrCtxt -> [TyCoVar] -> SDoc
pprSkols ctxt :: ReportErrCtxt
ctxt tvs :: [TyCoVar]
tvs
  = [SDoc] -> SDoc
vcat (((Implication, [TyCoVar]) -> SDoc)
-> [(Implication, [TyCoVar])] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Implication, [TyCoVar]) -> SDoc
forall a.
(Outputable a, NamedThing a) =>
(Implication, [a]) -> SDoc
pp_one ([Implication] -> [TyCoVar] -> [(Implication, [TyCoVar])]
getSkolemInfo (ReportErrCtxt -> [Implication]
cec_encl ReportErrCtxt
ctxt) [TyCoVar]
tvs))
  where
    pp_one :: (Implication, [a]) -> SDoc
pp_one (Implic { ic_info :: Implication -> SkolemInfo
ic_info = SkolemInfo
skol_info }, tvs :: [a]
tvs)
      | SkolemInfo
UnkSkol <- SkolemInfo
skol_info
      = SDoc -> Int -> SDoc -> SDoc
hang ([a] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [a]
tvs)
           2 ([a] -> String -> String -> SDoc
forall a. [a] -> String -> String -> SDoc
is_or_are [a]
tvs "an" "unknown")
      | Bool
otherwise
      = [SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang ([a] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [a]
tvs)
                  2 ([a] -> String -> String -> SDoc
forall a. [a] -> String -> String -> SDoc
is_or_are [a]
tvs "a"  "rigid" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "bound by")
             , Int -> SDoc -> SDoc
nest 2 (SkolemInfo -> SDoc
pprSkolInfo SkolemInfo
skol_info)
             , Int -> SDoc -> SDoc
nest 2 (String -> SDoc
text "at" SDoc -> SDoc -> SDoc
<+> SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((SrcSpan -> SrcSpan -> SrcSpan) -> [SrcSpan] -> SrcSpan
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans ((a -> SrcSpan) -> [a] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map a -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan [a]
tvs))) ]

    is_or_are :: [a] -> String -> String -> SDoc
is_or_are [_] article :: String
article adjective :: String
adjective = String -> SDoc
text "is" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
article SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
adjective
                                      SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "type variable"
    is_or_are _   _       adjective :: String
adjective = String -> SDoc
text "are" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
adjective
                                      SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "type variables"

getAmbigTkvs :: Ct -> ([Var],[Var])
getAmbigTkvs :: Ct -> ([TyCoVar], [TyCoVar])
getAmbigTkvs ct :: Ct
ct
  = (TyCoVar -> Bool) -> [TyCoVar] -> ([TyCoVar], [TyCoVar])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (TyCoVar -> VarSet -> Bool
`elemVarSet` VarSet
dep_tkv_set) [TyCoVar]
ambig_tkvs
  where
    tkvs :: [TyCoVar]
tkvs       = Ct -> [TyCoVar]
tyCoVarsOfCtList Ct
ct
    ambig_tkvs :: [TyCoVar]
ambig_tkvs = (TyCoVar -> Bool) -> [TyCoVar] -> [TyCoVar]
forall a. (a -> Bool) -> [a] -> [a]
filter TyCoVar -> Bool
isAmbiguousTyVar [TyCoVar]
tkvs
    dep_tkv_set :: VarSet
dep_tkv_set = [Type] -> VarSet
tyCoVarsOfTypes ((TyCoVar -> Type) -> [TyCoVar] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyCoVar -> Type
tyVarKind [TyCoVar]
tkvs)

getSkolemInfo :: [Implication] -> [TcTyVar]
              -> [(Implication, [TcTyVar])]
-- Get the skolem info for some type variables
-- from the implication constraints that bind them
--
-- In the returned (implic, tvs) pairs, the 'tvs' part is non-empty
getSkolemInfo :: [Implication] -> [TyCoVar] -> [(Implication, [TyCoVar])]
getSkolemInfo _ []
  = []

getSkolemInfo [] tvs :: [TyCoVar]
tvs
  = String -> SDoc -> [(Implication, [TyCoVar])]
forall a. HasCallStack => String -> SDoc -> a
pprPanic "No skolem info:" ([TyCoVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyCoVar]
tvs)

getSkolemInfo (implic :: Implication
implic:implics :: [Implication]
implics) tvs :: [TyCoVar]
tvs
  | [TyCoVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyCoVar]
tvs_here =                      [Implication] -> [TyCoVar] -> [(Implication, [TyCoVar])]
getSkolemInfo [Implication]
implics [TyCoVar]
tvs
  | Bool
otherwise     = (Implication
implic, [TyCoVar]
tvs_here) (Implication, [TyCoVar])
-> [(Implication, [TyCoVar])] -> [(Implication, [TyCoVar])]
forall a. a -> [a] -> [a]
: [Implication] -> [TyCoVar] -> [(Implication, [TyCoVar])]
getSkolemInfo [Implication]
implics [TyCoVar]
tvs_other
  where
    (tvs_here :: [TyCoVar]
tvs_here, tvs_other :: [TyCoVar]
tvs_other) = (TyCoVar -> Bool) -> [TyCoVar] -> ([TyCoVar], [TyCoVar])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (TyCoVar -> [TyCoVar] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Implication -> [TyCoVar]
ic_skols Implication
implic) [TyCoVar]
tvs

-----------------------
-- relevantBindings looks at the value environment and finds values whose
-- types mention any of the offending type variables.  It has to be
-- careful to zonk the Id's type first, so it has to be in the monad.
-- We must be careful to pass it a zonked type variable, too.
--
-- We always remove closed top-level bindings, though,
-- since they are never relevant (cf Trac #8233)

relevantBindings :: Bool  -- True <=> filter by tyvar; False <=> no filtering
                          -- See Trac #8191
                 -> ReportErrCtxt -> Ct
                 -> TcM (ReportErrCtxt, SDoc, Ct)
-- Also returns the zonked and tidied CtOrigin of the constraint
relevantBindings :: Bool -> ReportErrCtxt -> Ct -> TcM (ReportErrCtxt, SDoc, Ct)
relevantBindings want_filtering :: Bool
want_filtering ctxt :: ReportErrCtxt
ctxt ct :: Ct
ct
  = do { DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; (env1 :: TidyEnv
env1, tidy_orig :: CtOrigin
tidy_orig) <- TidyEnv -> CtOrigin -> TcM (TidyEnv, CtOrigin)
zonkTidyOrigin (ReportErrCtxt -> TidyEnv
cec_tidy ReportErrCtxt
ctxt) (CtLoc -> CtOrigin
ctLocOrigin CtLoc
loc)
       ; let ct_tvs :: VarSet
ct_tvs = Ct -> VarSet
tyCoVarsOfCt Ct
ct VarSet -> VarSet -> VarSet
`unionVarSet` VarSet
extra_tvs

             -- For *kind* errors, report the relevant bindings of the
             -- enclosing *type* equality, because that's more useful for the programmer
             extra_tvs :: VarSet
extra_tvs = case CtOrigin
tidy_orig of
                             KindEqOrigin t1 :: Type
t1 m_t2 :: Maybe Type
m_t2 _ _ -> [Type] -> VarSet
tyCoVarsOfTypes ([Type] -> VarSet) -> [Type] -> VarSet
forall a b. (a -> b) -> a -> b
$
                                                         Type
t1 Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: Maybe Type -> [Type]
forall a. Maybe a -> [a]
maybeToList Maybe Type
m_t2
                             _                        -> VarSet
emptyVarSet
       ; String -> SDoc -> TcM ()
traceTc "relevantBindings" (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
           [SDoc] -> SDoc
vcat [ Ct -> SDoc
forall a. Outputable a => a -> SDoc
ppr Ct
ct
                , CtOrigin -> SDoc
pprCtOrigin (CtLoc -> CtOrigin
ctLocOrigin CtLoc
loc)
                , VarSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr VarSet
ct_tvs
                , (SDoc -> SDoc) -> [SDoc] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas SDoc -> SDoc
forall a. a -> a
id [ TyCoVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCoVar
id SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCoVar -> Type
idType TyCoVar
id)
                                   | TcIdBndr id :: TyCoVar
id _ <- TcLclEnv -> TcBinderStack
tcl_bndrs TcLclEnv
lcl_env ]
                , (SDoc -> SDoc) -> [SDoc] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas SDoc -> SDoc
forall a. a -> a
id
                    [ Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
id | TcIdBndr_ExpType id :: Name
id _ _ <- TcLclEnv -> TcBinderStack
tcl_bndrs TcLclEnv
lcl_env ] ]

       ; (tidy_env' :: TidyEnv
tidy_env', docs :: [SDoc]
docs, discards :: Bool
discards)
              <- DynFlags
-> TidyEnv
-> VarSet
-> Maybe Int
-> VarSet
-> [SDoc]
-> Bool
-> TcBinderStack
-> TcM (TidyEnv, [SDoc], Bool)
go DynFlags
dflags TidyEnv
env1 VarSet
ct_tvs (DynFlags -> Maybe Int
maxRelevantBinds DynFlags
dflags)
                    VarSet
emptyVarSet [] Bool
False
                    (TcBinderStack -> TcBinderStack
forall a. HasOccName a => [a] -> [a]
removeBindingShadowing (TcBinderStack -> TcBinderStack) -> TcBinderStack -> TcBinderStack
forall a b. (a -> b) -> a -> b
$ TcLclEnv -> TcBinderStack
tcl_bndrs TcLclEnv
lcl_env)
         -- tcl_bndrs has the innermost bindings first,
         -- which are probably the most relevant ones

       ; let doc :: SDoc
doc = Bool -> SDoc -> SDoc
ppUnless ([SDoc] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SDoc]
docs) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                   SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Relevant bindings include")
                      2 ([SDoc] -> SDoc
vcat [SDoc]
docs SDoc -> SDoc -> SDoc
$$ Bool -> SDoc -> SDoc
ppWhen Bool
discards SDoc
discardMsg)

             -- Put a zonked, tidied CtOrigin into the Ct
             loc' :: CtLoc
loc'  = CtLoc -> CtOrigin -> CtLoc
setCtLocOrigin CtLoc
loc CtOrigin
tidy_orig
             ct' :: Ct
ct'   = Ct -> CtLoc -> Ct
setCtLoc Ct
ct CtLoc
loc'
             ctxt' :: ReportErrCtxt
ctxt' = ReportErrCtxt
ctxt { cec_tidy :: TidyEnv
cec_tidy = TidyEnv
tidy_env' }

       ; (ReportErrCtxt, SDoc, Ct) -> TcM (ReportErrCtxt, SDoc, Ct)
forall (m :: * -> *) a. Monad m => a -> m a
return (ReportErrCtxt
ctxt', SDoc
doc, Ct
ct') }
  where
    ev :: CtEvidence
ev      = Ct -> CtEvidence
ctEvidence Ct
ct
    loc :: CtLoc
loc     = CtEvidence -> CtLoc
ctEvLoc CtEvidence
ev
    lcl_env :: TcLclEnv
lcl_env = CtLoc -> TcLclEnv
ctLocEnv CtLoc
loc

    run_out :: Maybe Int -> Bool
    run_out :: Maybe Int -> Bool
run_out Nothing = Bool
False
    run_out (Just n :: Int
n) = Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0

    dec_max :: Maybe Int -> Maybe Int
    dec_max :: Maybe Int -> Maybe Int
dec_max = (Int -> Int) -> Maybe Int -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\n :: Int
n -> Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)


    go :: DynFlags -> TidyEnv -> TcTyVarSet -> Maybe Int -> TcTyVarSet -> [SDoc]
       -> Bool                          -- True <=> some filtered out due to lack of fuel
       -> [TcBinder]
       -> TcM (TidyEnv, [SDoc], Bool)   -- The bool says if we filtered any out
                                        -- because of lack of fuel
    go :: DynFlags
-> TidyEnv
-> VarSet
-> Maybe Int
-> VarSet
-> [SDoc]
-> Bool
-> TcBinderStack
-> TcM (TidyEnv, [SDoc], Bool)
go _ tidy_env :: TidyEnv
tidy_env _ _ _ docs :: [SDoc]
docs discards :: Bool
discards []
      = (TidyEnv, [SDoc], Bool) -> TcM (TidyEnv, [SDoc], Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (TidyEnv
tidy_env, [SDoc] -> [SDoc]
forall a. [a] -> [a]
reverse [SDoc]
docs, Bool
discards)
    go dflags :: DynFlags
dflags tidy_env :: TidyEnv
tidy_env ct_tvs :: VarSet
ct_tvs n_left :: Maybe Int
n_left tvs_seen :: VarSet
tvs_seen docs :: [SDoc]
docs discards :: Bool
discards (tc_bndr :: TcBinder
tc_bndr : tc_bndrs :: TcBinderStack
tc_bndrs)
      = case TcBinder
tc_bndr of
          TcTvBndr {} -> TcM (TidyEnv, [SDoc], Bool)
discard_it
          TcIdBndr id :: TyCoVar
id top_lvl :: TopLevelFlag
top_lvl -> Name -> Type -> TopLevelFlag -> TcM (TidyEnv, [SDoc], Bool)
forall a.
(OutputableBndr a, NamedThing a) =>
a -> Type -> TopLevelFlag -> TcM (TidyEnv, [SDoc], Bool)
go2 (TyCoVar -> Name
idName TyCoVar
id) (TyCoVar -> Type
idType TyCoVar
id) TopLevelFlag
top_lvl
          TcIdBndr_ExpType name :: Name
name et :: ExpType
et top_lvl :: TopLevelFlag
top_lvl ->
            do { Maybe Type
mb_ty <- ExpType -> TcM (Maybe Type)
readExpType_maybe ExpType
et
                   -- et really should be filled in by now. But there's a chance
                   -- it hasn't, if, say, we're reporting a kind error en route to
                   -- checking a term. See test indexed-types/should_fail/T8129
                   -- Or we are reporting errors from the ambiguity check on
                   -- a local type signature
               ; case Maybe Type
mb_ty of
                   Just ty :: Type
ty -> Name -> Type -> TopLevelFlag -> TcM (TidyEnv, [SDoc], Bool)
forall a.
(OutputableBndr a, NamedThing a) =>
a -> Type -> TopLevelFlag -> TcM (TidyEnv, [SDoc], Bool)
go2 Name
name Type
ty TopLevelFlag
top_lvl
                   Nothing -> TcM (TidyEnv, [SDoc], Bool)
discard_it  -- No info; discard
               }
      where
        discard_it :: TcM (TidyEnv, [SDoc], Bool)
discard_it = DynFlags
-> TidyEnv
-> VarSet
-> Maybe Int
-> VarSet
-> [SDoc]
-> Bool
-> TcBinderStack
-> TcM (TidyEnv, [SDoc], Bool)
go DynFlags
dflags TidyEnv
tidy_env VarSet
ct_tvs Maybe Int
n_left VarSet
tvs_seen [SDoc]
docs
                        Bool
discards TcBinderStack
tc_bndrs
        go2 :: a -> Type -> TopLevelFlag -> TcM (TidyEnv, [SDoc], Bool)
go2 id_name :: a
id_name id_type :: Type
id_type top_lvl :: TopLevelFlag
top_lvl
          = do { (tidy_env' :: TidyEnv
tidy_env', tidy_ty :: Type
tidy_ty) <- TidyEnv -> Type -> TcM (TidyEnv, Type)
zonkTidyTcType TidyEnv
tidy_env Type
id_type
               ; String -> SDoc -> TcM ()
traceTc "relevantBindings 1" (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
id_name SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
tidy_ty)
               ; let id_tvs :: VarSet
id_tvs = Type -> VarSet
tyCoVarsOfType Type
tidy_ty
                     doc :: SDoc
doc = [SDoc] -> SDoc
sep [ a -> SDoc
forall a. OutputableBndr a => a -> SDoc
pprPrefixOcc a
id_name SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
tidy_ty
                               , Int -> SDoc -> SDoc
nest 2 (SDoc -> SDoc
parens (String -> SDoc
text "bound at"
                                    SDoc -> SDoc -> SDoc
<+> SrcLoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr (a -> SrcLoc
forall a. NamedThing a => a -> SrcLoc
getSrcLoc a
id_name)))]
                     new_seen :: VarSet
new_seen = VarSet
tvs_seen VarSet -> VarSet -> VarSet
`unionVarSet` VarSet
id_tvs

               ; if (Bool
want_filtering Bool -> Bool -> Bool
&& Bool -> Bool
not (DynFlags -> Bool
hasPprDebug DynFlags
dflags)
                                    Bool -> Bool -> Bool
&& VarSet
id_tvs VarSet -> VarSet -> Bool
`disjointVarSet` VarSet
ct_tvs)
                          -- We want to filter out this binding anyway
                          -- so discard it silently
                 then TcM (TidyEnv, [SDoc], Bool)
discard_it

                 else if TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl Bool -> Bool -> Bool
&& Bool -> Bool
not (Maybe Int -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Int
n_left)
                          -- It's a top-level binding and we have not specified
                          -- -fno-max-relevant-bindings, so discard it silently
                 then TcM (TidyEnv, [SDoc], Bool)
discard_it

                 else if Maybe Int -> Bool
run_out Maybe Int
n_left Bool -> Bool -> Bool
&& VarSet
id_tvs VarSet -> VarSet -> Bool
`subVarSet` VarSet
tvs_seen
                          -- We've run out of n_left fuel and this binding only
                          -- mentions already-seen type variables, so discard it
                 then DynFlags
-> TidyEnv
-> VarSet
-> Maybe Int
-> VarSet
-> [SDoc]
-> Bool
-> TcBinderStack
-> TcM (TidyEnv, [SDoc], Bool)
go DynFlags
dflags TidyEnv
tidy_env VarSet
ct_tvs Maybe Int
n_left VarSet
tvs_seen [SDoc]
docs
                         Bool
True      -- Record that we have now discarded something
                         TcBinderStack
tc_bndrs

                          -- Keep this binding, decrement fuel
                 else DynFlags
-> TidyEnv
-> VarSet
-> Maybe Int
-> VarSet
-> [SDoc]
-> Bool
-> TcBinderStack
-> TcM (TidyEnv, [SDoc], Bool)
go DynFlags
dflags TidyEnv
tidy_env' VarSet
ct_tvs (Maybe Int -> Maybe Int
dec_max Maybe Int
n_left) VarSet
new_seen
                         (SDoc
docSDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
:[SDoc]
docs) Bool
discards TcBinderStack
tc_bndrs }


discardMsg :: SDoc
discardMsg :: SDoc
discardMsg = String -> SDoc
text "(Some bindings suppressed;" SDoc -> SDoc -> SDoc
<+>
             String -> SDoc
text "use -fmax-relevant-binds=N or -fno-max-relevant-binds)"

-----------------------
warnDefaulting :: [Ct] -> Type -> TcM ()
warnDefaulting :: [Ct] -> Type -> TcM ()
warnDefaulting wanteds :: [Ct]
wanteds default_ty :: Type
default_ty
  = do { Bool
warn_default <- WarningFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnTypeDefaults
       ; TidyEnv
env0 <- TcM TidyEnv
tcInitTidyEnv
       ; let tidy_env :: TidyEnv
tidy_env = TidyEnv -> [TyCoVar] -> TidyEnv
tidyFreeTyCoVars TidyEnv
env0 ([TyCoVar] -> TidyEnv) -> [TyCoVar] -> TidyEnv
forall a b. (a -> b) -> a -> b
$
                        Cts -> [TyCoVar]
tyCoVarsOfCtsList ([Ct] -> Cts
forall a. [a] -> Bag a
listToBag [Ct]
wanteds)
             tidy_wanteds :: [Ct]
tidy_wanteds = (Ct -> Ct) -> [Ct] -> [Ct]
forall a b. (a -> b) -> [a] -> [b]
map (TidyEnv -> Ct -> Ct
tidyCt TidyEnv
tidy_env) [Ct]
wanteds
             (loc :: CtLoc
loc, ppr_wanteds :: SDoc
ppr_wanteds) = [Ct] -> (CtLoc, SDoc)
pprWithArising [Ct]
tidy_wanteds
             warn_msg :: SDoc
warn_msg =
                SDoc -> Int -> SDoc -> SDoc
hang ([SDoc] -> SDoc
hsep [ String -> SDoc
text "Defaulting the following"
                           , String -> SDoc
text "constraint" SDoc -> SDoc -> SDoc
<> [Ct] -> SDoc
forall a. [a] -> SDoc
plural [Ct]
tidy_wanteds
                           , String -> SDoc
text "to type"
                           , SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
default_ty) ])
                     2
                     SDoc
ppr_wanteds
       ; CtLoc -> TcM () -> TcM ()
forall a. CtLoc -> TcM a -> TcM a
setCtLocM CtLoc
loc (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$ WarnReason -> Bool -> SDoc -> TcM ()
warnTc (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnTypeDefaults) Bool
warn_default SDoc
warn_msg }

{-
Note [Runtime skolems]
~~~~~~~~~~~~~~~~~~~~~~
We want to give a reasonably helpful error message for ambiguity
arising from *runtime* skolems in the debugger.  These
are created by in RtClosureInspect.zonkRTTIType.

************************************************************************
*                                                                      *
                 Error from the canonicaliser
         These ones are called *during* constraint simplification
*                                                                      *
************************************************************************
-}

solverDepthErrorTcS :: CtLoc -> TcType -> TcM a
solverDepthErrorTcS :: CtLoc -> Type -> TcM a
solverDepthErrorTcS loc :: CtLoc
loc ty :: Type
ty
  = CtLoc -> TcM a -> TcM a
forall a. CtLoc -> TcM a -> TcM a
setCtLocM CtLoc
loc (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
    do { Type
ty <- Type -> TcM Type
zonkTcType Type
ty
       ; TidyEnv
env0 <- TcM TidyEnv
tcInitTidyEnv
       ; let tidy_env :: TidyEnv
tidy_env     = TidyEnv -> [TyCoVar] -> TidyEnv
tidyFreeTyCoVars TidyEnv
env0 (Type -> [TyCoVar]
tyCoVarsOfTypeList Type
ty)
             tidy_ty :: Type
tidy_ty      = TidyEnv -> Type -> Type
tidyType TidyEnv
tidy_env Type
ty
             msg :: SDoc
msg
               = [SDoc] -> SDoc
vcat [ String -> SDoc
text "Reduction stack overflow; size =" SDoc -> SDoc -> SDoc
<+> SubGoalDepth -> SDoc
forall a. Outputable a => a -> SDoc
ppr SubGoalDepth
depth
                      , SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "When simplifying the following type:")
                           2 (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
tidy_ty)
                      , SDoc
note ]
       ; (TidyEnv, SDoc) -> TcM a
forall a. (TidyEnv, SDoc) -> TcM a
failWithTcM (TidyEnv
tidy_env, SDoc
msg) }
  where
    depth :: SubGoalDepth
depth = CtLoc -> SubGoalDepth
ctLocDepth CtLoc
loc
    note :: SDoc
note = [SDoc] -> SDoc
vcat
      [ String -> SDoc
text "Use -freduction-depth=0 to disable this check"
      , String -> SDoc
text "(any upper bound you could choose might fail unpredictably with"
      , String -> SDoc
text " minor updates to GHC, so disabling the check is recommended if"
      , String -> SDoc
text " you're sure that type checking should terminate)" ]