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

{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}

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

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

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

  -- * CtOrigin and CallStack
  isPushCallStackOrigin, callStackOriginFS,
  -- * FixedRuntimeRep origin
  FixedRuntimeRepOrigin(..), FixedRuntimeRepContext(..),
  pprFixedRuntimeRepContext,
  StmtOrigin(..),

  -- * Arrow command origin
  FRRArrowContext(..), pprFRRArrowContext,
  ExpectedFunTyOrigin(..), pprExpectedFunTyOrigin, pprExpectedFunTyHerald,

  ) 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.InstEnv
import GHC.Core.PatSyn
import GHC.Core.Multiplicity ( scaledThing )

import GHC.Unit.Module
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.Types.Unique
import GHC.Types.Unique.Supply

{- *********************************************************************
*                                                                      *
          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
         -- This 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

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

  | 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.
      (HsMatchContext GhcTc)
             -- 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-recursivive)
                        -- 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 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

  | QuantCtxtSkol       -- Quantified context, e.g.
                        --   f :: forall c. (forall a. c a => c [a]) => blah

  | 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 :: HasCallStack => SkolemInfo
unkSkol :: HasCallStack => SkolemInfo
unkSkol = Unique -> SkolemInfoAnon -> SkolemInfo
SkolemInfo (Int -> Unique
mkUniqueGrimily Int
0) SkolemInfoAnon
HasCallStack => SkolemInfoAnon
unkSkolAnon

unkSkolAnon :: HasCallStack => SkolemInfoAnon
unkSkolAnon :: HasCallStack => 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
  Unique
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
uniqFromMask Char
's'
  SkolemInfo -> m SkolemInfo
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Unique -> SkolemInfoAnon -> SkolemInfo
SkolemInfo Unique
u SkolemInfoAnon
sk_anon)

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


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
text String
"an explicit forall" SDoc -> SDoc -> SDoc
<+> TyVarBndrs -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyVarBndrs
tvs
pprSkolInfo (IPSkol [HsIPName]
ips)      = String -> SDoc
text String
"the implicit-parameter binding" SDoc -> SDoc -> SDoc
<> [HsIPName] -> SDoc
forall a. [a] -> SDoc
plural [HsIPName]
ips SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"for"
                                 SDoc -> SDoc -> SDoc
<+> (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
text String
"the deriving clause for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
pred)
pprSkolInfo SkolemInfoAnon
InstSkol          = String -> SDoc
text String
"the instance declaration"
pprSkolInfo SkolemInfoAnon
FamInstSkol       = String -> SDoc
text String
"a family instance declaration"
pprSkolInfo SkolemInfoAnon
BracketSkol       = String -> SDoc
text String
"a Template Haskell bracket"
pprSkolInfo (RuleSkol FastString
name)   = String -> SDoc
text String
"the RULE" SDoc -> SDoc -> SDoc
<+> FastString -> SDoc
pprRuleName FastString
name
pprSkolInfo (PatSkol ConLike
cl HsMatchContext GhcTc
mc)   = [SDoc] -> SDoc
sep [ ConLike -> SDoc
pprPatSkolInfo ConLike
cl
                                    , String -> SDoc
text String
"in" SDoc -> SDoc -> SDoc
<+> HsMatchContext GhcTc -> SDoc
forall p.
(Outputable (IdP p), UnXRec p) =>
HsMatchContext p -> SDoc
pprMatchContext HsMatchContext GhcTc
mc ]
pprSkolInfo (InferSkol [(Name, TcType)]
ids)   = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"the inferred type" SDoc -> SDoc -> SDoc
<> [(Name, TcType)] -> SDoc
forall a. [a] -> SDoc
plural [(Name, TcType)]
ids SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"of")
                                   Int
2 ([SDoc] -> SDoc
vcat [ Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty
                                           | (Name
name,TcType
ty) <- [(Name, TcType)]
ids ])
pprSkolInfo (UnifyForAllSkol TcType
ty)  = String -> SDoc
text String
"the type" SDoc -> SDoc -> SDoc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty
pprSkolInfo (TyConSkol TyConFlavour
flav Name
name) = String -> SDoc
text String
"the" SDoc -> SDoc -> SDoc
<+> TyConFlavour -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyConFlavour
flav SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"declaration for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)
pprSkolInfo (DataConSkol Name
name)    = String -> SDoc
text String
"the type signature for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)
pprSkolInfo SkolemInfoAnon
ReifySkol             = String -> SDoc
text String
"the type being reified"

pprSkolInfo (QuantCtxtSkol {}) = String -> SDoc
text String
"a quantified context"
pprSkolInfo SkolemInfoAnon
RuntimeUnkSkol     = String -> SDoc
text String
"Unknown type from GHCi runtime"
pprSkolInfo SkolemInfoAnon
ArrowReboundIfSkol = String -> SDoc
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
text String
"UnkSkol (please report this as a bug)" SDoc -> SDoc -> SDoc
$$ 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
vcat [ String -> SDoc
text String
"the type signature for:"
                              , Int -> SDoc -> SDoc
nest Int
2 (Name -> SDoc
forall a. OutputableBndr a => a -> SDoc
pprPrefixOcc Name
f SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> 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
vcat [ UserTypeCtxt -> SDoc
pprUserTypeCtxt UserTypeCtxt
ctxt SDoc -> SDoc -> SDoc
<> SDoc
colon
                              , Int -> SDoc -> SDoc
nest Int
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
sep [ String -> SDoc
text String
"a pattern with constructor:"
          , Int -> SDoc -> SDoc
nest Int
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
<+> SDoc
dcolon
            SDoc -> SDoc -> SDoc
<+> TcType -> SDoc
pprType (Bool -> DataCon -> TcType
dataConDisplayType Bool
show_linear_types DataCon
dc) SDoc -> SDoc -> SDoc
<> SDoc
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
sep [ String -> SDoc
text String
"a pattern with pattern synonym:"
        , Int -> SDoc -> SDoc
nest Int
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
<+> SDoc
dcolon
                   SDoc -> SDoc -> SDoc
<+> PatSyn -> SDoc
pprPatSynType PatSyn
ps SDoc -> SDoc -> SDoc
<> SDoc
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, to match what topSkolemise
  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)
  | 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 (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
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

  -- The following are other origins for given constraints that cannot produce
  -- new skolems -- hence no SkolemInfo.

  -- | 'InstSCOrigin' 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 'InstSCOrigin' origin.
  | InstSCOrigin ScDepth      -- ^ The number of superclass selections necessary to
                              -- get this constraint; see Note [Replacement vs keeping]
                              -- and Note [Use only the best local instance], both in
                              -- GHC.Tc.Solver.Interact
                 TypeSize     -- ^ If @(C ty1 .. tyn)@ is the largest class from
                              --    which we made a superclass selection in the chain,
                              --    then @TypeSize = sizeTypes [ty1, .., tyn]@
                              -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance

  -- | 'OtherSCOrigin' is used for a Given constraint obtained by superclass
  -- selection from a constraint /other than/ the context of an instance
  -- declaration. (For the latter we use 'InstSCOrigin'.)  E.g.
  --      f :: Foo a => blah
  --      f = e
  -- When typechecking body of 'f', the superclasses of the Given (Foo a)
  -- will have 'OtherSCOrigin'.
  -- Needed for Note [Replacement vs keeping] and
  -- Note [Use only the best local instance], both in GHC.Tc.Solver.Interact.
  | OtherSCOrigin ScDepth -- ^ The number of superclass selections necessary to
                          -- get this constraint
                  SkolemInfoAnon   -- ^ Where the sub-class constraint arose from
                               -- (used only for printing)

  -- All the others are 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.
  -- If the instance head is @C ty1 .. tyn@
  --    then @TypeSize = sizeTypes [ty1, .., tyn]@
  -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance
  | ScOrigin TypeSize

  | 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 OccName)   -- 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
  | Shouldn'tHappenOrigin String
                            -- the user should never see this one
  | GhcBug20076             -- see #20076

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

  | CycleBreakerOrigin
      CtOrigin   -- origin of the original constraint
      -- See Detail (7) of Note [Type equality cycles] in GHC.Tc.Solver.Canonical
  | 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

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

-- 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 :: Bool
uo_visible = Bool
False }
toInvisibleOrigin CtOrigin
orig                   = CtOrigin
orig

isGivenOrigin :: CtOrigin -> Bool
isGivenOrigin :: CtOrigin -> Bool
isGivenOrigin (GivenOrigin {})              = Bool
True
isGivenOrigin (InstSCOrigin {})             = Bool
True
isGivenOrigin (OtherSCOrigin {})            = 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
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 SrcAnn NoEpAnns
_ DotFieldOcc GhcRn
f)) = FastString -> CtOrigin
HasFieldOrigin (GenLocated (SrcAnn NoEpAnns) FastString -> FastString
forall l e. GenLocated l e -> e
unLoc (GenLocated (SrcAnn NoEpAnns) FastString -> FastString)
-> GenLocated (SrcAnn NoEpAnns) FastString -> FastString
forall a b. (a -> b) -> a -> b
$ DotFieldOcc GhcRn -> XRec GhcRn FastString
forall p. DotFieldOcc p -> XRec p FastString
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
_ MatchGroup GhcRn (LHsExpr GhcRn)
matches)    = MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin
matchesCtOrigin MatchGroup GhcRn (LHsExpr GhcRn)
matches
exprCtOrigin (HsLamCase XLamCase GhcRn
_ LamCaseVariant
_ 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
_ LHsToken "(" GhcRn
_ LHsExpr GhcRn
e LHsToken ")" GhcRn
_)      = 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
_ LHsToken "let" GhcRn
_ HsLocalBinds GhcRn
_ LHsToken "in" 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 (HsSpliceE {})      = String -> CtOrigin
Shouldn'tHappenOrigin String
"TH splice"
exprCtOrigin (HsProc {})         = String -> CtOrigin
Shouldn'tHappenOrigin String
"proc"
exprCtOrigin (HsStatic {})       = String -> CtOrigin
Shouldn'tHappenOrigin String
"static expression"
exprCtOrigin (XExpr (HsExpanded HsExpr GhcRn
a HsExpr GhcRn
_)) = HsExpr GhcRn -> CtOrigin
exprCtOrigin HsExpr GhcRn
a

-- | 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 SrcAnn NoEpAnns
_ (GRHS XCGRHS GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
_ [GuardLStmt 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
<+> SkolemInfoAnon -> SDoc
forall a. Outputable a => a -> SDoc
ppr SkolemInfoAnon
sk
pprCtOrigin (InstSCOrigin {})    = SDoc
ctoHerald SDoc -> SDoc -> SDoc
<+> SkolemInfoAnon -> SDoc
pprSkolInfo SkolemInfoAnon
InstSkol   -- keep output in sync
pprCtOrigin (OtherSCOrigin Int
_ SkolemInfoAnon
si) = SDoc
ctoHerald SDoc -> SDoc -> SDoc
<+> SkolemInfoAnon -> SDoc
pprSkolInfo SkolemInfoAnon
si

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

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

pprCtOrigin (FunDepOrigin2 TcType
pred1 CtOrigin
orig1 TcType
pred2 SrcSpan
loc2)
  = SDoc -> Int -> SDoc -> SDoc
hang (SDoc
ctoHerald SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"a functional dependency between:")
       Int
2 ([SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"constraint" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
pred1))
                    Int
2 (CtOrigin -> SDoc
pprCtOrigin CtOrigin
orig1 )
               , SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"instance" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
pred2))
                    Int
2 (String -> SDoc
text String
"at" SDoc -> SDoc -> SDoc
<+> 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 -> Int -> SDoc -> SDoc
hang (SDoc
ctoHerald SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"reasoning about an injective type family using constraints:")
       Int
2 ([SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (SDoc -> SDoc
quotes (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
pred1)) Int
2 (CtOrigin -> SDoc
pprCtOrigin CtOrigin
orig1 SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"at" SDoc -> SDoc -> SDoc
<+> RealSrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr RealSrcSpan
loc1)
               , SDoc -> Int -> SDoc -> SDoc
hang (SDoc -> SDoc
quotes (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
pred2)) Int
2 (CtOrigin -> SDoc
pprCtOrigin CtOrigin
orig2 SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"at" SDoc -> SDoc -> SDoc
<+> RealSrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr RealSrcSpan
loc2) ])

pprCtOrigin CtOrigin
AssocFamPatOrigin
  = String -> SDoc
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 -> Int -> SDoc -> SDoc
hang (SDoc
ctoHerald SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"a type equality" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
whenPprDebug (SDoc -> SDoc
brackets (Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
vis)))
       Int
2 ([SDoc] -> SDoc
sep [TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
t1, Char -> SDoc
char Char
'~', TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
t2])

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

pprCtOrigin (DerivOriginDC DataCon
dc Int
n Bool
_)
  = SDoc -> Int -> SDoc -> SDoc
hang (SDoc
ctoHerald SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"the" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
speakNth Int
n
          SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"field of" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
dc))
       Int
2 (SDoc -> SDoc
parens (String -> SDoc
text String
"type" SDoc -> SDoc -> SDoc
<+> 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] -> Int -> Scaled TcType
forall a. HasCallStack => [a] -> Int -> a
!! (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)

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

pprCtOrigin (DoPatOrigin LPat GhcRn
pat)
    = SDoc
ctoHerald SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"a do statement"
      SDoc -> SDoc -> SDoc
$$
      String -> SDoc
text String
"with the failable pattern" SDoc -> SDoc -> SDoc
<+> 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
<+> [SDoc] -> SDoc
hsep [ String -> SDoc
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
text String
"in a statement in a monad comprehension" ]

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

pprCtOrigin CtOrigin
GhcBug20076
  = [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"GHC Bug #20076 <https://gitlab.haskell.org/ghc/ghc/-/issues/20076>"
         , String -> SDoc
text String
"Assuming you have a partial type signature, you can avoid this error"
         , String -> SDoc
text String
"by either adding an extra-constraints wildcard (like `(..., _) => ...`,"
         , String -> SDoc
text String
"with the underscore at the end of the constraint), or by avoiding the"
         , String -> SDoc
text String
"use of a simplifiable constraint in your partial type signature." ]

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

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

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

pprCtOrigin (FRROrigin {})
  = SDoc
ctoHerald SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"a representation-polymorphism check"

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

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

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

pprCtOrigin CtOrigin
simple_origin
  = SDoc
ctoHerald SDoc -> SDoc -> SDoc
<+> HasCallStack => CtOrigin -> SDoc
CtOrigin -> SDoc
pprCtO CtOrigin
simple_origin

-- | Short one-liners
pprCtO :: HasCallStack => CtOrigin -> SDoc
pprCtO :: HasCallStack => CtOrigin -> SDoc
pprCtO (OccurrenceOf Name
name)   = [SDoc] -> SDoc
hsep [String -> SDoc
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
hsep [String -> SDoc
text String
"a use of", SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
name)]
pprCtO CtOrigin
AppOrigin             = String -> SDoc
text String
"an application"
pprCtO (IPOccOrigin HsIPName
name)    = [SDoc] -> SDoc
hsep [String -> SDoc
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
hsep [String -> SDoc
text String
"the overloaded label"
                                    ,SDoc -> SDoc
quotes (Char -> SDoc
char Char
'#' SDoc -> SDoc -> SDoc
<> FastString -> SDoc
forall a. Outputable a => a -> SDoc
ppr FastString
l)]
pprCtO CtOrigin
RecordUpdOrigin       = String -> SDoc
text String
"a record update"
pprCtO CtOrigin
ExprSigOrigin         = String -> SDoc
text String
"an expression type signature"
pprCtO CtOrigin
PatSigOrigin          = String -> SDoc
text String
"a pattern type signature"
pprCtO CtOrigin
PatOrigin             = String -> SDoc
text String
"a pattern"
pprCtO CtOrigin
ViewPatOrigin         = String -> SDoc
text String
"a view pattern"
pprCtO (LiteralOrigin HsOverLit GhcRn
lit)   = [SDoc] -> SDoc
hsep [String -> SDoc
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
hsep [String -> SDoc
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
text String
"an operator section"
pprCtO (HasFieldOrigin FastString
f)    = [SDoc] -> SDoc
hsep [String -> SDoc
text String
"selecting the field", SDoc -> SDoc
quotes (FastString -> SDoc
forall a. Outputable a => a -> SDoc
ppr FastString
f)]
pprCtO CtOrigin
AssocFamPatOrigin     = String -> SDoc
text String
"the LHS of a family instance"
pprCtO CtOrigin
TupleOrigin           = String -> SDoc
text String
"a tuple"
pprCtO CtOrigin
NegateOrigin          = String -> SDoc
text String
"a use of syntactic negation"
pprCtO (ScOrigin TypeSize
n)          = String -> SDoc
text String
"the superclasses of an instance declaration"
                               SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
whenPprDebug (SDoc -> SDoc
parens (TypeSize -> SDoc
forall a. Outputable a => a -> SDoc
ppr TypeSize
n))
pprCtO CtOrigin
DerivClauseOrigin     = String -> SDoc
text String
"the 'deriving' clause of a data type declaration"
pprCtO CtOrigin
StandAloneDerivOrigin = String -> SDoc
text String
"a 'deriving' declaration"
pprCtO CtOrigin
DefaultOrigin         = String -> SDoc
text String
"a 'default' declaration"
pprCtO CtOrigin
DoOrigin              = String -> SDoc
text String
"a do statement"
pprCtO CtOrigin
MCompOrigin           = String -> SDoc
text String
"a statement in a monad comprehension"
pprCtO CtOrigin
ProcOrigin            = String -> SDoc
text String
"a proc expression"
pprCtO CtOrigin
ArrowCmdOrigin        = String -> SDoc
text String
"an arrow command"
pprCtO CtOrigin
AnnOrigin             = String -> SDoc
text String
"an annotation"
pprCtO (ExprHoleOrigin Maybe OccName
Nothing)    = String -> SDoc
text String
"an expression hole"
pprCtO (ExprHoleOrigin (Just OccName
occ)) = String -> SDoc
text String
"a use of" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
occ)
pprCtO (TypeHoleOrigin OccName
occ)  = String -> SDoc
text String
"a use of wildcard" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
occ)
pprCtO CtOrigin
PatCheckOrigin        = String -> SDoc
text String
"a pattern-match completeness check"
pprCtO CtOrigin
ListOrigin            = String -> SDoc
text String
"an overloaded list"
pprCtO CtOrigin
IfThenElseOrigin      = String -> SDoc
text String
"an if-then-else expression"
pprCtO CtOrigin
StaticOrigin          = String -> SDoc
text String
"a static form"
pprCtO CtOrigin
NonLinearPatternOrigin = String -> SDoc
text String
"a non-linear pattern"
pprCtO (UsageEnvironmentOf Name
x) = [SDoc] -> SDoc
hsep [String -> SDoc
text String
"multiplicity of", SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
x)]
pprCtO CtOrigin
BracketOrigin         = String -> SDoc
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
text String
"a given constraint"
pprCtO (InstSCOrigin {})            = String -> SDoc
text String
"the superclass of an instance constraint"
pprCtO (OtherSCOrigin {})           = String -> SDoc
text String
"the superclass of a given constraint"
pprCtO (SpecPragOrigin {})          = String -> SDoc
text String
"a SPECIALISE pragma"
pprCtO (FunDepOrigin1 {})           = String -> SDoc
text String
"a functional dependency"
pprCtO (FunDepOrigin2 {})           = String -> SDoc
text String
"a functional dependency"
pprCtO (InjTFOrigin1 {})            = String -> SDoc
text String
"an injective type family"
pprCtO (TypeEqOrigin {})            = String -> SDoc
text String
"a type equality"
pprCtO (KindEqOrigin {})            = String -> SDoc
text String
"a kind equality"
pprCtO (DerivOriginDC {})           = String -> SDoc
text String
"a deriving clause"
pprCtO (DerivOriginCoerce {})       = String -> SDoc
text String
"a derived method"
pprCtO (DoPatOrigin {})             = String -> SDoc
text String
"a do statement"
pprCtO (MCompPatOrigin {})          = String -> SDoc
text String
"a monad comprehension pattern"
pprCtO (Shouldn'tHappenOrigin String
note) = String -> SDoc
text String
note
pprCtO (ProvCtxtOrigin {})          = String -> SDoc
text String
"a provided constraint"
pprCtO (InstProvidedOrigin {})      = String -> SDoc
text String
"a provided constraint"
pprCtO (CycleBreakerOrigin CtOrigin
orig)    = HasCallStack => CtOrigin -> SDoc
CtOrigin -> SDoc
pprCtO CtOrigin
orig
pprCtO (FRROrigin {})               = String -> SDoc
text String
"a representation-polymorphism check"
pprCtO CtOrigin
GhcBug20076                  = String -> SDoc
text String
"GHC Bug #20076"
pprCtO (WantedSuperclassOrigin {})  = String -> SDoc
text String
"a superclass constraint"
pprCtO (InstanceSigOrigin {})       = String -> SDoc
text String
"a type signature in an instance"
pprCtO (AmbiguityCheckOrigin {})    = String -> SDoc
text String
"a type ambiguity check"

{- *********************************************************************
*                                                                      *
             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 (HasCallStack => 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?
    }

-- | 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 updates must have a fixed runtime representation.
  --
  -- Test case: RepPolyRecordUpdate.
  = FRRRecordUpdate !RdrName !(HsExpr GhcTc)

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

  -- | 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 in which
  -- an argument type does not have a fixed runtime representation.
  --
  -- The argument can either be an expression or a pattern.
  --
  -- Test cases:
  --  Expression: UnliftedNewtypesLevityBinder.
  --     Pattern: T20363.
  | FRRDataConArg !ExprOrPat !DataCon !Int

  -- | An instantiation of an 'Id' with no binding (e.g. `coerce`, `unsafeCoerce#`)
  -- in which one of the remaining arguments types does not have a fixed runtime representation.
  --
  -- Test cases: RepPolyWrappedVar, T14561, UnliftedNewtypesCoerceFail.
  | FRRNoBindingResArg !Id !Int

  -- | Arguments to unboxed tuples must have fixed runtime representations.
  --
  -- Test case: RepPolyTuple.
  | FRRTupleArg !Int

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

  -- | Unboxed sums must have a fixed runtime representation.
  --
  -- Test cases: RepPolySum.
  | FRRUnboxedSum

  -- | 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 comprehesion 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 'matchActualFunTySigma'.
  --
  -- See 'ExpectedFunTyOrigin' for more details.
  | FRRExpectedFunTy
      !ExpectedFunTyOrigin
      !Int
        -- ^ argument position (1-indexed)

-- | 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 (FRRRecordUpdate RdrName
lbl HsExpr GhcTc
_arg)
  = [SDoc] -> SDoc
sep [ String -> SDoc
text String
"The record update at field"
        , SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
lbl) ]
pprFixedRuntimeRepContext (FRRBinder Name
binder)
  = [SDoc] -> SDoc
sep [ String -> SDoc
text String
"The binder"
        , SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
binder) ]
pprFixedRuntimeRepContext FixedRuntimeRepContext
FRRPatBind
  = String -> SDoc
text String
"The pattern binding"
pprFixedRuntimeRepContext FixedRuntimeRepContext
FRRPatSynArg
  = String -> SDoc
text String
"The pattern synonym argument pattern"
pprFixedRuntimeRepContext FixedRuntimeRepContext
FRRCase
  = String -> SDoc
text String
"The scrutinee of the case statement"
pprFixedRuntimeRepContext (FRRDataConArg ExprOrPat
expr_or_pat DataCon
con Int
i)
  = String -> SDoc
text String
"The" SDoc -> SDoc -> SDoc
<+> SDoc
what
  where
    arg, what :: SDoc
    arg :: SDoc
arg = case ExprOrPat
expr_or_pat of
      ExprOrPat
Expression -> String -> SDoc
text String
"argument"
      ExprOrPat
Pattern    -> String -> SDoc
text String
"pattern"
    what :: SDoc
what
      | DataCon -> Bool
isNewDataCon DataCon
con
      = String -> SDoc
text String
"newtype constructor" SDoc -> SDoc -> SDoc
<+> SDoc
arg
      | Bool
otherwise
      = String -> SDoc
text String
"data constructor" SDoc -> SDoc -> SDoc
<+> SDoc
arg SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"in" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
speakNth Int
i SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"position"
pprFixedRuntimeRepContext (FRRNoBindingResArg Id
fn Int
i)
  = [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Unsaturated use of a representation-polymorphic primitive function."
         , String -> SDoc
text String
"The" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
speakNth Int
i SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"argument of" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Name -> SDoc) -> Name -> SDoc
forall a b. (a -> b) -> a -> b
$ Id -> Name
forall a. NamedThing a => a -> Name
getName Id
fn) ]
pprFixedRuntimeRepContext (FRRTupleArg Int
i)
  = String -> SDoc
text String
"The tuple argument in" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
speakNth Int
i SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"position"
pprFixedRuntimeRepContext (FRRTupleSection Int
i)
  = String -> SDoc
text String
"The" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
speakNth Int
i SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"component of the tuple section"
pprFixedRuntimeRepContext FixedRuntimeRepContext
FRRUnboxedSum
  = String -> SDoc
text String
"The unboxed sum"
pprFixedRuntimeRepContext (FRRBodyStmt StmtOrigin
stmtOrig Int
i)
  = [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"The" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
speakNth Int
i SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"argument to (>>)" SDoc -> SDoc -> SDoc
<> SDoc
comma
         , String -> SDoc
text String
"arising from the" SDoc -> SDoc -> SDoc
<+> StmtOrigin -> SDoc
forall a. Outputable a => a -> SDoc
ppr StmtOrigin
stmtOrig SDoc -> SDoc -> SDoc
<> SDoc
comma ]
pprFixedRuntimeRepContext FixedRuntimeRepContext
FRRBodyStmtGuard
  = [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"The argument to" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (String -> SDoc
text String
"guard") SDoc -> SDoc -> SDoc
<> SDoc
comma
         , String -> SDoc
text String
"arising from the" SDoc -> SDoc -> SDoc
<+> StmtOrigin -> SDoc
forall a. Outputable a => a -> SDoc
ppr StmtOrigin
MonadComprehension SDoc -> SDoc -> SDoc
<> SDoc
comma ]
pprFixedRuntimeRepContext (FRRBindStmt StmtOrigin
stmtOrig)
  = [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"The first argument to (>>=)" SDoc -> SDoc -> SDoc
<> SDoc
comma
         , String -> SDoc
text String
"arising from the" SDoc -> SDoc -> SDoc
<+> StmtOrigin -> SDoc
forall a. Outputable a => a -> SDoc
ppr StmtOrigin
stmtOrig SDoc -> SDoc -> SDoc
<> SDoc
comma ]
pprFixedRuntimeRepContext FixedRuntimeRepContext
FRRBindStmtGuard
  = [SDoc] -> SDoc
sep [ String -> SDoc
text String
"The body of the bind statement" ]
pprFixedRuntimeRepContext (FRRArrow FRRArrowContext
arrowContext)
  = FRRArrowContext -> SDoc
pprFRRArrowContext FRRArrowContext
arrowContext
pprFixedRuntimeRepContext (FRRExpectedFunTy ExpectedFunTyOrigin
funTyOrig Int
arg_pos)
  = ExpectedFunTyOrigin -> Int -> SDoc
pprExpectedFunTyOrigin ExpectedFunTyOrigin
funTyOrig Int
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
text String
"monad comprehension"
  ppr StmtOrigin
DoNotation         = SDoc -> SDoc
quotes ( String -> SDoc
text String
"do" ) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"statement"

{- *********************************************************************
*                                                                      *
                       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
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"The arrow command") Int
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
vcat [ String -> SDoc
text String
"The argument in the arrow command application of"
         , Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc
quotes (HsCmd GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsCmd GhcRn
fun))
         , String -> SDoc
text String
"to"
         , Int -> SDoc -> SDoc
nest Int
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
vcat [ String -> SDoc
text String
"The function in the" SDoc -> SDoc -> SDoc
<+> HsArrAppType -> SDoc
pprHsArrType HsArrAppType
ho_app SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"of"
         , Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc
quotes (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
fun))
         , String -> SDoc
text String
"to"
         , Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc
quotes (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
arg)) ]
pprFRRArrowContext FRRArrowContext
ArrowCmdCase
  = String -> SDoc
text String
"The scrutinee of the arrow case command"
pprFRRArrowContext (ArrowFun HsExpr GhcRn
fun)
  = [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"The return type of the arrow function"
         , Int -> SDoc -> SDoc
nest Int
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 'matchActualFunTySigma'?
--
-- 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
  = ExpectedFunTySyntaxOp
    !CtOrigin
    !(HsExpr GhcRn)
      -- ^ 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)
      . (OutputableBndrId 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
  | ExpectedFunTyLam
      !(MatchGroup GhcRn (LHsExpr GhcRn))

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

pprExpectedFunTyOrigin :: ExpectedFunTyOrigin
                       -> Int -- ^ argument position (starting at 1)
                       -> SDoc
pprExpectedFunTyOrigin :: ExpectedFunTyOrigin -> Int -> SDoc
pprExpectedFunTyOrigin ExpectedFunTyOrigin
funTy_origin Int
i =
  case ExpectedFunTyOrigin
funTy_origin of
    ExpectedFunTySyntaxOp CtOrigin
orig HsExpr GhcRn
op ->
      [SDoc] -> SDoc
vcat [ [SDoc] -> SDoc
sep [ SDoc
the_arg_of
                 , String -> SDoc
text String
"the rebindable syntax operator"
                 , SDoc -> SDoc
quotes (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
op) ]
           , Int -> SDoc -> SDoc
nest Int
2 (CtOrigin -> SDoc
forall a. Outputable a => a -> SDoc
ppr CtOrigin
orig) ]
    ExpectedFunTyViewPat HsExpr GhcRn
expr ->
      [SDoc] -> SDoc
vcat [ SDoc
the_arg_of SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"the view pattern"
           , Int -> SDoc -> SDoc
nest Int
2 (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
expr) ]
    ExpectedFunTyArg TypedThing
fun HsExpr (GhcPass p)
arg ->
      [SDoc] -> SDoc
sep [ String -> SDoc
text String
"The argument"
          , SDoc -> SDoc
quotes (HsExpr (GhcPass p) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr (GhcPass p)
arg)
          , String -> SDoc
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
<+> SDoc -> SDoc
quotes (TypedThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TypedThing
fun)
      | Bool
otherwise
      -> String -> SDoc
text String
"The" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
speakNth Int
i SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"pattern in the equation" SDoc -> SDoc -> SDoc
<> [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
<+> String -> SDoc
text String
"for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TypedThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TypedThing
fun)
    ExpectedFunTyLam {} -> SDoc -> SDoc
binder_of (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"lambda"
    ExpectedFunTyLamCase LamCaseVariant
lc_variant HsExpr GhcRn
_ -> SDoc -> SDoc
binder_of (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ LamCaseVariant -> SDoc
lamCaseKeyword LamCaseVariant
lc_variant
  where
    the_arg_of :: SDoc
    the_arg_of :: SDoc
the_arg_of = String -> SDoc
text String
"The" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
speakNth Int
i SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"argument of"

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

pprExpectedFunTyHerald :: ExpectedFunTyOrigin -> SDoc
pprExpectedFunTyHerald :: ExpectedFunTyOrigin -> SDoc
pprExpectedFunTyHerald (ExpectedFunTySyntaxOp {})
  = String -> SDoc
text String
"This rebindable syntax expects a function with"
pprExpectedFunTyHerald (ExpectedFunTyViewPat {})
  = String -> SDoc
text String
"A view pattern expression expects"
pprExpectedFunTyHerald (ExpectedFunTyArg TypedThing
fun HsExpr (GhcPass p)
_)
  = [SDoc] -> SDoc
sep [ String -> SDoc
text String
"The function" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TypedThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TypedThing
fun)
        , String -> SDoc
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
text String
"The equation" SDoc -> SDoc -> SDoc
<> [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
<+> String -> SDoc
text String
"for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TypedThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TypedThing
fun) SDoc -> SDoc -> SDoc
<+> [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 MatchGroup GhcRn (LHsExpr GhcRn)
match)
  = [SDoc] -> SDoc
sep [ String -> SDoc
text String
"The lambda expression" SDoc -> SDoc -> SDoc
<+>
                   SDoc -> SDoc
quotes (Depth -> SDoc -> SDoc
pprSetDepth (Int -> Depth
PartWay Int
1) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                           MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)) -> SDoc
forall (idR :: Pass) body.
(OutputableBndrId idR, Outputable body) =>
MatchGroup (GhcPass idR) body -> SDoc
pprMatches MatchGroup GhcRn (LHsExpr GhcRn)
MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
match)
        -- The pprSetDepth makes the lambda abstraction print briefly
        , String -> SDoc
text String
"has" ]
pprExpectedFunTyHerald (ExpectedFunTyLamCase LamCaseVariant
_ HsExpr GhcRn
expr)
  = [SDoc] -> SDoc
sep [ String -> SDoc
text String
"The function" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
expr)
        , String -> SDoc
text String
"requires" ]