{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Tc.Types.Origin (
UserTypeCtxt(..), pprUserTypeCtxt, isSigMaybe,
ReportRedundantConstraints(..), reportRedundantConstraints,
redundantConstraintsSpan,
SkolemInfo(..), SkolemInfoAnon(..), mkSkolemInfo, getSkolemInfo, pprSigSkolInfo, pprSkolInfo,
unkSkol, unkSkolAnon,
CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin,
isVisibleOrigin, toInvisibleOrigin,
pprCtOrigin, isGivenOrigin, isWantedWantedFunDepOrigin,
isWantedSuperclassOrigin,
TypedThing(..), TyVarBndrs(..),
isPushCallStackOrigin, callStackOriginFS,
FixedRuntimeRepOrigin(..), FixedRuntimeRepContext(..),
pprFixedRuntimeRepContext,
StmtOrigin(..),
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
data UserTypeCtxt
= FunSigCtxt
Name
ReportRedundantConstraints
| InfSigCtxt Name
| ExprSigCtxt
ReportRedundantConstraints
| KindSigCtxt
| StandaloneKindSigCtxt
Name
| TypeAppCtxt
| ConArgCtxt Name
| TySynCtxt Name
| PatSynCtxt Name
| PatSigCtxt
| RuleSigCtxt FastString Name
| ForSigCtxt Name
| DefaultDeclCtxt
| InstDeclCtxt Bool
| SpecInstCtxt
| GenSigCtxt
| GhciCtxt Bool
| ClassSCCtxt Name
| SigmaCtxt
| DataTyCtxt Name
| DerivClauseCtxt
| TyVarBndrKindCtxt Name
| DataKindCtxt Name
| TySynKindCtxt Name
| TyFamResKindCtxt Name
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 )
data ReportRedundantConstraints
= NoRRC
| WantRRC SrcSpan
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 )
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
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
data SkolemInfo
= SkolemInfo
Unique
SkolemInfoAnon
instance Uniquable SkolemInfo where
getUnique :: SkolemInfo -> Unique
getUnique (SkolemInfo Unique
u SkolemInfoAnon
_) = Unique
u
data SkolemInfoAnon
= SigSkol
UserTypeCtxt
TcType
[(Name,TcTyVar)]
| SigTypeSkol UserTypeCtxt
| ForAllSkol
TyVarBndrs
| DerivSkol Type
| InstSkol
| FamInstSkol
| PatSkol
ConLike
(HsMatchContext GhcTc)
| IPSkol [HsIPName]
| RuleSkol RuleName
| InferSkol [(Name,TcType)]
| BracketSkol
| UnifyForAllSkol
TcType
| TyConSkol TyConFlavour Name
| DataConSkol Name
| ReifySkol
| QuantCtxtSkol
| RuntimeUnkSkol
| ArrowReboundIfSkol
| UnkSkol CallStack
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
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
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 (NoGhcTc p)), UnXRec (NoGhcTc 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"
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
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
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 ])
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 ]
data TypedThing
= HsTypeRnThing (HsType GhcRn)
| TypeThing Type
| HsExprRnThing (HsExpr GhcRn)
| NameThing Name
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
=
GivenOrigin SkolemInfoAnon
| InstSCOrigin ScDepth
TypeSize
| OtherSCOrigin ScDepth
SkolemInfoAnon
| OccurrenceOf Name
| OccurrenceOfRecSel RdrName
| AppOrigin
| SpecPragOrigin UserTypeCtxt
| TypeEqOrigin { CtOrigin -> TcType
uo_actual :: TcType
, CtOrigin -> TcType
uo_expected :: TcType
, CtOrigin -> Maybe TypedThing
uo_thing :: Maybe TypedThing
, CtOrigin -> Bool
uo_visible :: Bool
}
| KindEqOrigin
TcType TcType
CtOrigin
(Maybe TypeOrKind)
| IPOccOrigin HsIPName
| OverLabelOrigin FastString
| LiteralOrigin (HsOverLit GhcRn)
| NegateOrigin
| ArithSeqOrigin (ArithSeqInfo GhcRn)
| AssocFamPatOrigin
| SectionOrigin
| HasFieldOrigin FastString
| TupleOrigin
| ExprSigOrigin
| PatSigOrigin
| PatOrigin
| ProvCtxtOrigin
(PatSynBind GhcRn GhcRn)
| RecordUpdOrigin
| ViewPatOrigin
| ScOrigin TypeSize
| DerivClauseOrigin
| DerivOriginDC DataCon Int Bool
| DerivOriginCoerce Id Type Type Bool
| StandAloneDerivOrigin
| DefaultOrigin
| DoOrigin
| DoPatOrigin (LPat GhcRn)
| MCompOrigin
| MCompPatOrigin (LPat GhcRn)
| ProcOrigin
| ArrowCmdOrigin
| AnnOrigin
| FunDepOrigin1
PredType CtOrigin RealSrcSpan
PredType CtOrigin RealSrcSpan
| FunDepOrigin2
PredType CtOrigin
PredType SrcSpan
| InjTFOrigin1
PredType CtOrigin RealSrcSpan
PredType CtOrigin RealSrcSpan
| ExprHoleOrigin (Maybe OccName)
| TypeHoleOrigin OccName
| PatCheckOrigin
| ListOrigin
| IfThenElseOrigin
| BracketOrigin
| StaticOrigin
| Shouldn'tHappenOrigin String
| GhcBug20076
| InstProvidedOrigin
Module
ClsInst
| NonLinearPatternOrigin
| UsageEnvironmentOf Name
| CycleBreakerOrigin
CtOrigin
| FRROrigin
FixedRuntimeRepOrigin
| WantedSuperclassOrigin PredType CtOrigin
| InstanceSigOrigin
Name
Type
Type
| AmbiguityCheckOrigin UserTypeCtxt
type ScDepth = Int
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
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
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
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"
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 SrcSpanAnnN FastString -> FastString
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnN FastString -> FastString)
-> GenLocated SrcSpanAnnN 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
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"
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
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
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
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"
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
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"
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"
isPushCallStackOrigin :: CtOrigin -> Bool
isPushCallStackOrigin :: CtOrigin -> Bool
isPushCallStackOrigin (IPOccOrigin {}) = Bool
False
isPushCallStackOrigin CtOrigin
_ = Bool
True
callStackOriginFS :: CtOrigin -> FastString
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))
data FixedRuntimeRepOrigin
= FixedRuntimeRepOrigin
{ FixedRuntimeRepOrigin -> TcType
frr_type :: Type
, FixedRuntimeRepOrigin -> FixedRuntimeRepContext
frr_context :: FixedRuntimeRepContext
}
data FixedRuntimeRepContext
= FRRRecordUpdate !RdrName !(HsExpr GhcTc)
| FRRBinder !Name
| FRRPatBind
| FRRPatSynArg
| FRRCase
| FRRDataConArg !ExprOrPat !DataCon !Int
| FRRNoBindingResArg !Id !Int
| FRRTupleArg !Int
| FRRTupleSection !Int
| FRRUnboxedSum
| FRRBodyStmt !StmtOrigin !Int
| FRRBodyStmtGuard
| FRRBindStmt !StmtOrigin
| FRRBindStmtGuard
| FRRArrow !FRRArrowContext
| FRRExpectedFunTy
!ExpectedFunTyOrigin
!Int
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
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"
data FRRArrowContext
= ArrowCmdResTy !(HsCmd GhcRn)
| ArrowCmdApp !(HsCmd GhcRn) !(HsExpr GhcRn)
| ArrowCmdArrApp !(HsExpr GhcRn) !(HsExpr GhcRn) !HsArrAppType
| ArrowCmdCase
| 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
data ExpectedFunTyOrigin
= ExpectedFunTySyntaxOp
!CtOrigin
!(HsExpr GhcRn)
| ExpectedFunTyViewPat
!(HsExpr GhcRn)
| forall (p :: Pass)
. (OutputableBndrId p)
=> ExpectedFunTyArg
!TypedThing
!(HsExpr (GhcPass p))
| ExpectedFunTyMatches
!TypedThing
!(MatchGroup GhcRn (LHsExpr GhcRn))
| ExpectedFunTyLam
!(MatchGroup GhcRn (LHsExpr GhcRn))
| ExpectedFunTyLamCase
LamCaseVariant
!(HsExpr GhcRn)
pprExpectedFunTyOrigin :: ExpectedFunTyOrigin
-> Int
-> 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)
, 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" ]