{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeFamilies #-}

-- | Describes the provenance of types as they flow through the type-checker.
-- The datatypes here are mainly used for error message generation.
module GHC.Tc.Types.Origin (
  -- * UserTypeCtxt
  UserTypeCtxt(..), pprUserTypeCtxt, isSigMaybe,
  ReportRedundantConstraints(..), reportRedundantConstraints,
  redundantConstraintsSpan,

  -- * SkolemInfo
  SkolemInfo(..), SkolemInfoAnon(..), mkSkolemInfo, getSkolemInfo, pprSigSkolInfo, pprSkolInfo,
  unkSkol, unkSkolAnon, mkClsInstSkol,

  -- * CtOrigin
  CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin,
  isVisibleOrigin, toInvisibleOrigin,
  pprCtOrigin, isGivenOrigin, isWantedWantedFunDepOrigin,
  isWantedSuperclassOrigin,
  ClsInstOrQC(..), NakedScFlag(..), NonLinearPatternReason(..),

  TypedThing(..), TyVarBndrs(..),

  -- * CallStack
  isPushCallStackOrigin, callStackOriginFS,

  -- * FixedRuntimeRep origin
  FixedRuntimeRepOrigin(..),
  FixedRuntimeRepContext(..),
  pprFixedRuntimeRepContext,
  StmtOrigin(..), ArgPos(..),
  mkFRRUnboxedTuple, mkFRRUnboxedSum,

  -- ** FixedRuntimeRep origin for rep-poly 'Id's
  RepPolyId(..), Polarity(..), Position(..),

  -- ** Arrow command FixedRuntimeRep origin
  FRRArrowContext(..), pprFRRArrowContext,

  -- ** ExpectedFunTy FixedRuntimeRepOrigin
  ExpectedFunTyOrigin(..), pprExpectedFunTyOrigin, pprExpectedFunTyHerald,

  -- * InstanceWhat
  InstanceWhat(..), SafeOverlapping
  ) where

import GHC.Prelude

import GHC.Tc.Utils.TcType

import GHC.Hs

import GHC.Core.DataCon
import GHC.Core.ConLike
import GHC.Core.TyCon
import GHC.Core.Class
import GHC.Core.InstEnv
import GHC.Core.PatSyn
import GHC.Core.Multiplicity ( scaledThing )

import GHC.Unit.Module
import GHC.Unit.Module.Warnings
import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.Name.Reader
import GHC.Types.Basic
import GHC.Types.SrcLoc

import GHC.Data.FastString

import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Stack
import GHC.Utils.Monad
import GHC.Utils.Misc( HasDebugCallStack )
import GHC.Types.Unique
import GHC.Types.Unique.Supply

import Language.Haskell.Syntax.Basic (FieldLabelString(..))

import qualified Data.Kind as Hs

{- *********************************************************************
*                                                                      *
          UserTypeCtxt
*                                                                      *
********************************************************************* -}

-------------------------------------
-- | UserTypeCtxt describes the origin of the polymorphic type
-- in the places where we need an expression to have that type
data UserTypeCtxt
  = FunSigCtxt      -- Function type signature, when checking the type
                    -- Also used for types in SPECIALISE pragmas
       Name              -- Name of the function
       ReportRedundantConstraints
         -- See Note [Tracking redundant constraints] in GHC.Tc.Solver
         -- This field is usually 'WantRCC', but 'NoRCC' for
         --   * Record selectors (not important here)
         --   * Class and instance methods.  Here the code may legitimately
         --     be more polymorphic than the signature generated from the
         --     class declaration
         --   * Functions whose type signature has hidden the constraints
         --     behind a type synonym.  E.g.
         --          type Foo = forall a. Eq a => a -> a
         --          id :: Foo
         --          id x = x
         --     Here we can't give a good location for the redundant constraints
         --     (see lhsSigWcTypeContextSpan), so we don't report redundant
         --     constraints at all. It's not clear that this a good choice;
         --     perhaps we should report, just with a less informative SrcSpan.
         --     c.f. #16154

  | InfSigCtxt Name     -- Inferred type for function
  | ExprSigCtxt         -- Expression type signature
      ReportRedundantConstraints
  | KindSigCtxt         -- Kind signature
  | StandaloneKindSigCtxt  -- Standalone kind signature
       Name                -- Name of the type/class
  | TypeAppCtxt         -- Visible type application
  | ConArgCtxt Name     -- Data constructor argument
  | TySynCtxt Name      -- RHS of a type synonym decl
  | PatSynCtxt Name     -- Type sig for a pattern synonym
  | PatSigCtxt          -- Type sig in pattern
                        --   eg  f (x::t) = ...
                        --   or  (x::t, y) = e
  | RuleSigCtxt FastString Name    -- LHS of a RULE forall
                        --    RULE "foo" forall (x :: a -> a). f (Just x) = ...
  | ForSigCtxt Name     -- Foreign import or export signature
  | DefaultDeclCtxt     -- Class or types in a default declaration
  | InstDeclCtxt Bool   -- An instance declaration
                        --    True:  stand-alone deriving
                        --    False: vanilla instance declaration
  | SpecInstCtxt        -- SPECIALISE instance pragma
  | GenSigCtxt          -- Higher-rank or impredicative situations
                        -- e.g. (f e) where f has a higher-rank type
                        -- We might want to elaborate this
  | GhciCtxt Bool       -- GHCi command :kind <type>
                        -- The Bool indicates if we are checking the outermost
                        -- type application.
                        -- See Note [Unsaturated type synonyms in GHCi] in
                        -- GHC.Tc.Validity.

  | ClassSCCtxt Name    -- Superclasses of a class
  | SigmaCtxt           -- Theta part of a normal for-all type
                        --      f :: <S> => a -> a
  | DataTyCtxt Name     -- The "stupid theta" part of a data decl
                        --      data <S> => T a = MkT a
  | DerivClauseCtxt     -- A 'deriving' clause
  | TyVarBndrKindCtxt Name  -- The kind of a type variable being bound
  | DataKindCtxt Name   -- The kind of a data/newtype (instance)
  | TySynKindCtxt Name  -- The kind of the RHS of a type synonym
  | TyFamResKindCtxt Name   -- The result kind of a type family
  deriving( UserTypeCtxt -> UserTypeCtxt -> Bool
(UserTypeCtxt -> UserTypeCtxt -> Bool)
-> (UserTypeCtxt -> UserTypeCtxt -> Bool) -> Eq UserTypeCtxt
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UserTypeCtxt -> UserTypeCtxt -> Bool
== :: UserTypeCtxt -> UserTypeCtxt -> Bool
$c/= :: UserTypeCtxt -> UserTypeCtxt -> Bool
/= :: UserTypeCtxt -> UserTypeCtxt -> Bool
Eq ) -- Just for checkSkolInfoAnon

-- | Report Redundant Constraints.
data ReportRedundantConstraints
  = NoRRC            -- ^ Don't report redundant constraints

  | WantRRC SrcSpan  -- ^ Report redundant constraints
      -- The SrcSpan is for the constraints
      -- E.g. f :: (Eq a, Ord b) => blah
      --      The span is for the (Eq a, Ord b)
      -- We need to record the span here because we have
      -- long since discarded the HsType in favour of a Type

  deriving( ReportRedundantConstraints -> ReportRedundantConstraints -> Bool
(ReportRedundantConstraints -> ReportRedundantConstraints -> Bool)
-> (ReportRedundantConstraints
    -> ReportRedundantConstraints -> Bool)
-> Eq ReportRedundantConstraints
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ReportRedundantConstraints -> ReportRedundantConstraints -> Bool
== :: ReportRedundantConstraints -> ReportRedundantConstraints -> Bool
$c/= :: ReportRedundantConstraints -> ReportRedundantConstraints -> Bool
/= :: ReportRedundantConstraints -> ReportRedundantConstraints -> Bool
Eq )  -- Just for checkSkolInfoAnon

reportRedundantConstraints :: ReportRedundantConstraints -> Bool
reportRedundantConstraints :: ReportRedundantConstraints -> Bool
reportRedundantConstraints ReportRedundantConstraints
NoRRC        = Bool
False
reportRedundantConstraints (WantRRC {}) = Bool
True

redundantConstraintsSpan :: UserTypeCtxt -> SrcSpan
redundantConstraintsSpan :: UserTypeCtxt -> SrcSpan
redundantConstraintsSpan (FunSigCtxt Name
_ (WantRRC SrcSpan
span)) = SrcSpan
span
redundantConstraintsSpan (ExprSigCtxt (WantRRC SrcSpan
span))  = SrcSpan
span
redundantConstraintsSpan UserTypeCtxt
_ = SrcSpan
noSrcSpan

{-
-- Notes re TySynCtxt
-- We allow type synonyms that aren't types; e.g.  type List = []
--
-- If the RHS mentions tyvars that aren't in scope, we'll
-- quantify over them:
--      e.g.    type T = a->a
-- will become  type T = forall a. a->a
--
-- With gla-exts that's right, but for H98 we should complain.
-}


pprUserTypeCtxt :: UserTypeCtxt -> SDoc
pprUserTypeCtxt :: UserTypeCtxt -> SDoc
pprUserTypeCtxt (FunSigCtxt Name
n ReportRedundantConstraints
_)  = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the type signature for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n)
pprUserTypeCtxt (InfSigCtxt Name
n)    = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the inferred type for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n)
pprUserTypeCtxt (RuleSigCtxt FastString
_ Name
n) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the type signature for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n)
pprUserTypeCtxt (ExprSigCtxt ReportRedundantConstraints
_)   = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"an expression type signature"
pprUserTypeCtxt UserTypeCtxt
KindSigCtxt       = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a kind signature"
pprUserTypeCtxt (StandaloneKindSigCtxt Name
n) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a standalone kind signature for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n)
pprUserTypeCtxt UserTypeCtxt
TypeAppCtxt       = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a type argument"
pprUserTypeCtxt (ConArgCtxt Name
c)    = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the type of the constructor" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
c)
pprUserTypeCtxt (TySynCtxt Name
c)     = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the RHS of the type synonym" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
c)
pprUserTypeCtxt UserTypeCtxt
PatSigCtxt        = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a pattern type signature"
pprUserTypeCtxt (ForSigCtxt Name
n)    = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the foreign declaration for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n)
pprUserTypeCtxt UserTypeCtxt
DefaultDeclCtxt   = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a `default' declaration"
pprUserTypeCtxt (InstDeclCtxt Bool
False) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"an instance declaration"
pprUserTypeCtxt (InstDeclCtxt Bool
True)  = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a stand-alone deriving instance declaration"
pprUserTypeCtxt UserTypeCtxt
SpecInstCtxt      = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a SPECIALISE instance pragma"
pprUserTypeCtxt UserTypeCtxt
GenSigCtxt        = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a type expected by the context"
pprUserTypeCtxt (GhciCtxt {})     = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a type in a GHCi command"
pprUserTypeCtxt (ClassSCCtxt Name
c)   = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the super-classes of class" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
c)
pprUserTypeCtxt UserTypeCtxt
SigmaCtxt         = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the context of a polymorphic type"
pprUserTypeCtxt (DataTyCtxt Name
tc)   = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the context of the data type declaration for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
tc)
pprUserTypeCtxt (PatSynCtxt Name
n)    = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the signature for pattern synonym" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n)
pprUserTypeCtxt (UserTypeCtxt
DerivClauseCtxt) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a `deriving' clause"
pprUserTypeCtxt (TyVarBndrKindCtxt Name
n) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the kind annotation on the type variable" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n)
pprUserTypeCtxt (DataKindCtxt Name
n)  = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the kind annotation on the declaration for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n)
pprUserTypeCtxt (TySynKindCtxt Name
n) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the kind annotation on the declaration for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n)
pprUserTypeCtxt (TyFamResKindCtxt Name
n) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the result kind for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n)

isSigMaybe :: UserTypeCtxt -> Maybe Name
isSigMaybe :: UserTypeCtxt -> Maybe Name
isSigMaybe (FunSigCtxt Name
n ReportRedundantConstraints
_) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
isSigMaybe (ConArgCtxt Name
n)   = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
isSigMaybe (ForSigCtxt Name
n)   = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
isSigMaybe (PatSynCtxt Name
n)   = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
isSigMaybe UserTypeCtxt
_                = Maybe Name
forall a. Maybe a
Nothing

{-
************************************************************************
*                                                                      *
                SkolemInfo
*                                                                      *
************************************************************************
-}

-- | 'SkolemInfo' stores the origin of a skolem type variable,
-- so that we can display this information to the user in case of a type error.
--
-- The 'Unique' field allows us to report all skolem type variables bound in the
-- same place in a single report.
data SkolemInfo
  = SkolemInfo
      Unique         -- ^ The Unique is used to common up skolem variables bound
                     --   at the same location (only used in pprSkols)
      SkolemInfoAnon -- ^ The information about the origin of the skolem type variable

instance Uniquable SkolemInfo where
  getUnique :: SkolemInfo -> Unique
getUnique (SkolemInfo Unique
u SkolemInfoAnon
_) = Unique
u

-- | 'SkolemInfoAnon' stores the origin of a skolem type variable (e.g. bound by
-- a user-written forall, the header of a data declaration, a deriving clause, ...).
--
-- This information is displayed when reporting an error message, such as
--
--  @"Couldn't match 'k' with 'l'"@
--
-- This allows us to explain where the type variable came from.
--
-- When several skolem type variables are bound at once, prefer using 'SkolemInfo',
-- which stores a 'Unique' which allows these type variables to be reported
data SkolemInfoAnon
  = SigSkol -- A skolem that is created by instantiating
            -- a programmer-supplied type signature
            -- Location of the binding site is on the TyVar
            -- See Note [SigSkol SkolemInfo]
       UserTypeCtxt        -- What sort of signature
       TcType              -- Original type signature (before skolemisation)
       [(Name,TcTyVar)]    -- Maps the original name of the skolemised tyvar
                           -- to its instantiated version

  | SigTypeSkol UserTypeCtxt
                 -- like SigSkol, but when we're kind-checking the *type*
                 -- hence, we have less info

  | ForAllSkol  -- Bound by a user-written "forall".
      TyVarBndrs   -- Shows just the binders, used when reporting a bad telescope
                    -- See Note [Checking telescopes] in GHC.Tc.Types.Constraint

  | DerivSkol Type      -- Bound by a 'deriving' clause;
                        -- the type is the instance we are trying to derive

  | InstSkol            -- Bound at an instance decl, or quantified constraint
       ClsInstOrQC      -- Whether class instance or quantified constraint
       PatersonSize     -- Head has the given PatersonSize

  | FamInstSkol         -- Bound at a family instance decl
  | PatSkol             -- An existential type variable bound by a pattern for
      ConLike           -- a data constructor with an existential type.
      HsMatchContextRn
             -- e.g.   data T = forall a. Eq a => MkT a
             --        f (MkT x) = ...
             -- The pattern MkT x will allocate an existential type
             -- variable for 'a'.

  | IPSkol [HsIPName]   -- Binding site of an implicit parameter

  | RuleSkol RuleName   -- The LHS of a RULE

  | InferSkol [(Name,TcType)]
                        -- We have inferred a type for these (mutually recursive)
                        -- polymorphic Ids, and are now checking that their RHS
                        -- constraints are satisfied.

  | BracketSkol         -- Template Haskell bracket

  | UnifyForAllSkol     -- We are unifying two for-all types
       TcType           -- The instantiated type *inside* the forall

  | TyConSkol (TyConFlavour TyCon) Name -- bound in a type declaration of the given flavour

  | DataConSkol Name    -- bound as an existential in a Haskell98 datacon decl or
                        -- as any variable in a GADT datacon decl

  | ReifySkol           -- Bound during Template Haskell reification

  | RuntimeUnkSkol      -- Runtime skolem from the GHCi debugger      #14628

  | ArrowReboundIfSkol  -- Bound by the expected type of the rebound arrow ifThenElse command.

  | UnkSkol CallStack


-- | Use this when you can't specify a helpful origin for
-- some skolem type variable.
--
-- We're hoping to be able to get rid of this entirely, but for the moment
-- it's still needed.
unkSkol :: HasDebugCallStack => SkolemInfo
unkSkol :: HasDebugCallStack => SkolemInfo
unkSkol = Unique -> SkolemInfoAnon -> SkolemInfo
SkolemInfo (Word64 -> Unique
mkUniqueGrimily Word64
0) SkolemInfoAnon
HasDebugCallStack => SkolemInfoAnon
unkSkolAnon

unkSkolAnon :: HasDebugCallStack => SkolemInfoAnon
unkSkolAnon :: HasDebugCallStack => SkolemInfoAnon
unkSkolAnon = CallStack -> SkolemInfoAnon
UnkSkol CallStack
HasCallStack => CallStack
callStack

-- | Wrap up the origin of a skolem type variable with a new 'Unique',
-- so that we can common up skolem type variables whose 'SkolemInfo'
-- shares a certain 'Unique'.
mkSkolemInfo :: MonadIO m => SkolemInfoAnon -> m SkolemInfo
mkSkolemInfo :: forall (m :: * -> *). MonadIO m => SkolemInfoAnon -> m SkolemInfo
mkSkolemInfo SkolemInfoAnon
sk_anon = do
  u <- IO Unique -> m Unique
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Unique -> m Unique) -> IO Unique -> m Unique
forall a b. (a -> b) -> a -> b
$! Char -> IO Unique
uniqFromTag Char
's'
  return (SkolemInfo u sk_anon)

getSkolemInfo :: SkolemInfo -> SkolemInfoAnon
getSkolemInfo :: SkolemInfo -> SkolemInfoAnon
getSkolemInfo (SkolemInfo Unique
_ SkolemInfoAnon
skol_anon) = SkolemInfoAnon
skol_anon

mkClsInstSkol :: Class -> [Type] -> SkolemInfoAnon
mkClsInstSkol :: Class -> [TcType] -> SkolemInfoAnon
mkClsInstSkol Class
cls [TcType]
tys = ClsInstOrQC -> PatersonSize -> SkolemInfoAnon
InstSkol ClsInstOrQC
IsClsInst (Class -> [TcType] -> PatersonSize
pSizeClassPred Class
cls [TcType]
tys)

instance Outputable SkolemInfo where
  ppr :: SkolemInfo -> SDoc
ppr (SkolemInfo Unique
_ SkolemInfoAnon
sk_info ) = SkolemInfoAnon -> SDoc
forall a. Outputable a => a -> SDoc
ppr SkolemInfoAnon
sk_info

instance Outputable SkolemInfoAnon where
  ppr :: SkolemInfoAnon -> SDoc
ppr = SkolemInfoAnon -> SDoc
pprSkolInfo

pprSkolInfo :: SkolemInfoAnon -> SDoc
-- Complete the sentence "is a rigid type variable bound by..."
pprSkolInfo :: SkolemInfoAnon -> SDoc
pprSkolInfo (SigSkol UserTypeCtxt
cx TcType
ty [(Name, Id)]
_) = UserTypeCtxt -> TcType -> SDoc
pprSigSkolInfo UserTypeCtxt
cx TcType
ty
pprSkolInfo (SigTypeSkol UserTypeCtxt
cx)  = UserTypeCtxt -> SDoc
pprUserTypeCtxt UserTypeCtxt
cx
pprSkolInfo (ForAllSkol TyVarBndrs
tvs)  = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"an explicit forall" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TyVarBndrs -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyVarBndrs
tvs
pprSkolInfo (IPSkol [HsIPName]
ips)      = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the implicit-parameter binding" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [HsIPName] -> SDoc
forall a. [a] -> SDoc
plural [HsIPName]
ips SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"for"
                                 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> (HsIPName -> SDoc) -> [HsIPName] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas HsIPName -> SDoc
forall a. Outputable a => a -> SDoc
ppr [HsIPName]
ips
pprSkolInfo (DerivSkol TcType
pred)  = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the deriving clause for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
pred)
pprSkolInfo (InstSkol ClsInstOrQC
IsClsInst PatersonSize
sz) = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the instance declaration"
                                           , SDoc -> SDoc
forall doc. IsOutput doc => doc -> doc
whenPprDebug (SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces (PatersonSize -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatersonSize
sz)) ]
pprSkolInfo (InstSkol (IsQC {}) PatersonSize
sz) = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a quantified context"
                                           , SDoc -> SDoc
forall doc. IsOutput doc => doc -> doc
whenPprDebug (SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces (PatersonSize -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatersonSize
sz)) ]
pprSkolInfo SkolemInfoAnon
FamInstSkol       = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a family instance declaration"
pprSkolInfo SkolemInfoAnon
BracketSkol       = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a Template Haskell bracket"
pprSkolInfo (RuleSkol FastString
name)   = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the RULE" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FastString -> SDoc
pprRuleName FastString
name
pprSkolInfo (PatSkol ConLike
cl HsMatchContextRn
mc)   = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [ ConLike -> SDoc
pprPatSkolInfo ConLike
cl
                                    , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsMatchContext (GenLocated SrcSpanAnnN Name) -> SDoc
forall fn. Outputable fn => HsMatchContext fn -> SDoc
pprMatchContext HsMatchContextRn
HsMatchContext (GenLocated SrcSpanAnnN Name)
mc ]
pprSkolInfo (InferSkol [(Name, TcType)]
ids)   = SDoc -> ScDepth -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the inferred type" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [(Name, TcType)] -> SDoc
forall a. [a] -> SDoc
plural [(Name, TcType)]
ids SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"of")
                                   ScDepth
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty
                                           | (Name
name,TcType
ty) <- [(Name, TcType)]
ids ])
pprSkolInfo (UnifyForAllSkol TcType
ty)  = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the type" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty
pprSkolInfo (TyConSkol TyConFlavour TyCon
flav Name
name) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TyConFlavour TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyConFlavour TyCon
flav SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"declaration for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)
pprSkolInfo (DataConSkol Name
name)    = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the type signature for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)
pprSkolInfo SkolemInfoAnon
ReifySkol             = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the type being reified"

pprSkolInfo SkolemInfoAnon
RuntimeUnkSkol     = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Unknown type from GHCi runtime"
pprSkolInfo SkolemInfoAnon
ArrowReboundIfSkol = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the expected type of a rebound if-then-else command"

-- unkSkol
-- For type variables the others are dealt with by pprSkolTvBinding.
-- For Insts, these cases should not happen
pprSkolInfo (UnkSkol CallStack
cs) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"UnkSkol (please report this as a bug)" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ CallStack -> SDoc
prettyCallStackDoc CallStack
cs


pprSigSkolInfo :: UserTypeCtxt -> TcType -> SDoc
-- The type is already tidied
pprSigSkolInfo :: UserTypeCtxt -> TcType -> SDoc
pprSigSkolInfo UserTypeCtxt
ctxt TcType
ty
  = case UserTypeCtxt
ctxt of
       FunSigCtxt Name
f ReportRedundantConstraints
_ -> [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the type signature for:"
                              , ScDepth -> SDoc -> SDoc
nest ScDepth
2 (Name -> SDoc
forall a. OutputableBndr a => a -> SDoc
pprPrefixOcc Name
f SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty) ]
       PatSynCtxt {}  -> UserTypeCtxt -> SDoc
pprUserTypeCtxt UserTypeCtxt
ctxt  -- See Note [Skolem info for pattern synonyms]
       UserTypeCtxt
_              -> [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ UserTypeCtxt -> SDoc
pprUserTypeCtxt UserTypeCtxt
ctxt SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon
                              , ScDepth -> SDoc -> SDoc
nest ScDepth
2 (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty) ]

pprPatSkolInfo :: ConLike -> SDoc
pprPatSkolInfo :: ConLike -> SDoc
pprPatSkolInfo (RealDataCon DataCon
dc)
  = (SDocContext -> Bool) -> (Bool -> SDoc) -> SDoc
forall a. (SDocContext -> a) -> (a -> SDoc) -> SDoc
sdocOption SDocContext -> Bool
sdocLinearTypes (\Bool
show_linear_types ->
      [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a pattern with constructor:"
          , ScDepth -> SDoc -> SDoc
nest ScDepth
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
dc SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon
            SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcType -> SDoc
pprType (Bool -> DataCon -> TcType
dataConDisplayType Bool
show_linear_types DataCon
dc) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma ])
            -- pprType prints forall's regardless of -fprint-explicit-foralls
            -- which is what we want here, since we might be saying
            -- type variable 't' is bound by ...

pprPatSkolInfo (PatSynCon PatSyn
ps)
  = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a pattern with pattern synonym:"
        , ScDepth -> SDoc -> SDoc
nest ScDepth
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ PatSyn -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatSyn
ps SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon
                   SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> PatSyn -> SDoc
pprPatSynType PatSyn
ps SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma ]

{- Note [Skolem info for pattern synonyms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For pattern synonym SkolemInfo we have
   SigSkol (PatSynCtxt p) ty _
but the type 'ty' is not very helpful.  The full pattern-synonym type
has the provided and required pieces, which it is inconvenient to
record and display here. So we simply don't display the type at all,
contenting ourselves with just the name of the pattern synonym, which
is fine.  We could do more, but it doesn't seem worth it.

Note [SigSkol SkolemInfo]
~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we skolemise a type
   f :: forall a. Eq a => forall b. b -> a
Then we'll instantiate [a :-> a', b :-> b'], and with the instantiated
      a' -> b' -> a.
But when, in an error message, we report that "b is a rigid type
variable bound by the type signature for f", we want to show the foralls
in the right place.  So we proceed as follows:

* In SigSkol we record
    - the original signature forall a. a -> forall b. b -> a
    - the instantiation mapping [a :-> a', b :-> b']

* Then when tidying in GHC.Tc.Utils.TcMType.tidySkolemInfo, we first tidy a' to
  whatever it tidies to, say a''; and then we walk over the type
  replacing the binder a by the tidied version a'', to give
       forall a''. Eq a'' => forall b''. b'' -> a''
  We need to do this under (=>) arrows and (->), to match what skolemisation
  does.

* Typically a'' will have a nice pretty name like "a", but the point is
  that the foral-bound variables of the signature we report line up with
  the instantiated skolems lying  around in other types.
-}

{- *********************************************************************
*                                                                      *
            CtOrigin
*                                                                      *
************************************************************************
-}

-- | Some thing which has a type.
--
-- This datatype is used when we want to report to the user
-- that something has an unexpected type.
data TypedThing
  = HsTypeRnThing (HsType GhcRn)
  | TypeThing Type
  | HsExprRnThing (HsExpr GhcRn)
  | HsExprTcThing (HsExpr GhcTc)
  | NameThing Name

-- | Some kind of type variable binder.
--
-- Used for reporting errors, in 'SkolemInfo' and 'TcSolverReportMsg'.
data TyVarBndrs
  = forall flag. OutputableBndrFlag flag 'Renamed =>
      HsTyVarBndrsRn [HsTyVarBndr flag GhcRn]

instance Outputable TypedThing where
  ppr :: TypedThing -> SDoc
ppr (HsTypeRnThing HsType GhcRn
ty) = HsType GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsType GhcRn
ty
  ppr (TypeThing TcType
ty) = TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty
  ppr (HsExprRnThing HsExpr GhcRn
expr) = HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
expr
  ppr (HsExprTcThing HsExpr GhcTc
expr) = HsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
expr
  ppr (NameThing Name
name) = Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name

instance Outputable TyVarBndrs where
  ppr :: TyVarBndrs -> SDoc
ppr (HsTyVarBndrsRn [HsTyVarBndr flag GhcRn]
bndrs) = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
fsep ((HsTyVarBndr flag GhcRn -> SDoc)
-> [HsTyVarBndr flag GhcRn] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map HsTyVarBndr flag GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr [HsTyVarBndr flag GhcRn]
bndrs)

data CtOrigin
  = -- | A given constraint from a user-written type signature. The
    -- 'SkolemInfo' inside gives more information.
    GivenOrigin SkolemInfoAnon

  -- | 'GivenSCOrigin' is used for a Given constraint obtained by superclass selection
  -- from the context of an instance declaration.  E.g.
  --       instance @(Foo a, Bar a) => C [a]@ where ...
  -- When typechecking the instance decl itself, including producing evidence
  -- for the superclasses of @C@, the superclasses of @(Foo a)@ and @(Bar a)@ will
  -- have 'GivenSCOrigin' origin.
  | GivenSCOrigin
        SkolemInfoAnon  -- ^ Just like GivenOrigin

        ScDepth         -- ^ The number of superclass selections necessary to
                        -- get this constraint; see Note [Replacement vs keeping]
                        -- in GHC.Tc.Solver.Dict

        Bool   -- ^ True => "blocked": cannot use this to solve naked superclass Wanteds
               --                      i.e. ones with (ScOrigin _ NakedSc)
               --   False => can use this to solve all Wanted constraints
               -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance

  ----------- Below here, all are Origins for Wanted constraints ------------

  | OccurrenceOf Name              -- Occurrence of an overloaded identifier
  | OccurrenceOfRecSel RdrName     -- Occurrence of a record selector
  | AppOrigin                      -- An application of some kind

  | SpecPragOrigin UserTypeCtxt    -- Specialisation pragma for
                                   -- function or instance


  | TypeEqOrigin { CtOrigin -> TcType
uo_actual   :: TcType
                 , CtOrigin -> TcType
uo_expected :: TcType
                 , CtOrigin -> Maybe TypedThing
uo_thing    :: Maybe TypedThing
                       -- ^ The thing that has type "actual"
                 , CtOrigin -> Bool
uo_visible  :: Bool
                       -- ^ Is at least one of the three elements above visible?
                       -- (Errors from the polymorphic subsumption check are considered
                       -- visible.) Only used for prioritizing error messages.
                 }

  | KindEqOrigin
      TcType TcType             -- A kind equality arising from unifying these two types
      CtOrigin                  -- originally arising from this
      (Maybe TypeOrKind)        -- the level of the eq this arises from

  | IPOccOrigin  HsIPName       -- Occurrence of an implicit parameter
  | OverLabelOrigin FastString  -- Occurrence of an overloaded label

  | LiteralOrigin (HsOverLit GhcRn)     -- Occurrence of a literal
  | NegateOrigin                        -- Occurrence of syntactic negation

  | ArithSeqOrigin (ArithSeqInfo GhcRn) -- [x..], [x..y] etc
  | AssocFamPatOrigin   -- When matching the patterns of an associated
                        -- family instance with that of its parent class
                        -- IMPORTANT: These constraints will never cause errors;
                        -- See Note [Constraints to ignore] in GHC.Tc.Errors
  | SectionOrigin
  | HasFieldOrigin FastString
  | TupleOrigin         -- (..,..)
  | ExprSigOrigin       -- e :: ty
  | PatSigOrigin        -- p :: ty
  | PatOrigin           -- Instantiating a polytyped pattern at a constructor
  | ProvCtxtOrigin      -- The "provided" context of a pattern synonym signature
        (PatSynBind GhcRn GhcRn) -- Information about the pattern synonym, in
                                 -- particular the name and the right-hand side
  | RecordUpdOrigin
  | ViewPatOrigin

  -- | 'ScOrigin' is used only for the Wanted constraints for the
  --   superclasses of an instance declaration.
  | ScOrigin
      ClsInstOrQC   -- Whether class instance or quantified constraint
      NakedScFlag

  | DerivClauseOrigin   -- Typechecking a deriving clause (as opposed to
                        -- standalone deriving).
  | DerivOriginDC DataCon Int Bool
      -- Checking constraints arising from this data con and field index. The
      -- Bool argument in DerivOriginDC and DerivOriginCoerce is True if
      -- standalong deriving (with a wildcard constraint) is being used. This
      -- is used to inform error messages on how to recommended fixes (e.g., if
      -- the argument is True, then don't recommend "use standalone deriving",
      -- but rather "fill in the wildcard constraint yourself").
      -- See Note [Inferring the instance context] in GHC.Tc.Deriv.Infer
  | DerivOriginCoerce Id Type Type Bool
                        -- DerivOriginCoerce id ty1 ty2: Trying to coerce class method `id` from
                        -- `ty1` to `ty2`.
  | StandAloneDerivOrigin -- Typechecking stand-alone deriving. Useful for
                          -- constraints coming from a wildcard constraint,
                          -- e.g., deriving instance _ => Eq (Foo a)
                          -- See Note [Inferring the instance context]
                          -- in GHC.Tc.Deriv.Infer
  | DefaultOrigin       -- Typechecking a default decl
  | DoOrigin            -- Arising from a do expression
  | DoPatOrigin (LPat GhcRn) -- Arising from a failable pattern in
                             -- a do expression
  | MCompOrigin         -- Arising from a monad comprehension
  | MCompPatOrigin (LPat GhcRn) -- Arising from a failable pattern in a
                                -- monad comprehension
  | ProcOrigin          -- Arising from a proc expression
  | ArrowCmdOrigin      -- Arising from an arrow command
  | AnnOrigin           -- An annotation

  | FunDepOrigin1       -- A functional dependency from combining
        PredType CtOrigin RealSrcSpan      -- This constraint arising from ...
        PredType CtOrigin RealSrcSpan      -- and this constraint arising from ...

  | FunDepOrigin2       -- A functional dependency from combining
        PredType CtOrigin   -- This constraint arising from ...
        PredType SrcSpan    -- and this top-level instance
        -- We only need a CtOrigin on the first, because the location
        -- is pinned on the entire error message

  | InjTFOrigin1    -- injective type family equation combining
      PredType CtOrigin RealSrcSpan    -- This constraint arising from ...
      PredType CtOrigin RealSrcSpan    -- and this constraint arising from ...

  | ExprHoleOrigin (Maybe RdrName)   -- from an expression hole
  | TypeHoleOrigin OccName   -- from a type hole (partial type signature)
  | PatCheckOrigin      -- normalisation of a type during pattern-match checking
  | ListOrigin          -- An overloaded list
  | IfThenElseOrigin    -- An if-then-else expression
  | BracketOrigin       -- An overloaded quotation bracket
  | StaticOrigin        -- A static form
  | ImpedanceMatching Id   -- See Note [Impedance matching] in GHC.Tc.Gen.Bind
  | Shouldn'tHappenOrigin String  -- The user should never see this one

  -- | Testing whether the constraint associated with an instance declaration
  -- in a signature file is satisfied upon instantiation.
  --
  -- Test cases: backpack/should_fail/bkpfail{11,43}.bkp
  | InstProvidedOrigin
      Module  -- ^ Module in which the instance was declared
      ClsInst -- ^ The declared typeclass instance

  | NonLinearPatternOrigin NonLinearPatternReason (LPat GhcRn)
  | OmittedFieldOrigin (Maybe FieldLabel)
  | UsageEnvironmentOf Name

  | CycleBreakerOrigin
      CtOrigin   -- origin of the original constraint

      -- See Detail (7) of Note [Type equality cycles] in GHC.Tc.Solver.Equality
  | FRROrigin
      FixedRuntimeRepOrigin

  | WantedSuperclassOrigin PredType CtOrigin
        -- From expanding out the superclasses of a Wanted; the PredType
        -- is the subclass predicate, and the origin
        -- of the original Wanted is the CtOrigin

  | InstanceSigOrigin   -- from the sub-type check of an InstanceSig
      Name   -- the method name
      Type   -- the instance-sig type
      Type   -- the instantiated type of the method
  | AmbiguityCheckOrigin UserTypeCtxt

data NonLinearPatternReason
  = LazyPatternReason
  | GeneralisedPatternReason
  | PatternSynonymReason
  | ViewPatternReason
  | OtherPatternReason

-- | The number of superclass selections needed to get this Given.
-- If @d :: C ty@   has @ScDepth=2@, then the evidence @d@ will look
-- like @sc_sel (sc_sel dg)@, where @dg@ is a Given.
type ScDepth = Int

data ClsInstOrQC = IsClsInst
                 | IsQC CtOrigin

data NakedScFlag = NakedSc | NotNakedSc
      --   The NakedScFlag affects only GHC.Tc.Solver.InertSet.prohibitedSuperClassSolve
      --   * For the original superclass constraints we use (ScOrigin _ NakedSc)
      --   * But after using an instance declaration we use (ScOrigin _ NotNakedSc)
      --   See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance

instance Outputable NakedScFlag where
  ppr :: NakedScFlag -> SDoc
ppr NakedScFlag
NakedSc    = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"NakedSc"
  ppr NakedScFlag
NotNakedSc = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"NotNakedSc"

-- An origin is visible if the place where the constraint arises is manifest
-- in user code. Currently, all origins are visible except for invisible
-- TypeEqOrigins. This is used when choosing which error of
-- several to report
isVisibleOrigin :: CtOrigin -> Bool
isVisibleOrigin :: CtOrigin -> Bool
isVisibleOrigin (TypeEqOrigin { uo_visible :: CtOrigin -> Bool
uo_visible = Bool
vis }) = Bool
vis
isVisibleOrigin (KindEqOrigin TcType
_ TcType
_ CtOrigin
sub_orig Maybe TypeOrKind
_)       = CtOrigin -> Bool
isVisibleOrigin CtOrigin
sub_orig
isVisibleOrigin CtOrigin
_                                   = Bool
True

-- Converts a visible origin to an invisible one, if possible. Currently,
-- this works only for TypeEqOrigin
toInvisibleOrigin :: CtOrigin -> CtOrigin
toInvisibleOrigin :: CtOrigin -> CtOrigin
toInvisibleOrigin orig :: CtOrigin
orig@(TypeEqOrigin {}) = CtOrigin
orig { uo_visible = False }
toInvisibleOrigin CtOrigin
orig                   = CtOrigin
orig

isGivenOrigin :: CtOrigin -> Bool
isGivenOrigin :: CtOrigin -> Bool
isGivenOrigin (GivenOrigin {})       = Bool
True
isGivenOrigin (GivenSCOrigin {})     = Bool
True
isGivenOrigin (CycleBreakerOrigin CtOrigin
o) = CtOrigin -> Bool
isGivenOrigin CtOrigin
o
isGivenOrigin CtOrigin
_                      = Bool
False

-- See Note [Suppressing confusing errors] in GHC.Tc.Errors
isWantedWantedFunDepOrigin :: CtOrigin -> Bool
isWantedWantedFunDepOrigin :: CtOrigin -> Bool
isWantedWantedFunDepOrigin (FunDepOrigin1 TcType
_ CtOrigin
orig1 RealSrcSpan
_ TcType
_ CtOrigin
orig2 RealSrcSpan
_)
  = Bool -> Bool
not (CtOrigin -> Bool
isGivenOrigin CtOrigin
orig1) Bool -> Bool -> Bool
&& Bool -> Bool
not (CtOrigin -> Bool
isGivenOrigin CtOrigin
orig2)
isWantedWantedFunDepOrigin (InjTFOrigin1 TcType
_ CtOrigin
orig1 RealSrcSpan
_ TcType
_ CtOrigin
orig2 RealSrcSpan
_)
  = Bool -> Bool
not (CtOrigin -> Bool
isGivenOrigin CtOrigin
orig1) Bool -> Bool -> Bool
&& Bool -> Bool
not (CtOrigin -> Bool
isGivenOrigin CtOrigin
orig2)
isWantedWantedFunDepOrigin CtOrigin
_ = Bool
False

-- | Did a constraint arise from expanding a Wanted constraint
-- to look at superclasses?
isWantedSuperclassOrigin :: CtOrigin -> Bool
isWantedSuperclassOrigin :: CtOrigin -> Bool
isWantedSuperclassOrigin (WantedSuperclassOrigin {}) = Bool
True
isWantedSuperclassOrigin CtOrigin
_                           = Bool
False

instance Outputable CtOrigin where
  ppr :: CtOrigin -> SDoc
ppr = CtOrigin -> SDoc
pprCtOrigin

ctoHerald :: SDoc
ctoHerald :: SDoc
ctoHerald = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"arising from"

-- | Extract a suitable CtOrigin from a HsExpr
lexprCtOrigin :: LHsExpr GhcRn -> CtOrigin
lexprCtOrigin :: LHsExpr GhcRn -> CtOrigin
lexprCtOrigin (L SrcSpanAnnA
_ HsExpr GhcRn
e) = HsExpr GhcRn -> CtOrigin
exprCtOrigin HsExpr GhcRn
e

exprCtOrigin :: HsExpr GhcRn -> CtOrigin
exprCtOrigin :: HsExpr GhcRn -> CtOrigin
exprCtOrigin (HsVar XVar GhcRn
_ (L SrcSpanAnnN
_ Name
name)) = Name -> CtOrigin
OccurrenceOf Name
name
exprCtOrigin (HsGetField XGetField GhcRn
_ LHsExpr GhcRn
_ (L EpAnnCO
_ DotFieldOcc GhcRn
f)) = FastString -> CtOrigin
HasFieldOrigin (FieldLabelString -> FastString
field_label (FieldLabelString -> FastString) -> FieldLabelString -> FastString
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnN FieldLabelString -> FieldLabelString
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnN FieldLabelString -> FieldLabelString)
-> GenLocated SrcSpanAnnN FieldLabelString -> FieldLabelString
forall a b. (a -> b) -> a -> b
$ DotFieldOcc GhcRn -> XRec GhcRn FieldLabelString
forall p. DotFieldOcc p -> XRec p FieldLabelString
dfoLabel DotFieldOcc GhcRn
f)
exprCtOrigin (HsUnboundVar {})    = String -> CtOrigin
Shouldn'tHappenOrigin String
"unbound variable"
exprCtOrigin (HsRecSel XRecSel GhcRn
_ FieldOcc GhcRn
f)       = RdrName -> CtOrigin
OccurrenceOfRecSel (GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnN RdrName -> RdrName)
-> GenLocated SrcSpanAnnN RdrName -> RdrName
forall a b. (a -> b) -> a -> b
$ FieldOcc GhcRn -> XRec GhcRn RdrName
forall pass. FieldOcc pass -> XRec pass RdrName
foLabel FieldOcc GhcRn
f)
exprCtOrigin (HsOverLabel XOverLabel GhcRn
_ FastString
l)  = FastString -> CtOrigin
OverLabelOrigin FastString
l
exprCtOrigin (ExplicitList {})    = CtOrigin
ListOrigin
exprCtOrigin (HsIPVar XIPVar GhcRn
_ HsIPName
ip)       = HsIPName -> CtOrigin
IPOccOrigin HsIPName
ip
exprCtOrigin (HsOverLit XOverLitE GhcRn
_ HsOverLit GhcRn
lit)    = HsOverLit GhcRn -> CtOrigin
LiteralOrigin HsOverLit GhcRn
lit
exprCtOrigin (HsLit {})           = String -> CtOrigin
Shouldn'tHappenOrigin String
"concrete literal"
exprCtOrigin (HsLam XLam GhcRn
_ HsLamVariant
_ MatchGroup GhcRn (LHsExpr GhcRn)
ms)       = MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin
matchesCtOrigin MatchGroup GhcRn (LHsExpr GhcRn)
ms
exprCtOrigin (HsApp XApp GhcRn
_ LHsExpr GhcRn
e1 LHsExpr GhcRn
_)       = LHsExpr GhcRn -> CtOrigin
lexprCtOrigin LHsExpr GhcRn
e1
exprCtOrigin (HsAppType XAppTypeE GhcRn
_ LHsExpr GhcRn
e1 LHsWcType (NoGhcTc GhcRn)
_)   = LHsExpr GhcRn -> CtOrigin
lexprCtOrigin LHsExpr GhcRn
e1
exprCtOrigin (OpApp XOpApp GhcRn
_ LHsExpr GhcRn
_ LHsExpr GhcRn
op LHsExpr GhcRn
_)     = LHsExpr GhcRn -> CtOrigin
lexprCtOrigin LHsExpr GhcRn
op
exprCtOrigin (NegApp XNegApp GhcRn
_ LHsExpr GhcRn
e SyntaxExpr GhcRn
_)       = LHsExpr GhcRn -> CtOrigin
lexprCtOrigin LHsExpr GhcRn
e
exprCtOrigin (HsPar XPar GhcRn
_ LHsExpr GhcRn
e)          = LHsExpr GhcRn -> CtOrigin
lexprCtOrigin LHsExpr GhcRn
e
exprCtOrigin (HsProjection XProjection GhcRn
_ NonEmpty (XRec GhcRn (DotFieldOcc GhcRn))
_)   = CtOrigin
SectionOrigin
exprCtOrigin (SectionL XSectionL GhcRn
_ LHsExpr GhcRn
_ LHsExpr GhcRn
_)     = CtOrigin
SectionOrigin
exprCtOrigin (SectionR XSectionR GhcRn
_ LHsExpr GhcRn
_ LHsExpr GhcRn
_)     = CtOrigin
SectionOrigin
exprCtOrigin (ExplicitTuple {})   = String -> CtOrigin
Shouldn'tHappenOrigin String
"explicit tuple"
exprCtOrigin ExplicitSum{}        = String -> CtOrigin
Shouldn'tHappenOrigin String
"explicit sum"
exprCtOrigin (HsCase XCase GhcRn
_ LHsExpr GhcRn
_ MatchGroup GhcRn (LHsExpr GhcRn)
matches) = MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin
matchesCtOrigin MatchGroup GhcRn (LHsExpr GhcRn)
matches
exprCtOrigin (HsIf {})           = CtOrigin
IfThenElseOrigin
exprCtOrigin (HsMultiIf XMultiIf GhcRn
_ [LGRHS GhcRn (LHsExpr GhcRn)]
rhs)   = [LGRHS GhcRn (LHsExpr GhcRn)] -> CtOrigin
lGRHSCtOrigin [LGRHS GhcRn (LHsExpr GhcRn)]
rhs
exprCtOrigin (HsLet XLet GhcRn
_ HsLocalBinds GhcRn
_ LHsExpr GhcRn
e)       = LHsExpr GhcRn -> CtOrigin
lexprCtOrigin LHsExpr GhcRn
e
exprCtOrigin (HsDo {})           = CtOrigin
DoOrigin
exprCtOrigin (RecordCon {})      = String -> CtOrigin
Shouldn'tHappenOrigin String
"record construction"
exprCtOrigin (RecordUpd {})      = CtOrigin
RecordUpdOrigin
exprCtOrigin (ExprWithTySig {})  = CtOrigin
ExprSigOrigin
exprCtOrigin (ArithSeq {})       = String -> CtOrigin
Shouldn'tHappenOrigin String
"arithmetic sequence"
exprCtOrigin (HsPragE XPragE GhcRn
_ HsPragE GhcRn
_ LHsExpr GhcRn
e)     = LHsExpr GhcRn -> CtOrigin
lexprCtOrigin LHsExpr GhcRn
e
exprCtOrigin (HsTypedBracket {}) = String -> CtOrigin
Shouldn'tHappenOrigin String
"TH typed bracket"
exprCtOrigin (HsUntypedBracket {}) = String -> CtOrigin
Shouldn'tHappenOrigin String
"TH untyped bracket"
exprCtOrigin (HsTypedSplice {})    = String -> CtOrigin
Shouldn'tHappenOrigin String
"TH typed splice"
exprCtOrigin (HsUntypedSplice {})  = String -> CtOrigin
Shouldn'tHappenOrigin String
"TH untyped splice"
exprCtOrigin (HsProc {})         = String -> CtOrigin
Shouldn'tHappenOrigin String
"proc"
exprCtOrigin (HsStatic {})       = String -> CtOrigin
Shouldn'tHappenOrigin String
"static expression"
exprCtOrigin (HsEmbTy {})        = String -> CtOrigin
Shouldn'tHappenOrigin String
"type expression"
exprCtOrigin (HsForAll {})       = String -> CtOrigin
Shouldn'tHappenOrigin String
"forall telescope"    -- See Note [Types in terms]
exprCtOrigin (HsQual {})         = String -> CtOrigin
Shouldn'tHappenOrigin String
"constraint context"  -- See Note [Types in terms]
exprCtOrigin (HsFunArr {})       = String -> CtOrigin
Shouldn'tHappenOrigin String
"function arrow"      -- See Note [Types in terms]
exprCtOrigin (XExpr (ExpandedThingRn HsThingRn
thing HsExpr GhcRn
_)) | OrigExpr HsExpr GhcRn
a <- HsThingRn
thing = HsExpr GhcRn -> CtOrigin
exprCtOrigin HsExpr GhcRn
a
                                               | OrigStmt ExprLStmt GhcRn
_ <- HsThingRn
thing = CtOrigin
DoOrigin
                                               | OrigPat LPat GhcRn
p  <- HsThingRn
thing = LPat GhcRn -> CtOrigin
DoPatOrigin LPat GhcRn
p
exprCtOrigin (XExpr (PopErrCtxt {})) = String -> CtOrigin
Shouldn'tHappenOrigin String
"PopErrCtxt"

-- | Extract a suitable CtOrigin from a MatchGroup
matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin
matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin
matchesCtOrigin (MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts = XRec GhcRn [LMatch GhcRn (LHsExpr GhcRn)]
alts })
  | L SrcSpanAnnL
_ [L SrcSpanAnnA
_ Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
match] <- XRec GhcRn [LMatch GhcRn (LHsExpr GhcRn)]
alts
  , Match { m_grhss :: forall p body. Match p body -> GRHSs p body
m_grhss = GRHSs GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
grhss } <- Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
match
  = GRHSs GhcRn (LHsExpr GhcRn) -> CtOrigin
grhssCtOrigin GRHSs GhcRn (LHsExpr GhcRn)
GRHSs GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
grhss

  | Bool
otherwise
  = String -> CtOrigin
Shouldn'tHappenOrigin String
"multi-way match"

-- | Extract a suitable CtOrigin from guarded RHSs
grhssCtOrigin :: GRHSs GhcRn (LHsExpr GhcRn) -> CtOrigin
grhssCtOrigin :: GRHSs GhcRn (LHsExpr GhcRn) -> CtOrigin
grhssCtOrigin (GRHSs { grhssGRHSs :: forall p body. GRHSs p body -> [LGRHS p body]
grhssGRHSs = [LGRHS GhcRn (LHsExpr GhcRn)]
lgrhss }) = [LGRHS GhcRn (LHsExpr GhcRn)] -> CtOrigin
lGRHSCtOrigin [LGRHS GhcRn (LHsExpr GhcRn)]
lgrhss

-- | Extract a suitable CtOrigin from a list of guarded RHSs
lGRHSCtOrigin :: [LGRHS GhcRn (LHsExpr GhcRn)] -> CtOrigin
lGRHSCtOrigin :: [LGRHS GhcRn (LHsExpr GhcRn)] -> CtOrigin
lGRHSCtOrigin [L EpAnnCO
_ (GRHS XCGRHS GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
_ [ExprLStmt GhcRn]
_ (L SrcSpanAnnA
_ HsExpr GhcRn
e))] = HsExpr GhcRn -> CtOrigin
exprCtOrigin HsExpr GhcRn
e
lGRHSCtOrigin [LGRHS GhcRn (LHsExpr GhcRn)]
_ = String -> CtOrigin
Shouldn'tHappenOrigin String
"multi-way GRHS"

pprCtOrigin :: CtOrigin -> SDoc
-- "arising from ..."
pprCtOrigin :: CtOrigin -> SDoc
pprCtOrigin (GivenOrigin SkolemInfoAnon
sk)
  = SDoc
ctoHerald SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SkolemInfoAnon -> SDoc
forall a. Outputable a => a -> SDoc
ppr SkolemInfoAnon
sk

pprCtOrigin (GivenSCOrigin SkolemInfoAnon
sk ScDepth
d Bool
blk)
  = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ SDoc
ctoHerald SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SkolemInfoAnon -> SDoc
pprSkolInfo SkolemInfoAnon
sk
         , SDoc -> SDoc
forall doc. IsOutput doc => doc -> doc
whenPprDebug (SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"given-sc:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ScDepth -> SDoc
forall a. Outputable a => a -> SDoc
ppr ScDepth
d SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
blk)) ]

pprCtOrigin (SpecPragOrigin UserTypeCtxt
ctxt)
  = case UserTypeCtxt
ctxt of
       FunSigCtxt Name
n ReportRedundantConstraints
_ -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n)
       UserTypeCtxt
SpecInstCtxt   -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a SPECIALISE INSTANCE pragma"
       UserTypeCtxt
_              -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a SPECIALISE pragma"  -- Never happens I think

pprCtOrigin (FunDepOrigin1 TcType
pred1 CtOrigin
orig1 RealSrcSpan
loc1 TcType
pred2 CtOrigin
orig2 RealSrcSpan
loc2)
  = SDoc -> ScDepth -> SDoc -> SDoc
hang (SDoc
ctoHerald SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a functional dependency between constraints:")
       ScDepth
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ SDoc -> ScDepth -> SDoc -> SDoc
hang (SDoc -> SDoc
quotes (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
pred1)) ScDepth
2 (CtOrigin -> SDoc
pprCtOrigin CtOrigin
orig1 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"at" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> RealSrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr RealSrcSpan
loc1)
               , SDoc -> ScDepth -> SDoc -> SDoc
hang (SDoc -> SDoc
quotes (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
pred2)) ScDepth
2 (CtOrigin -> SDoc
pprCtOrigin CtOrigin
orig2 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"at" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> RealSrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr RealSrcSpan
loc2) ])

pprCtOrigin (FunDepOrigin2 TcType
pred1 CtOrigin
orig1 TcType
pred2 SrcSpan
loc2)
  = SDoc -> ScDepth -> SDoc -> SDoc
hang (SDoc
ctoHerald SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a functional dependency between:")
       ScDepth
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ SDoc -> ScDepth -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"constraint" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
pred1))
                    ScDepth
2 (CtOrigin -> SDoc
pprCtOrigin CtOrigin
orig1 )
               , SDoc -> ScDepth -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"instance" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
pred2))
                    ScDepth
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"at" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
loc2) ])

pprCtOrigin (InjTFOrigin1 TcType
pred1 CtOrigin
orig1 RealSrcSpan
loc1 TcType
pred2 CtOrigin
orig2 RealSrcSpan
loc2)
  = SDoc -> ScDepth -> SDoc -> SDoc
hang (SDoc
ctoHerald SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"reasoning about an injective type family using constraints:")
       ScDepth
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ SDoc -> ScDepth -> SDoc -> SDoc
hang (SDoc -> SDoc
quotes (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
pred1)) ScDepth
2 (CtOrigin -> SDoc
pprCtOrigin CtOrigin
orig1 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"at" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> RealSrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr RealSrcSpan
loc1)
               , SDoc -> ScDepth -> SDoc -> SDoc
hang (SDoc -> SDoc
quotes (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
pred2)) ScDepth
2 (CtOrigin -> SDoc
pprCtOrigin CtOrigin
orig2 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"at" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> RealSrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr RealSrcSpan
loc2) ])

pprCtOrigin CtOrigin
AssocFamPatOrigin
  = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"when matching a family LHS with its class instance head"

pprCtOrigin (TypeEqOrigin { uo_actual :: CtOrigin -> TcType
uo_actual = TcType
t1, uo_expected :: CtOrigin -> TcType
uo_expected =  TcType
t2, uo_visible :: CtOrigin -> Bool
uo_visible = Bool
vis })
  = SDoc -> ScDepth -> SDoc -> SDoc
hang (SDoc
ctoHerald SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a type equality" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsOutput doc => doc -> doc
whenPprDebug (SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
vis)))
       ScDepth
2 ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
t1, Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'~', TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
t2])

pprCtOrigin (KindEqOrigin TcType
t1 TcType
t2 CtOrigin
_ Maybe TypeOrKind
_)
  = SDoc -> ScDepth -> SDoc -> SDoc
hang (SDoc
ctoHerald SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a kind equality arising from")
       ScDepth
2 ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
t1, Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'~', TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
t2])

pprCtOrigin (DerivOriginDC DataCon
dc ScDepth
n Bool
_)
  = SDoc -> ScDepth -> SDoc -> SDoc
hang (SDoc
ctoHerald SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ScDepth -> SDoc
speakNth ScDepth
n
          SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"field of" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
dc))
       ScDepth
2 (SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"type" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Scaled TcType -> TcType
forall a. Scaled a -> a
scaledThing Scaled TcType
ty))))
  where
    ty :: Scaled TcType
ty = DataCon -> [Scaled TcType]
dataConOrigArgTys DataCon
dc [Scaled TcType] -> ScDepth -> Scaled TcType
forall a. HasCallStack => [a] -> ScDepth -> a
!! (ScDepth
nScDepth -> ScDepth -> ScDepth
forall a. Num a => a -> a -> a
-ScDepth
1)

pprCtOrigin (DerivOriginCoerce Id
meth TcType
ty1 TcType
ty2 Bool
_)
  = SDoc -> ScDepth -> SDoc -> SDoc
hang (SDoc
ctoHerald SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the coercion of the method" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
meth))
       ScDepth
2 ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"from type" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty1)
              , ScDepth -> SDoc -> SDoc
nest ScDepth
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"to type" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty2) ])

pprCtOrigin (DoPatOrigin LPat GhcRn
pat)
    = SDoc
ctoHerald SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a do statement"
      SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
      String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"with the failable pattern" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (GenLocated SrcSpanAnnA (Pat GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LPat GhcRn
GenLocated SrcSpanAnnA (Pat GhcRn)
pat)

pprCtOrigin (MCompPatOrigin LPat GhcRn
pat)
    = SDoc
ctoHerald SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the failable pattern"
           , SDoc -> SDoc
quotes (GenLocated SrcSpanAnnA (Pat GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LPat GhcRn
GenLocated SrcSpanAnnA (Pat GhcRn)
pat)
           , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in a statement in a monad comprehension" ]

pprCtOrigin (Shouldn'tHappenOrigin String
note)
  = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<< This should not appear in error messages. If you see this"
         , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in an error message, please report a bug mentioning"
             SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
note) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"at"
         , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"https://gitlab.haskell.org/ghc/ghc/wikis/report-a-bug >>"
         ]

pprCtOrigin (ProvCtxtOrigin PSB{ psb_id :: forall idL idR. PatSynBind idL idR -> LIdP idL
psb_id = (L SrcSpanAnnN
_ Name
name) })
  = SDoc -> ScDepth -> SDoc -> SDoc
hang (SDoc
ctoHerald SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the \"provided\" constraints claimed by")
       ScDepth
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the signature of" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name))

pprCtOrigin (InstProvidedOrigin Module
mod ClsInst
cls_inst)
  = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"arising when attempting to show that"
         , ClsInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr ClsInst
cls_inst
         , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"is provided by" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod)]

pprCtOrigin (ImpedanceMatching Id
x)
  = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"arising when matching required constraints"
         , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in a group involving" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
x)]

pprCtOrigin (CycleBreakerOrigin CtOrigin
orig)
  = CtOrigin -> SDoc
pprCtOrigin CtOrigin
orig

pprCtOrigin (WantedSuperclassOrigin TcType
subclass_pred CtOrigin
subclass_orig)
  = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [ SDoc
ctoHerald SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a superclass required to satisfy" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
subclass_pred) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma
        , CtOrigin -> SDoc
pprCtOrigin CtOrigin
subclass_orig ]

pprCtOrigin (InstanceSigOrigin Name
method_name TcType
sig_type TcType
orig_method_type)
  = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ SDoc
ctoHerald SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the check that an instance signature is more general"
         , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"than the type of the method (instantiated for this instance)"
         , SDoc -> ScDepth -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"instance signature:")
              ScDepth
2 (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
method_name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
sig_type)
         , SDoc -> ScDepth -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"instantiated method type:")
              ScDepth
2 (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
orig_method_type) ]

pprCtOrigin (AmbiguityCheckOrigin UserTypeCtxt
ctxt)
  = SDoc
ctoHerald SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a type ambiguity check for" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
    UserTypeCtxt -> SDoc
pprUserTypeCtxt UserTypeCtxt
ctxt

pprCtOrigin (ScOrigin ClsInstOrQC
IsClsInst NakedScFlag
nkd)
  = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ SDoc
ctoHerald SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the superclasses of an instance declaration"
         , SDoc -> SDoc
forall doc. IsOutput doc => doc -> doc
whenPprDebug (SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"sc-origin:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> NakedScFlag -> SDoc
forall a. Outputable a => a -> SDoc
ppr NakedScFlag
nkd)) ]

pprCtOrigin (ScOrigin (IsQC CtOrigin
orig) NakedScFlag
nkd)
  = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ SDoc
ctoHerald SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the head of a quantified constraint"
         , SDoc -> SDoc
forall doc. IsOutput doc => doc -> doc
whenPprDebug (SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"sc-origin:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> NakedScFlag -> SDoc
forall a. Outputable a => a -> SDoc
ppr NakedScFlag
nkd))
         , CtOrigin -> SDoc
pprCtOrigin CtOrigin
orig ]

pprCtOrigin (NonLinearPatternOrigin NonLinearPatternReason
reason LPat GhcRn
pat)
  = SDoc -> ScDepth -> SDoc -> SDoc
hang (SDoc
ctoHerald SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a non-linear pattern" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (GenLocated SrcSpanAnnA (Pat GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LPat GhcRn
GenLocated SrcSpanAnnA (Pat GhcRn)
pat))
       ScDepth
2 (HasDebugCallStack => NonLinearPatternReason -> SDoc
NonLinearPatternReason -> SDoc
pprNonLinearPatternReason NonLinearPatternReason
reason)

pprCtOrigin CtOrigin
simple_origin
  = SDoc
ctoHerald SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HasDebugCallStack => CtOrigin -> SDoc
CtOrigin -> SDoc
pprCtO CtOrigin
simple_origin

-- | Short one-liners
pprCtO :: HasDebugCallStack => CtOrigin -> SDoc
pprCtO :: HasDebugCallStack => CtOrigin -> SDoc
pprCtO (OccurrenceOf Name
name)   = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a use of", SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)]
pprCtO (OccurrenceOfRecSel RdrName
name) = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a use of", SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
name)]
pprCtO CtOrigin
AppOrigin             = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"an application"
pprCtO (IPOccOrigin HsIPName
name)    = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a use of implicit parameter", SDoc -> SDoc
quotes (HsIPName -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsIPName
name)]
pprCtO (OverLabelOrigin FastString
l)   = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the overloaded label"
                                    ,SDoc -> SDoc
quotes (Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'#' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> FastString -> SDoc
forall a. Outputable a => a -> SDoc
ppr FastString
l)]
pprCtO CtOrigin
RecordUpdOrigin       = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a record update"
pprCtO CtOrigin
ExprSigOrigin         = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"an expression type signature"
pprCtO CtOrigin
PatSigOrigin          = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a pattern type signature"
pprCtO CtOrigin
PatOrigin             = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a pattern"
pprCtO CtOrigin
ViewPatOrigin         = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a view pattern"
pprCtO (LiteralOrigin HsOverLit GhcRn
lit)   = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the literal", SDoc -> SDoc
quotes (HsOverLit GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsOverLit GhcRn
lit)]
pprCtO (ArithSeqOrigin ArithSeqInfo GhcRn
seq)  = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the arithmetic sequence", SDoc -> SDoc
quotes (ArithSeqInfo GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr ArithSeqInfo GhcRn
seq)]
pprCtO CtOrigin
SectionOrigin         = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"an operator section"
pprCtO (HasFieldOrigin FastString
f)    = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"selecting the field", SDoc -> SDoc
quotes (FastString -> SDoc
forall a. Outputable a => a -> SDoc
ppr FastString
f)]
pprCtO CtOrigin
AssocFamPatOrigin     = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the LHS of a family instance"
pprCtO CtOrigin
TupleOrigin           = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a tuple"
pprCtO CtOrigin
NegateOrigin          = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a use of syntactic negation"
pprCtO (ScOrigin ClsInstOrQC
IsClsInst NakedScFlag
_) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the superclasses of an instance declaration"
pprCtO (ScOrigin (IsQC {}) NakedScFlag
_) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the head of a quantified constraint"
pprCtO CtOrigin
DerivClauseOrigin     = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the 'deriving' clause of a data type declaration"
pprCtO CtOrigin
StandAloneDerivOrigin = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a 'deriving' declaration"
pprCtO CtOrigin
DefaultOrigin         = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a 'default' declaration"
pprCtO CtOrigin
DoOrigin              = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a do statement"
pprCtO CtOrigin
MCompOrigin           = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a statement in a monad comprehension"
pprCtO CtOrigin
ProcOrigin            = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a proc expression"
pprCtO CtOrigin
ArrowCmdOrigin        = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"an arrow command"
pprCtO CtOrigin
AnnOrigin             = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"an annotation"
pprCtO (ExprHoleOrigin Maybe RdrName
Nothing)    = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"an expression hole"
pprCtO (ExprHoleOrigin (Just RdrName
occ)) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a use of" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
occ)
pprCtO (TypeHoleOrigin OccName
occ)  = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a use of wildcard" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
occ)
pprCtO CtOrigin
PatCheckOrigin        = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a pattern-match completeness check"
pprCtO CtOrigin
ListOrigin            = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"an overloaded list"
pprCtO CtOrigin
IfThenElseOrigin      = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"an if-then-else expression"
pprCtO CtOrigin
StaticOrigin          = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a static form"
pprCtO (UsageEnvironmentOf Name
x) = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"multiplicity of", SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
x)]
pprCtO (OmittedFieldOrigin Maybe FieldLabel
Nothing) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"an omitted anonymous field"
pprCtO (OmittedFieldOrigin (Just FieldLabel
fl)) = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"omitted field" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (FieldLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr FieldLabel
fl)]
pprCtO CtOrigin
BracketOrigin         = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a quotation bracket"

-- These ones are handled by pprCtOrigin, but we nevertheless sometimes
-- get here via callStackOriginFS, when doing ambiguity checks
-- A bit silly, but no great harm
pprCtO (GivenOrigin {})             = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a given constraint"
pprCtO (GivenSCOrigin {})           = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the superclass of a given constraint"
pprCtO (SpecPragOrigin {})          = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a SPECIALISE pragma"
pprCtO (FunDepOrigin1 {})           = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a functional dependency"
pprCtO (FunDepOrigin2 {})           = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a functional dependency"
pprCtO (InjTFOrigin1 {})            = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"an injective type family"
pprCtO (TypeEqOrigin {})            = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a type equality"
pprCtO (KindEqOrigin {})            = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a kind equality"
pprCtO (DerivOriginDC {})           = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a deriving clause"
pprCtO (DerivOriginCoerce {})       = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a derived method"
pprCtO (DoPatOrigin {})             = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a do statement"
pprCtO (MCompPatOrigin {})          = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a monad comprehension pattern"
pprCtO (Shouldn'tHappenOrigin String
note) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
note
pprCtO (ProvCtxtOrigin {})          = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a provided constraint"
pprCtO (InstProvidedOrigin {})      = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a provided constraint"
pprCtO (CycleBreakerOrigin CtOrigin
orig)    = HasDebugCallStack => CtOrigin -> SDoc
CtOrigin -> SDoc
pprCtO CtOrigin
orig
pprCtO (FRROrigin {})               = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a representation-polymorphism check"
pprCtO (WantedSuperclassOrigin {})  = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a superclass constraint"
pprCtO (InstanceSigOrigin {})       = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a type signature in an instance"
pprCtO (AmbiguityCheckOrigin {})    = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a type ambiguity check"
pprCtO (ImpedanceMatching {})       = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"combining required constraints"
pprCtO (NonLinearPatternOrigin NonLinearPatternReason
_ LPat GhcRn
pat) = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a non-linear pattern" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (GenLocated SrcSpanAnnA (Pat GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LPat GhcRn
GenLocated SrcSpanAnnA (Pat GhcRn)
pat)]

pprNonLinearPatternReason :: HasDebugCallStack => NonLinearPatternReason -> SDoc
pprNonLinearPatternReason :: HasDebugCallStack => NonLinearPatternReason -> SDoc
pprNonLinearPatternReason NonLinearPatternReason
LazyPatternReason = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"non-variable lazy pattern aren't linear")
pprNonLinearPatternReason NonLinearPatternReason
GeneralisedPatternReason = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"non-variable pattern bindings that have been generalised aren't linear")
pprNonLinearPatternReason NonLinearPatternReason
PatternSynonymReason = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"pattern synonyms aren't linear")
pprNonLinearPatternReason NonLinearPatternReason
ViewPatternReason = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"view patterns aren't linear")
pprNonLinearPatternReason NonLinearPatternReason
OtherPatternReason = SDoc
forall doc. IsOutput doc => doc
empty


{- *********************************************************************
*                                                                      *
             CallStacks and CtOrigin

    See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence
*                                                                      *
********************************************************************* -}

isPushCallStackOrigin :: CtOrigin -> Bool
-- Do we want to solve this IP constraint directly (return False)
-- or push the call site (return True)
-- See Note [Overview of implicit CallStacks] in GHc.Tc.Types.Evidence
isPushCallStackOrigin :: CtOrigin -> Bool
isPushCallStackOrigin (IPOccOrigin {}) = Bool
False
isPushCallStackOrigin CtOrigin
_                = Bool
True


callStackOriginFS :: CtOrigin -> FastString
-- This is the string that appears in the CallStack
callStackOriginFS :: CtOrigin -> FastString
callStackOriginFS (OccurrenceOf Name
fun) = OccName -> FastString
occNameFS (Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
fun)
callStackOriginFS CtOrigin
orig               = String -> FastString
mkFastString (SDoc -> String
showSDocUnsafe (HasDebugCallStack => CtOrigin -> SDoc
CtOrigin -> SDoc
pprCtO CtOrigin
orig))

{-
************************************************************************
*                                                                      *
            Checking for representation polymorphism
*                                                                      *
************************************************************************

Note [Reporting representation-polymorphism errors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
As explained in Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete,
to check that (ty :: ki) has a fixed runtime representation, we emit
an equality constraint of the form

  ki ~# concrete_tv

where concrete_tv is a concrete metavariable. In this situation, we attach
a 'FixedRuntimeRepOrigin' to both the equality and the concrete type variable.
The 'FixedRuntimeRepOrigin' consists of two pieces of information:

  - the type 'ty' on which we performed the representation-polymorphism check,
  - a 'FixedRuntimeRepContext' which explains why we needed to perform a check
    (e.g. because 'ty' was the kind of a function argument, or of a bound variable
    in a lambda abstraction, ...).

This information gets passed along as we make progress on solving the constraint,
and if we end up with an unsolved constraint we can report an informative error
message to the user using the 'FixedRuntimeRepOrigin'.

The error reporting goes through two different paths:

  - constraints whose 'CtOrigin' contains a 'FixedRuntimeRepOrigin' are reported
    using 'mkFRRErr' in 'reportWanteds',
  - equality constraints in which one side is a concrete metavariable and the
    other side is not concrete are reported using 'mkTyVarEqErr'. In this case,
    we pass on the type variable and the non-concrete type for error reporting,
    using the 'frr_info_not_concrete' field.

This is why we have the 'FixedRuntimeRepErrorInfo' datatype: so that we can optionally
include this extra message about an unsolved equality between a concrete type variable
and a non-concrete type.
-}

-- | The context for a representation-polymorphism check.
--
-- For example, when typechecking @ \ (a :: k) -> ...@,
-- we are checking the type @a@ because it's the type of
-- a term variable bound in a lambda, so we use 'FRRBinder'.
data FixedRuntimeRepOrigin
  = FixedRuntimeRepOrigin
    { FixedRuntimeRepOrigin -> TcType
frr_type    :: Type
       -- ^ What type are we checking?
       -- For example, @a[tau]@ in @a[tau] :: TYPE rr[tau]@.

    , FixedRuntimeRepOrigin -> FixedRuntimeRepContext
frr_context :: FixedRuntimeRepContext
      -- ^ What context requires a fixed runtime representation?
    }

instance Outputable FixedRuntimeRepOrigin where
  ppr :: FixedRuntimeRepOrigin -> SDoc
ppr (FixedRuntimeRepOrigin { frr_type :: FixedRuntimeRepOrigin -> TcType
frr_type = TcType
ty, frr_context :: FixedRuntimeRepOrigin -> FixedRuntimeRepContext
frr_context = FixedRuntimeRepContext
cxt })
    = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"FrOrigin" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"frr_type:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty
                                      , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"frr_context:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FixedRuntimeRepContext -> SDoc
forall a. Outputable a => a -> SDoc
ppr FixedRuntimeRepContext
cxt ])

-- | The context in which a representation-polymorphism check was performed.
--
-- Does not include the type on which the check was performed; see
-- 'FixedRuntimeRepOrigin' for that.
data FixedRuntimeRepContext

  -- | Record fields in record construction must have a fixed runtime
  -- representation.
  = FRRRecordCon !RdrName !(HsExpr GhcTc)

  -- | Record fields in record updates must have a fixed runtime representation.
  --
  -- Test case: RepPolyRecordUpdate.
  | FRRRecordUpdate !Name !(HsExpr GhcRn)

  -- | Variable binders must have a fixed runtime representation.
  --
  -- Test cases: LevPolyLet, RepPolyPatBind.
  | FRRBinder !Name

  -- | Types appearing in negative position in the type of a
  -- representation-polymorphic 'Id' must have a fixed runtime representation.
  --
  -- This includes:
  --
  --  - arguments,
  --
  --    Test cases: RepPolyMagic, RepPolyRightSection, RepPolyWrappedVar,
  --                T14561b, T17817.
  --
  --  - continuation result types, such as in 'catch#', 'keepAlive#'
  --    and 'control0#'.
  --
  --    Test case: T21906.
  | FRRRepPolyId
      !Name
      !RepPolyId
      !(Position Neg)

  -- | A partial application of the constructor of a representation-polymorphic
  -- unlifted newtype in which the argument type does not have a fixed
  -- runtime representation.
  --
  -- Test cases: UnliftedNewtypesLevityBinder, UnliftedNewtypesCoerceFail.
  | FRRRepPolyUnliftedNewtype !DataCon

  -- | Pattern binds must have a fixed runtime representation.
  --
  -- Test case: RepPolyInferPatBind.
  | FRRPatBind

  -- | Pattern synonym arguments must have a fixed runtime representation.
  --
  -- Test case: RepPolyInferPatSyn.
  | FRRPatSynArg

  -- | The type of the scrutinee in a case statement must have a
  -- fixed runtime representation.
  --
  -- Test cases: RepPolyCase{1,2}.
  | FRRCase

  -- | An instantiation of a newtype/data constructor pattern in which
  -- an argument type does not have a fixed runtime representation.
  --
  -- Test case: T20363.
  | FRRDataConPatArg !DataCon !Int

  -- | The 'RuntimeRep' arguments to unboxed tuples must be concrete 'RuntimeRep's.
  --
  -- Test case: RepPolyTuple.
  | FRRUnboxedTuple !Int

  -- | Tuple sections must have a fixed runtime representation.
  --
  -- Test case: RepPolyTupleSection.
  | FRRUnboxedTupleSection !Int

  -- | The 'RuntimeRep' arguments to unboxed sums must be concrete 'RuntimeRep's.
  --
  -- Test cases: RepPolySum.
  | FRRUnboxedSum !(Maybe Int)

  -- | The body of a @do@ expression or a monad comprehension must
  -- have a fixed runtime representation.
  --
  -- Test cases: RepPolyDoBody{1,2}, RepPolyMcBody.
  | FRRBodyStmt !StmtOrigin !Int

  -- | Arguments to a guard in a monad comprehension must have
  -- a fixed runtime representation.
  --
  -- Test case: RepPolyMcGuard.
  | FRRBodyStmtGuard

  -- | Arguments to `(>>=)` arising from a @do@ expression
  -- or a monad comprehension must have a fixed runtime representation.
  --
  -- Test cases: RepPolyDoBind, RepPolyMcBind.
  | FRRBindStmt !StmtOrigin

  -- | A value bound by a pattern guard must have a fixed runtime representation.
  --
  -- Test cases: none.
  | FRRBindStmtGuard

  -- | A representation-polymorphism check arising from arrow notation.
  --
  -- See 'FRRArrowContext' for more details.
  | FRRArrow !FRRArrowContext

  -- | A representation-polymorphic check arising from a call
  -- to 'matchExpectedFunTys' or 'matchActualFunTy'.
  --
  -- See 'ExpectedFunTyOrigin' for more details.
  | FRRExpectedFunTy
      !ExpectedFunTyOrigin
      !Int
        -- ^ argument position (1-indexed)

-- | The description of a representation-polymorphic 'Id'.
data RepPolyId
  -- | A representation-polymorphic 'PrimOp'.
  = RepPolyPrimOp
  -- | An unboxed tuple constructor.
  | RepPolyTuple
  -- | An unboxed sum constructor.
  | RepPolySum
  -- | An unspecified representation-polymorphic function,
  -- e.g. a pseudo-op such as 'coerce'.
  | RepPolyFunction

-- | A synonym for 'FRRUnboxedTuple' exposed in the hs-boot file
-- for "GHC.Tc.Types.Origin".
mkFRRUnboxedTuple :: Int -> FixedRuntimeRepContext
mkFRRUnboxedTuple :: ScDepth -> FixedRuntimeRepContext
mkFRRUnboxedTuple = ScDepth -> FixedRuntimeRepContext
FRRUnboxedTuple

-- | A synonym for 'FRRUnboxedSum' exposed in the hs-boot file
-- for "GHC.Tc.Types.Origin".
mkFRRUnboxedSum :: Maybe Int -> FixedRuntimeRepContext
mkFRRUnboxedSum :: Maybe ScDepth -> FixedRuntimeRepContext
mkFRRUnboxedSum = Maybe ScDepth -> FixedRuntimeRepContext
FRRUnboxedSum

-- | Print the context for a @FixedRuntimeRep@ representation-polymorphism check.
--
-- Note that this function does not include the specific 'RuntimeRep'
-- which is not fixed. That information is stored in 'FixedRuntimeRepOrigin'
-- and is reported separately.
pprFixedRuntimeRepContext :: FixedRuntimeRepContext -> SDoc
pprFixedRuntimeRepContext :: FixedRuntimeRepContext -> SDoc
pprFixedRuntimeRepContext (FRRRecordCon RdrName
lbl HsExpr GhcTc
_arg)
  = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The field", SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
lbl)
        , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"of the record constructor" ]
pprFixedRuntimeRepContext (FRRRecordUpdate Name
lbl HsExpr GhcRn
_arg)
  = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The record update at field"
        , SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
lbl) ]
pprFixedRuntimeRepContext (FRRBinder Name
binder)
  = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The binder"
        , SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
binder) ]
pprFixedRuntimeRepContext (FRRRepPolyId Name
nm RepPolyId
id Position 'Neg
what)
  = RepPolyId -> Name -> Position 'Neg -> SDoc
pprFRRRepPolyId RepPolyId
id Name
nm Position 'Neg
what
pprFixedRuntimeRepContext FixedRuntimeRepContext
FRRPatBind
  = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The pattern binding"
pprFixedRuntimeRepContext FixedRuntimeRepContext
FRRPatSynArg
  = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The pattern synonym argument pattern"
pprFixedRuntimeRepContext FixedRuntimeRepContext
FRRCase
  = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The scrutinee of the case statement"
pprFixedRuntimeRepContext (FRRDataConPatArg DataCon
con ScDepth
i)
  = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
what
  where
    what :: SDoc
    what :: SDoc
what
      | DataCon -> Bool
isNewDataCon DataCon
con
      = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"newtype constructor pattern"
      | Bool
otherwise
      = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"data constructor pattern in" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ScDepth -> SDoc
speakNth ScDepth
i SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"position"
pprFixedRuntimeRepContext (FRRRepPolyUnliftedNewtype DataCon
dc)
  = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Unsaturated use of a representation-polymorphic unlifted newtype."
         , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The argument of the newtype constructor" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
dc) ]
pprFixedRuntimeRepContext (FRRUnboxedTuple ScDepth
i)
  = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ScDepth -> SDoc
speakNth ScDepth
i SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"component of the unboxed tuple"
pprFixedRuntimeRepContext (FRRUnboxedTupleSection ScDepth
i)
  = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ScDepth -> SDoc
speakNth ScDepth
i SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"component of the unboxed tuple section"
pprFixedRuntimeRepContext (FRRUnboxedSum Maybe ScDepth
Nothing)
  = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The unboxed sum"
pprFixedRuntimeRepContext (FRRUnboxedSum (Just ScDepth
i))
  = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ScDepth -> SDoc
speakNth ScDepth
i SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"component of the unboxed sum"
pprFixedRuntimeRepContext (FRRBodyStmt StmtOrigin
stmtOrig ScDepth
i)
  = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ScDepth -> SDoc
speakNth ScDepth
i SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"argument to (>>)" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma
         , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"arising from the" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> StmtOrigin -> SDoc
forall a. Outputable a => a -> SDoc
ppr StmtOrigin
stmtOrig SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma ]
pprFixedRuntimeRepContext FixedRuntimeRepContext
FRRBodyStmtGuard
  = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The argument to" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"guard") SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma
         , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"arising from the" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> StmtOrigin -> SDoc
forall a. Outputable a => a -> SDoc
ppr StmtOrigin
MonadComprehension SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma ]
pprFixedRuntimeRepContext (FRRBindStmt StmtOrigin
stmtOrig)
  = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The first argument to (>>=)" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma
         , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"arising from the" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> StmtOrigin -> SDoc
forall a. Outputable a => a -> SDoc
ppr StmtOrigin
stmtOrig SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma ]
pprFixedRuntimeRepContext FixedRuntimeRepContext
FRRBindStmtGuard
  = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The body of the bind statement" ]
pprFixedRuntimeRepContext (FRRArrow FRRArrowContext
arrowContext)
  = FRRArrowContext -> SDoc
pprFRRArrowContext FRRArrowContext
arrowContext
pprFixedRuntimeRepContext (FRRExpectedFunTy ExpectedFunTyOrigin
funTyOrig ScDepth
arg_pos)
  = ExpectedFunTyOrigin -> ScDepth -> SDoc
pprExpectedFunTyOrigin ExpectedFunTyOrigin
funTyOrig ScDepth
arg_pos

instance Outputable FixedRuntimeRepContext where
  ppr :: FixedRuntimeRepContext -> SDoc
ppr = FixedRuntimeRepContext -> SDoc
pprFixedRuntimeRepContext

-- | Are we in a @do@ expression or a monad comprehension?
--
-- This datatype is only used to report this context to the user in error messages.
data StmtOrigin
  = MonadComprehension
  | DoNotation

instance Outputable StmtOrigin where
  ppr :: StmtOrigin -> SDoc
ppr StmtOrigin
MonadComprehension = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"monad comprehension"
  ppr StmtOrigin
DoNotation         = SDoc -> SDoc
quotes ( String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"do" ) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"statement"

-- | The position of an argument (to be reported in an error message).
data ArgPos
  = ArgPosInvis
    -- ^ Invisible argument: don't report its position to the user.
  | ArgPosVis !Int
    -- ^ Visible argument in i-th position.

{- *********************************************************************
*                                                                      *
            FixedRuntimeRep: representation-polymorphic Ids
*                                                                      *
********************************************************************* -}

data Polarity = Pos | Neg

type FlipPolarity :: Polarity -> Polarity
type family FlipPolarity p where
  FlipPolarity Pos = Neg
  FlipPolarity Neg = Pos

-- | A position in which a type variable appears in a type;
-- in particular, whether it appears in a positive or a negative position.
type Position :: Polarity -> Hs.Type
data Position p where
  -- | In the @i@-th argument of a function arrow
  Argument :: Int -> Position (FlipPolarity p) -> Position p
  -- | In the result of a function arrow
  Result   :: Position p -> Position p
  -- | At the top level of a type
  Top      :: Position Pos

pprFRRRepPolyId :: RepPolyId -> Name -> Position Neg -> SDoc
pprFRRRepPolyId :: RepPolyId -> Name -> Position 'Neg -> SDoc
pprFRRRepPolyId RepPolyId
id Name
nm (Argument ScDepth
i Position (FlipPolarity 'Neg)
pos) =
  String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
what SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ScDepth -> SDoc
speakNth ScDepth
i SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"argument of" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> RepPolyId -> Name -> SDoc
pprRepPolyId RepPolyId
id Name
nm
  where
    what :: SDoc
what = case Position (FlipPolarity 'Neg)
pos of
      Position (FlipPolarity 'Neg)
Top       -> SDoc
forall doc. IsOutput doc => doc
empty
      Result {} -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"return type of the"
      Position (FlipPolarity 'Neg)
_         -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"nested return type inside the"
pprFRRRepPolyId RepPolyId
id Name
nm (Result {}) =
  String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The result of" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> RepPolyId -> Name -> SDoc
pprRepPolyId RepPolyId
id Name
nm

pprRepPolyId :: RepPolyId -> Name -> SDoc
pprRepPolyId :: RepPolyId -> Name -> SDoc
pprRepPolyId RepPolyId
id Name
nm = SDoc
id_desc SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
nm)
  where
    id_desc :: SDoc
id_desc = case RepPolyId
id of
      RepPolyPrimOp   {} -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the primop"
      RepPolySum      {} -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the unboxed sum constructor"
      RepPolyTuple    {} -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the unboxed tuple constructor"
      RepPolyFunction {} -> SDoc
forall doc. IsOutput doc => doc
empty

{- *********************************************************************
*                                                                      *
                       FixedRuntimeRep: arrows
*                                                                      *
********************************************************************* -}

-- | While typechecking arrow notation, in which context
-- did a representation polymorphism check arise?
--
-- See 'FixedRuntimeRepContext' for more general origins of
-- representation polymorphism checks.
data FRRArrowContext

  -- | The result of an arrow command does not have a fixed runtime representation.
  --
  -- Test case: RepPolyArrowCmd.
  = ArrowCmdResTy !(HsCmd GhcRn)

  -- | The argument to an arrow in an arrow command application does not have
  -- a fixed runtime representation.
  --
  -- Test cases: none.
  | ArrowCmdApp !(HsCmd GhcRn) !(HsExpr GhcRn)

  -- | A function in an arrow application does not have
  -- a fixed runtime representation.
  --
  -- Test cases: none.
  | ArrowCmdArrApp !(HsExpr GhcRn) !(HsExpr GhcRn) !HsArrAppType

  -- | The scrutinee type in an arrow command case statement does not have a
  -- fixed runtime representation.
  --
  -- Test cases: none.
  | ArrowCmdCase

  -- | The overall type of an arrow proc expression does not have
  -- a fixed runtime representation.
  --
  -- Test case: RepPolyArrowFun.
  | ArrowFun !(HsExpr GhcRn)

pprFRRArrowContext :: FRRArrowContext -> SDoc
pprFRRArrowContext :: FRRArrowContext -> SDoc
pprFRRArrowContext (ArrowCmdResTy HsCmd GhcRn
cmd)
  = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ SDoc -> ScDepth -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The arrow command") ScDepth
2 (SDoc -> SDoc
quotes (HsCmd GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsCmd GhcRn
cmd)) ]
pprFRRArrowContext (ArrowCmdApp HsCmd GhcRn
fun HsExpr GhcRn
arg)
  = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The argument in the arrow command application of"
         , ScDepth -> SDoc -> SDoc
nest ScDepth
2 (SDoc -> SDoc
quotes (HsCmd GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsCmd GhcRn
fun))
         , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"to"
         , ScDepth -> SDoc -> SDoc
nest ScDepth
2 (SDoc -> SDoc
quotes (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
arg)) ]
pprFRRArrowContext (ArrowCmdArrApp HsExpr GhcRn
fun HsExpr GhcRn
arg HsArrAppType
ho_app)
  = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The function in the" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsArrAppType -> SDoc
pprHsArrType HsArrAppType
ho_app SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"of"
         , ScDepth -> SDoc -> SDoc
nest ScDepth
2 (SDoc -> SDoc
quotes (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
fun))
         , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"to"
         , ScDepth -> SDoc -> SDoc
nest ScDepth
2 (SDoc -> SDoc
quotes (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
arg)) ]
pprFRRArrowContext FRRArrowContext
ArrowCmdCase
  = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The scrutinee of the arrow case command"
pprFRRArrowContext (ArrowFun HsExpr GhcRn
fun)
  = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The return type of the arrow function"
         , ScDepth -> SDoc -> SDoc
nest ScDepth
2 (SDoc -> SDoc
quotes (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
fun)) ]

instance Outputable FRRArrowContext where
  ppr :: FRRArrowContext -> SDoc
ppr = FRRArrowContext -> SDoc
pprFRRArrowContext

{- *********************************************************************
*                                                                      *
              FixedRuntimeRep: ExpectedFunTy origin
*                                                                      *
********************************************************************* -}

-- | In what context are we calling 'matchExpectedFunTys'
-- or 'matchActualFunTy'?
--
-- Used for two things:
--
--  1. Reporting error messages which explain that a function has been
--     given an unexpected number of arguments.
--     Uses 'pprExpectedFunTyHerald'.
--     See Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify.
--
--  2. Reporting representation-polymorphism errors when a function argument
--     doesn't have a fixed RuntimeRep as per Note [Fixed RuntimeRep]
--     in GHC.Tc.Utils.Concrete.
--     Uses 'pprExpectedFunTyOrigin'.
--     See 'FixedRuntimeRepContext' for the situations in which
--     representation-polymorphism checks are performed.
data ExpectedFunTyOrigin

  -- | A rebindable syntax operator is expected to have a function type.
  --
  -- Test cases for representation-polymorphism checks:
  --   RepPolyDoBind, RepPolyDoBody{1,2}, RepPolyMc{Bind,Body,Guard}, RepPolyNPlusK
  = forall (p :: Pass)
     . (OutputableBndrId p)
    => ExpectedFunTySyntaxOp !CtOrigin !(HsExpr (GhcPass p))
      -- ^ rebindable syntax operator

  -- | A view pattern must have a function type.
  --
  -- Test cases for representation-polymorphism checks:
  --   RepPolyBinder
  | ExpectedFunTyViewPat
    !(HsExpr GhcRn)
      -- ^ function used in the view pattern

  -- | Need to be able to extract an argument type from a function type.
  --
  -- Test cases for representation-polymorphism checks:
  --   RepPolyApp
  | forall (p :: Pass)
     . Outputable (HsExpr (GhcPass p)) => ExpectedFunTyArg
          !TypedThing
            -- ^ function
          !(HsExpr (GhcPass p))
            -- ^ argument

  -- | Ensure that a function defined by equations indeed has a function type
  -- with the appropriate number of arguments.
  --
  -- Test cases for representation-polymorphism checks:
  --   RepPolyBinder, RepPolyRecordPattern, RepPolyWildcardPattern
  | ExpectedFunTyMatches
      !TypedThing
        -- ^ name of the function
      !(MatchGroup GhcRn (LHsExpr GhcRn))
       -- ^ equations

  -- | Ensure that a lambda abstraction has a function type.
  --
  -- Test cases for representation-polymorphism checks:
  --   RepPolyLambda, RepPolyMatch
  | ExpectedFunTyLam HsLamVariant
      !(HsExpr GhcRn)
       -- ^ the entire lambda-case expression

pprExpectedFunTyOrigin :: ExpectedFunTyOrigin
                       -> Int -- ^ argument position (starting at 1)
                       -> SDoc
pprExpectedFunTyOrigin :: ExpectedFunTyOrigin -> ScDepth -> SDoc
pprExpectedFunTyOrigin ExpectedFunTyOrigin
funTy_origin ScDepth
i =
  case ExpectedFunTyOrigin
funTy_origin of
    ExpectedFunTySyntaxOp CtOrigin
orig HsExpr (GhcPass p)
op ->
      [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [ SDoc
the_arg_of
                 , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the rebindable syntax operator"
                 , SDoc -> SDoc
quotes (HsExpr (GhcPass p) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr (GhcPass p)
op) ]
           , ScDepth -> SDoc -> SDoc
nest ScDepth
2 (CtOrigin -> SDoc
forall a. Outputable a => a -> SDoc
ppr CtOrigin
orig) ]
    ExpectedFunTyViewPat HsExpr GhcRn
expr ->
      [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ SDoc
the_arg_of SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"the view pattern"
           , ScDepth -> SDoc -> SDoc
nest ScDepth
2 (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
expr) ]
    ExpectedFunTyArg TypedThing
fun HsExpr (GhcPass p)
arg ->
      [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The argument"
          , SDoc -> SDoc
quotes (HsExpr (GhcPass p) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr (GhcPass p)
arg)
          , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"of"
          , SDoc -> SDoc
quotes (TypedThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TypedThing
fun) ]
    ExpectedFunTyMatches TypedThing
fun (MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts = L SrcSpanAnnL
_ [GenLocated
   SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
alts })
      | [GenLocated
   SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
-> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated
   SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
alts
      -> SDoc
the_arg_of SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (TypedThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TypedThing
fun)
      | Bool
otherwise
      -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ScDepth -> SDoc
speakNth ScDepth
i SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"pattern in the equation" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [GenLocated
   SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
-> SDoc
forall a. [a] -> SDoc
plural [GenLocated
   SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
alts
     SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (TypedThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TypedThing
fun)
    ExpectedFunTyLam HsLamVariant
lam_variant HsExpr GhcRn
_ -> SDoc -> SDoc
binder_of (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ HsLamVariant -> SDoc
lamCaseKeyword HsLamVariant
lam_variant
  where
    the_arg_of :: SDoc
    the_arg_of :: SDoc
the_arg_of = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ScDepth -> SDoc
speakNth ScDepth
i SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"argument of"

    binder_of :: SDoc -> SDoc
    binder_of :: SDoc -> SDoc
binder_of SDoc
what = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The binder of the" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
what SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"expression"

pprExpectedFunTyHerald :: ExpectedFunTyOrigin -> SDoc
pprExpectedFunTyHerald :: ExpectedFunTyOrigin -> SDoc
pprExpectedFunTyHerald (ExpectedFunTySyntaxOp {})
  = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"This rebindable syntax expects a function with"
pprExpectedFunTyHerald (ExpectedFunTyViewPat {})
  = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"A view pattern expression expects"
pprExpectedFunTyHerald (ExpectedFunTyArg TypedThing
fun HsExpr (GhcPass p)
_)
  = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The function" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (TypedThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TypedThing
fun)
        , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"is applied to" ]
pprExpectedFunTyHerald (ExpectedFunTyMatches TypedThing
fun (MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts = L SrcSpanAnnL
_ [GenLocated
   SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
alts }))
  = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The equation" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [GenLocated
   SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
-> SDoc
forall a. [a] -> SDoc
plural [GenLocated
   SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
alts SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (TypedThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TypedThing
fun) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [GenLocated
   SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
-> SDoc
forall a. [a] -> SDoc
hasOrHave [GenLocated
   SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
alts
pprExpectedFunTyHerald (ExpectedFunTyLam HsLamVariant
lam_variant HsExpr GhcRn
expr)
  = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsLamVariant -> SDoc
lamCaseKeyword HsLamVariant
lam_variant SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"expression"
                     SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Depth -> SDoc -> SDoc
pprSetDepth (ScDepth -> Depth
PartWay ScDepth
1) (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
expr))
               -- The pprSetDepth makes the lambda abstraction print briefly
        , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"has" ]

{- *******************************************************************
*                                                                    *
                       InstanceWhat
*                                                                    *
**********************************************************************-}

-- | Indicates if Instance met the Safe Haskell overlapping instances safety
-- check.
--
-- See Note [Safe Haskell Overlapping Instances] in GHC.Tc.Solver
-- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver
type SafeOverlapping = Bool

data InstanceWhat  -- How did we solve this constraint?
  = BuiltinEqInstance    -- Built-in solver for (t1 ~ t2), (t1 ~~ t2), Coercible t1 t2
                         -- See GHC.Tc.Solver.InertSet Note [Solved dictionaries]

  | BuiltinTypeableInstance TyCon   -- Built-in solver for Typeable (T t1 .. tn)
                         -- See Note [Well-staged instance evidence]

  | BuiltinInstance      -- Built-in solver for (C t1 .. tn) where C is
                         --   KnownNat, .. etc (classes with no top-level evidence)

  | LocalInstance        -- Solved by a quantified constraint
                         -- See GHC.Tc.Solver.InertSet Note [Solved dictionaries]

  | TopLevInstance       -- Solved by a top-level instance decl
      { InstanceWhat -> Id
iw_dfun_id   :: DFunId
      , InstanceWhat -> Bool
iw_safe_over :: SafeOverlapping
      , InstanceWhat -> Maybe (WarningTxt GhcRn)
iw_warn      :: Maybe (WarningTxt GhcRn) }
            -- See Note [Implementation of deprecated instances]
            -- in GHC.Tc.Solver.Dict

instance Outputable InstanceWhat where
  ppr :: InstanceWhat -> SDoc
ppr InstanceWhat
BuiltinInstance   = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a built-in instance"
  ppr BuiltinTypeableInstance {} = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a built-in typeable instance"
  ppr InstanceWhat
BuiltinEqInstance = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a built-in equality instance"
  ppr InstanceWhat
LocalInstance     = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"a locally-quantified instance"
  ppr (TopLevInstance { iw_dfun_id :: InstanceWhat -> Id
iw_dfun_id = Id
dfun })
      = SDoc -> ScDepth -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"instance" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcType -> SDoc
pprSigmaType (Id -> TcType
idType Id
dfun))
           ScDepth
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"--" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
pprDefinedAt (Id -> Name
idName Id
dfun))