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( Eq )
data ReportRedundantConstraints
= NoRRC
| WantRRC SrcSpan
deriving( Eq )
reportRedundantConstraints :: ReportRedundantConstraints -> Bool
reportRedundantConstraints NoRRC = False
reportRedundantConstraints (WantRRC {}) = True
redundantConstraintsSpan :: UserTypeCtxt -> SrcSpan
redundantConstraintsSpan (FunSigCtxt _ (WantRRC span)) = span
redundantConstraintsSpan (ExprSigCtxt (WantRRC span)) = span
redundantConstraintsSpan _ = noSrcSpan
pprUserTypeCtxt :: UserTypeCtxt -> SDoc
pprUserTypeCtxt (FunSigCtxt n _) = text "the type signature for" <+> quotes (ppr n)
pprUserTypeCtxt (InfSigCtxt n) = text "the inferred type for" <+> quotes (ppr n)
pprUserTypeCtxt (RuleSigCtxt _ n) = text "the type signature for" <+> quotes (ppr n)
pprUserTypeCtxt (ExprSigCtxt _) = text "an expression type signature"
pprUserTypeCtxt KindSigCtxt = text "a kind signature"
pprUserTypeCtxt (StandaloneKindSigCtxt n) = text "a standalone kind signature for" <+> quotes (ppr n)
pprUserTypeCtxt TypeAppCtxt = text "a type argument"
pprUserTypeCtxt (ConArgCtxt c) = text "the type of the constructor" <+> quotes (ppr c)
pprUserTypeCtxt (TySynCtxt c) = text "the RHS of the type synonym" <+> quotes (ppr c)
pprUserTypeCtxt PatSigCtxt = text "a pattern type signature"
pprUserTypeCtxt (ForSigCtxt n) = text "the foreign declaration for" <+> quotes (ppr n)
pprUserTypeCtxt DefaultDeclCtxt = text "a type in a `default' declaration"
pprUserTypeCtxt (InstDeclCtxt False) = text "an instance declaration"
pprUserTypeCtxt (InstDeclCtxt True) = text "a stand-alone deriving instance declaration"
pprUserTypeCtxt SpecInstCtxt = text "a SPECIALISE instance pragma"
pprUserTypeCtxt GenSigCtxt = text "a type expected by the context"
pprUserTypeCtxt (GhciCtxt {}) = text "a type in a GHCi command"
pprUserTypeCtxt (ClassSCCtxt c) = text "the super-classes of class" <+> quotes (ppr c)
pprUserTypeCtxt SigmaCtxt = text "the context of a polymorphic type"
pprUserTypeCtxt (DataTyCtxt tc) = text "the context of the data type declaration for" <+> quotes (ppr tc)
pprUserTypeCtxt (PatSynCtxt n) = text "the signature for pattern synonym" <+> quotes (ppr n)
pprUserTypeCtxt (DerivClauseCtxt) = text "a `deriving' clause"
pprUserTypeCtxt (TyVarBndrKindCtxt n) = text "the kind annotation on the type variable" <+> quotes (ppr n)
pprUserTypeCtxt (DataKindCtxt n) = text "the kind annotation on the declaration for" <+> quotes (ppr n)
pprUserTypeCtxt (TySynKindCtxt n) = text "the kind annotation on the declaration for" <+> quotes (ppr n)
pprUserTypeCtxt (TyFamResKindCtxt n) = text "the result kind for" <+> quotes (ppr n)
isSigMaybe :: UserTypeCtxt -> Maybe Name
isSigMaybe (FunSigCtxt n _) = Just n
isSigMaybe (ConArgCtxt n) = Just n
isSigMaybe (ForSigCtxt n) = Just n
isSigMaybe (PatSynCtxt n) = Just n
isSigMaybe _ = Nothing
data SkolemInfo
= SkolemInfo
Unique
SkolemInfoAnon
instance Uniquable SkolemInfo where
getUnique (SkolemInfo u _) = 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 = SkolemInfo (mkUniqueGrimily 0) unkSkolAnon
unkSkolAnon :: HasCallStack => SkolemInfoAnon
unkSkolAnon = UnkSkol callStack
mkSkolemInfo :: MonadIO m => SkolemInfoAnon -> m SkolemInfo
mkSkolemInfo sk_anon = do
u <- liftIO $! uniqFromMask 's'
return (SkolemInfo u sk_anon)
getSkolemInfo :: SkolemInfo -> SkolemInfoAnon
getSkolemInfo (SkolemInfo _ skol_anon) = skol_anon
instance Outputable SkolemInfo where
ppr (SkolemInfo _ sk_info ) = ppr sk_info
instance Outputable SkolemInfoAnon where
ppr = pprSkolInfo
pprSkolInfo :: SkolemInfoAnon -> SDoc
pprSkolInfo (SigSkol cx ty _) = pprSigSkolInfo cx ty
pprSkolInfo (SigTypeSkol cx) = pprUserTypeCtxt cx
pprSkolInfo (ForAllSkol tvs) = text "an explicit forall" <+> ppr tvs
pprSkolInfo (IPSkol ips) = text "the implicit-parameter binding" <> plural ips <+> text "for"
<+> pprWithCommas ppr ips
pprSkolInfo (DerivSkol pred) = text "the deriving clause for" <+> quotes (ppr pred)
pprSkolInfo InstSkol = text "the instance declaration"
pprSkolInfo FamInstSkol = text "a family instance declaration"
pprSkolInfo BracketSkol = text "a Template Haskell bracket"
pprSkolInfo (RuleSkol name) = text "the RULE" <+> pprRuleName name
pprSkolInfo (PatSkol cl mc) = sep [ pprPatSkolInfo cl
, text "in" <+> pprMatchContext mc ]
pprSkolInfo (InferSkol ids) = hang (text "the inferred type" <> plural ids <+> text "of")
2 (vcat [ ppr name <+> dcolon <+> ppr ty
| (name,ty) <- ids ])
pprSkolInfo (UnifyForAllSkol ty) = text "the type" <+> ppr ty
pprSkolInfo (TyConSkol flav name) = text "the" <+> ppr flav <+> text "declaration for" <+> quotes (ppr name)
pprSkolInfo (DataConSkol name) = text "the type signature for" <+> quotes (ppr name)
pprSkolInfo ReifySkol = text "the type being reified"
pprSkolInfo (QuantCtxtSkol {}) = text "a quantified context"
pprSkolInfo RuntimeUnkSkol = text "Unknown type from GHCi runtime"
pprSkolInfo ArrowReboundIfSkol = text "the expected type of a rebound if-then-else command"
pprSkolInfo (UnkSkol cs) = text "UnkSkol (please report this as a bug)" $$ prettyCallStackDoc cs
pprSigSkolInfo :: UserTypeCtxt -> TcType -> SDoc
pprSigSkolInfo ctxt ty
= case ctxt of
FunSigCtxt f _ -> vcat [ text "the type signature for:"
, nest 2 (pprPrefixOcc f <+> dcolon <+> ppr ty) ]
PatSynCtxt {} -> pprUserTypeCtxt ctxt
_ -> vcat [ pprUserTypeCtxt ctxt <> colon
, nest 2 (ppr ty) ]
pprPatSkolInfo :: ConLike -> SDoc
pprPatSkolInfo (RealDataCon dc)
= sdocOption sdocLinearTypes (\show_linear_types ->
sep [ text "a pattern with constructor:"
, nest 2 $ ppr dc <+> dcolon
<+> pprType (dataConDisplayType show_linear_types dc) <> comma ])
pprPatSkolInfo (PatSynCon ps)
= sep [ text "a pattern with pattern synonym:"
, nest 2 $ ppr ps <+> dcolon
<+> pprPatSynType ps <> 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 (HsTypeRnThing ty) = ppr ty
ppr (TypeThing ty) = ppr ty
ppr (HsExprRnThing expr) = ppr expr
ppr (NameThing name) = ppr name
instance Outputable TyVarBndrs where
ppr (HsTyVarBndrsRn bndrs) = fsep (map ppr bndrs)
data CtOrigin
=
GivenOrigin SkolemInfoAnon
| InstSCOrigin ScDepth
TypeSize
| OtherSCOrigin ScDepth
SkolemInfoAnon
| OccurrenceOf Name
| OccurrenceOfRecSel RdrName
| AppOrigin
| SpecPragOrigin UserTypeCtxt
| TypeEqOrigin { uo_actual :: TcType
, uo_expected :: TcType
, uo_thing :: Maybe TypedThing
, 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 (TypeEqOrigin { uo_visible = vis }) = vis
isVisibleOrigin (KindEqOrigin _ _ sub_orig _) = isVisibleOrigin sub_orig
isVisibleOrigin _ = True
toInvisibleOrigin :: CtOrigin -> CtOrigin
toInvisibleOrigin orig@(TypeEqOrigin {}) = orig { uo_visible = False }
toInvisibleOrigin orig = orig
isGivenOrigin :: CtOrigin -> Bool
isGivenOrigin (GivenOrigin {}) = True
isGivenOrigin (InstSCOrigin {}) = True
isGivenOrigin (OtherSCOrigin {}) = True
isGivenOrigin (CycleBreakerOrigin o) = isGivenOrigin o
isGivenOrigin _ = False
isWantedWantedFunDepOrigin :: CtOrigin -> Bool
isWantedWantedFunDepOrigin (FunDepOrigin1 _ orig1 _ _ orig2 _)
= not (isGivenOrigin orig1) && not (isGivenOrigin orig2)
isWantedWantedFunDepOrigin (InjTFOrigin1 _ orig1 _ _ orig2 _)
= not (isGivenOrigin orig1) && not (isGivenOrigin orig2)
isWantedWantedFunDepOrigin _ = False
isWantedSuperclassOrigin :: CtOrigin -> Bool
isWantedSuperclassOrigin (WantedSuperclassOrigin {}) = True
isWantedSuperclassOrigin _ = False
instance Outputable CtOrigin where
ppr = pprCtOrigin
ctoHerald :: SDoc
ctoHerald = text "arising from"
lexprCtOrigin :: LHsExpr GhcRn -> CtOrigin
lexprCtOrigin (L _ e) = exprCtOrigin e
exprCtOrigin :: HsExpr GhcRn -> CtOrigin
exprCtOrigin (HsVar _ (L _ name)) = OccurrenceOf name
exprCtOrigin (HsGetField _ _ (L _ f)) = HasFieldOrigin (unLoc $ dfoLabel f)
exprCtOrigin (HsUnboundVar {}) = Shouldn'tHappenOrigin "unbound variable"
exprCtOrigin (HsRecSel _ f) = OccurrenceOfRecSel (unLoc $ foLabel f)
exprCtOrigin (HsOverLabel _ l) = OverLabelOrigin l
exprCtOrigin (ExplicitList {}) = ListOrigin
exprCtOrigin (HsIPVar _ ip) = IPOccOrigin ip
exprCtOrigin (HsOverLit _ lit) = LiteralOrigin lit
exprCtOrigin (HsLit {}) = Shouldn'tHappenOrigin "concrete literal"
exprCtOrigin (HsLam _ matches) = matchesCtOrigin matches
exprCtOrigin (HsLamCase _ _ ms) = matchesCtOrigin ms
exprCtOrigin (HsApp _ e1 _) = lexprCtOrigin e1
exprCtOrigin (HsAppType _ e1 _) = lexprCtOrigin e1
exprCtOrigin (OpApp _ _ op _) = lexprCtOrigin op
exprCtOrigin (NegApp _ e _) = lexprCtOrigin e
exprCtOrigin (HsPar _ _ e _) = lexprCtOrigin e
exprCtOrigin (HsProjection _ _) = SectionOrigin
exprCtOrigin (SectionL _ _ _) = SectionOrigin
exprCtOrigin (SectionR _ _ _) = SectionOrigin
exprCtOrigin (ExplicitTuple {}) = Shouldn'tHappenOrigin "explicit tuple"
exprCtOrigin ExplicitSum{} = Shouldn'tHappenOrigin "explicit sum"
exprCtOrigin (HsCase _ _ matches) = matchesCtOrigin matches
exprCtOrigin (HsIf {}) = IfThenElseOrigin
exprCtOrigin (HsMultiIf _ rhs) = lGRHSCtOrigin rhs
exprCtOrigin (HsLet _ _ _ _ e) = lexprCtOrigin e
exprCtOrigin (HsDo {}) = DoOrigin
exprCtOrigin (RecordCon {}) = Shouldn'tHappenOrigin "record construction"
exprCtOrigin (RecordUpd {}) = RecordUpdOrigin
exprCtOrigin (ExprWithTySig {}) = ExprSigOrigin
exprCtOrigin (ArithSeq {}) = Shouldn'tHappenOrigin "arithmetic sequence"
exprCtOrigin (HsPragE _ _ e) = lexprCtOrigin e
exprCtOrigin (HsTypedBracket {}) = Shouldn'tHappenOrigin "TH typed bracket"
exprCtOrigin (HsUntypedBracket {}) = Shouldn'tHappenOrigin "TH untyped bracket"
exprCtOrigin (HsSpliceE {}) = Shouldn'tHappenOrigin "TH splice"
exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc"
exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression"
exprCtOrigin (XExpr (HsExpanded a _)) = exprCtOrigin a
matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin
matchesCtOrigin (MG { mg_alts = alts })
| L _ [L _ match] <- alts
, Match { m_grhss = grhss } <- match
= grhssCtOrigin grhss
| otherwise
= Shouldn'tHappenOrigin "multi-way match"
grhssCtOrigin :: GRHSs GhcRn (LHsExpr GhcRn) -> CtOrigin
grhssCtOrigin (GRHSs { grhssGRHSs = lgrhss }) = lGRHSCtOrigin lgrhss
lGRHSCtOrigin :: [LGRHS GhcRn (LHsExpr GhcRn)] -> CtOrigin
lGRHSCtOrigin [L _ (GRHS _ _ (L _ e))] = exprCtOrigin e
lGRHSCtOrigin _ = Shouldn'tHappenOrigin "multi-way GRHS"
pprCtOrigin :: CtOrigin -> SDoc
pprCtOrigin (GivenOrigin sk) = ctoHerald <+> ppr sk
pprCtOrigin (InstSCOrigin {}) = ctoHerald <+> pprSkolInfo InstSkol
pprCtOrigin (OtherSCOrigin _ si) = ctoHerald <+> pprSkolInfo si
pprCtOrigin (SpecPragOrigin ctxt)
= case ctxt of
FunSigCtxt n _ -> text "for" <+> quotes (ppr n)
SpecInstCtxt -> text "a SPECIALISE INSTANCE pragma"
_ -> text "a SPECIALISE pragma"
pprCtOrigin (FunDepOrigin1 pred1 orig1 loc1 pred2 orig2 loc2)
= hang (ctoHerald <+> text "a functional dependency between constraints:")
2 (vcat [ hang (quotes (ppr pred1)) 2 (pprCtOrigin orig1 <+> text "at" <+> ppr loc1)
, hang (quotes (ppr pred2)) 2 (pprCtOrigin orig2 <+> text "at" <+> ppr loc2) ])
pprCtOrigin (FunDepOrigin2 pred1 orig1 pred2 loc2)
= hang (ctoHerald <+> text "a functional dependency between:")
2 (vcat [ hang (text "constraint" <+> quotes (ppr pred1))
2 (pprCtOrigin orig1 )
, hang (text "instance" <+> quotes (ppr pred2))
2 (text "at" <+> ppr loc2) ])
pprCtOrigin (InjTFOrigin1 pred1 orig1 loc1 pred2 orig2 loc2)
= hang (ctoHerald <+> text "reasoning about an injective type family using constraints:")
2 (vcat [ hang (quotes (ppr pred1)) 2 (pprCtOrigin orig1 <+> text "at" <+> ppr loc1)
, hang (quotes (ppr pred2)) 2 (pprCtOrigin orig2 <+> text "at" <+> ppr loc2) ])
pprCtOrigin AssocFamPatOrigin
= text "when matching a family LHS with its class instance head"
pprCtOrigin (TypeEqOrigin { uo_actual = t1, uo_expected = t2, uo_visible = vis })
= hang (ctoHerald <+> text "a type equality" <> whenPprDebug (brackets (ppr vis)))
2 (sep [ppr t1, char '~', ppr t2])
pprCtOrigin (KindEqOrigin t1 t2 _ _)
= hang (ctoHerald <+> text "a kind equality arising from")
2 (sep [ppr t1, char '~', ppr t2])
pprCtOrigin (DerivOriginDC dc n _)
= hang (ctoHerald <+> text "the" <+> speakNth n
<+> text "field of" <+> quotes (ppr dc))
2 (parens (text "type" <+> quotes (ppr (scaledThing ty))))
where
ty = dataConOrigArgTys dc !! (n1)
pprCtOrigin (DerivOriginCoerce meth ty1 ty2 _)
= hang (ctoHerald <+> text "the coercion of the method" <+> quotes (ppr meth))
2 (sep [ text "from type" <+> quotes (ppr ty1)
, nest 2 $ text "to type" <+> quotes (ppr ty2) ])
pprCtOrigin (DoPatOrigin pat)
= ctoHerald <+> text "a do statement"
$$
text "with the failable pattern" <+> quotes (ppr pat)
pprCtOrigin (MCompPatOrigin pat)
= ctoHerald <+> hsep [ text "the failable pattern"
, quotes (ppr pat)
, text "in a statement in a monad comprehension" ]
pprCtOrigin (Shouldn'tHappenOrigin note)
= vcat [ text "<< This should not appear in error messages. If you see this"
, text "in an error message, please report a bug mentioning"
<+> quotes (text note) <+> text "at"
, text "https://gitlab.haskell.org/ghc/ghc/wikis/report-a-bug >>"
]
pprCtOrigin GhcBug20076
= vcat [ text "GHC Bug #20076 <https://gitlab.haskell.org/ghc/ghc/-/issues/20076>"
, text "Assuming you have a partial type signature, you can avoid this error"
, text "by either adding an extra-constraints wildcard (like `(..., _) => ...`,"
, text "with the underscore at the end of the constraint), or by avoiding the"
, text "use of a simplifiable constraint in your partial type signature." ]
pprCtOrigin (ProvCtxtOrigin PSB{ psb_id = (L _ name) })
= hang (ctoHerald <+> text "the \"provided\" constraints claimed by")
2 (text "the signature of" <+> quotes (ppr name))
pprCtOrigin (InstProvidedOrigin mod cls_inst)
= vcat [ text "arising when attempting to show that"
, ppr cls_inst
, text "is provided by" <+> quotes (ppr mod)]
pprCtOrigin (CycleBreakerOrigin orig)
= pprCtOrigin orig
pprCtOrigin (FRROrigin {})
= ctoHerald <+> text "a representation-polymorphism check"
pprCtOrigin (WantedSuperclassOrigin subclass_pred subclass_orig)
= sep [ ctoHerald <+> text "a superclass required to satisfy" <+> quotes (ppr subclass_pred) <> comma
, pprCtOrigin subclass_orig ]
pprCtOrigin (InstanceSigOrigin method_name sig_type orig_method_type)
= vcat [ ctoHerald <+> text "the check that an instance signature is more general"
, text "than the type of the method (instantiated for this instance)"
, hang (text "instance signature:")
2 (ppr method_name <+> dcolon <+> ppr sig_type)
, hang (text "instantiated method type:")
2 (ppr orig_method_type) ]
pprCtOrigin (AmbiguityCheckOrigin ctxt)
= ctoHerald <+> text "a type ambiguity check for" $$
pprUserTypeCtxt ctxt
pprCtOrigin simple_origin
= ctoHerald <+> pprCtO simple_origin
pprCtO :: HasCallStack => CtOrigin -> SDoc
pprCtO (OccurrenceOf name) = hsep [text "a use of", quotes (ppr name)]
pprCtO (OccurrenceOfRecSel name) = hsep [text "a use of", quotes (ppr name)]
pprCtO AppOrigin = text "an application"
pprCtO (IPOccOrigin name) = hsep [text "a use of implicit parameter", quotes (ppr name)]
pprCtO (OverLabelOrigin l) = hsep [text "the overloaded label"
,quotes (char '#' <> ppr l)]
pprCtO RecordUpdOrigin = text "a record update"
pprCtO ExprSigOrigin = text "an expression type signature"
pprCtO PatSigOrigin = text "a pattern type signature"
pprCtO PatOrigin = text "a pattern"
pprCtO ViewPatOrigin = text "a view pattern"
pprCtO (LiteralOrigin lit) = hsep [text "the literal", quotes (ppr lit)]
pprCtO (ArithSeqOrigin seq) = hsep [text "the arithmetic sequence", quotes (ppr seq)]
pprCtO SectionOrigin = text "an operator section"
pprCtO (HasFieldOrigin f) = hsep [text "selecting the field", quotes (ppr f)]
pprCtO AssocFamPatOrigin = text "the LHS of a family instance"
pprCtO TupleOrigin = text "a tuple"
pprCtO NegateOrigin = text "a use of syntactic negation"
pprCtO (ScOrigin n) = text "the superclasses of an instance declaration"
<> whenPprDebug (parens (ppr n))
pprCtO DerivClauseOrigin = text "the 'deriving' clause of a data type declaration"
pprCtO StandAloneDerivOrigin = text "a 'deriving' declaration"
pprCtO DefaultOrigin = text "a 'default' declaration"
pprCtO DoOrigin = text "a do statement"
pprCtO MCompOrigin = text "a statement in a monad comprehension"
pprCtO ProcOrigin = text "a proc expression"
pprCtO ArrowCmdOrigin = text "an arrow command"
pprCtO AnnOrigin = text "an annotation"
pprCtO (ExprHoleOrigin Nothing) = text "an expression hole"
pprCtO (ExprHoleOrigin (Just occ)) = text "a use of" <+> quotes (ppr occ)
pprCtO (TypeHoleOrigin occ) = text "a use of wildcard" <+> quotes (ppr occ)
pprCtO PatCheckOrigin = text "a pattern-match completeness check"
pprCtO ListOrigin = text "an overloaded list"
pprCtO IfThenElseOrigin = text "an if-then-else expression"
pprCtO StaticOrigin = text "a static form"
pprCtO NonLinearPatternOrigin = text "a non-linear pattern"
pprCtO (UsageEnvironmentOf x) = hsep [text "multiplicity of", quotes (ppr x)]
pprCtO BracketOrigin = text "a quotation bracket"
pprCtO (GivenOrigin {}) = text "a given constraint"
pprCtO (InstSCOrigin {}) = text "the superclass of an instance constraint"
pprCtO (OtherSCOrigin {}) = text "the superclass of a given constraint"
pprCtO (SpecPragOrigin {}) = text "a SPECIALISE pragma"
pprCtO (FunDepOrigin1 {}) = text "a functional dependency"
pprCtO (FunDepOrigin2 {}) = text "a functional dependency"
pprCtO (InjTFOrigin1 {}) = text "an injective type family"
pprCtO (TypeEqOrigin {}) = text "a type equality"
pprCtO (KindEqOrigin {}) = text "a kind equality"
pprCtO (DerivOriginDC {}) = text "a deriving clause"
pprCtO (DerivOriginCoerce {}) = text "a derived method"
pprCtO (DoPatOrigin {}) = text "a do statement"
pprCtO (MCompPatOrigin {}) = text "a monad comprehension pattern"
pprCtO (Shouldn'tHappenOrigin note) = text note
pprCtO (ProvCtxtOrigin {}) = text "a provided constraint"
pprCtO (InstProvidedOrigin {}) = text "a provided constraint"
pprCtO (CycleBreakerOrigin orig) = pprCtO orig
pprCtO (FRROrigin {}) = text "a representation-polymorphism check"
pprCtO GhcBug20076 = text "GHC Bug #20076"
pprCtO (WantedSuperclassOrigin {}) = text "a superclass constraint"
pprCtO (InstanceSigOrigin {}) = text "a type signature in an instance"
pprCtO (AmbiguityCheckOrigin {}) = text "a type ambiguity check"
isPushCallStackOrigin :: CtOrigin -> Bool
isPushCallStackOrigin (IPOccOrigin {}) = False
isPushCallStackOrigin _ = True
callStackOriginFS :: CtOrigin -> FastString
callStackOriginFS (OccurrenceOf fun) = occNameFS (getOccName fun)
callStackOriginFS orig = mkFastString (showSDocUnsafe (pprCtO orig))
data FixedRuntimeRepOrigin
= FixedRuntimeRepOrigin
{ frr_type :: Type
, 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 (FRRRecordUpdate lbl _arg)
= sep [ text "The record update at field"
, quotes (ppr lbl) ]
pprFixedRuntimeRepContext (FRRBinder binder)
= sep [ text "The binder"
, quotes (ppr binder) ]
pprFixedRuntimeRepContext FRRPatBind
= text "The pattern binding"
pprFixedRuntimeRepContext FRRPatSynArg
= text "The pattern synonym argument pattern"
pprFixedRuntimeRepContext FRRCase
= text "The scrutinee of the case statement"
pprFixedRuntimeRepContext (FRRDataConArg expr_or_pat con i)
= text "The" <+> what
where
arg, what :: SDoc
arg = case expr_or_pat of
Expression -> text "argument"
Pattern -> text "pattern"
what
| isNewDataCon con
= text "newtype constructor" <+> arg
| otherwise
= text "data constructor" <+> arg <+> text "in" <+> speakNth i <+> text "position"
pprFixedRuntimeRepContext (FRRNoBindingResArg fn i)
= vcat [ text "Unsaturated use of a representation-polymorphic primitive function."
, text "The" <+> speakNth i <+> text "argument of" <+> quotes (ppr $ getName fn) ]
pprFixedRuntimeRepContext (FRRTupleArg i)
= text "The tuple argument in" <+> speakNth i <+> text "position"
pprFixedRuntimeRepContext (FRRTupleSection i)
= text "The" <+> speakNth i <+> text "component of the tuple section"
pprFixedRuntimeRepContext FRRUnboxedSum
= text "The unboxed sum"
pprFixedRuntimeRepContext (FRRBodyStmt stmtOrig i)
= vcat [ text "The" <+> speakNth i <+> text "argument to (>>)" <> comma
, text "arising from the" <+> ppr stmtOrig <> comma ]
pprFixedRuntimeRepContext FRRBodyStmtGuard
= vcat [ text "The argument to" <+> quotes (text "guard") <> comma
, text "arising from the" <+> ppr MonadComprehension <> comma ]
pprFixedRuntimeRepContext (FRRBindStmt stmtOrig)
= vcat [ text "The first argument to (>>=)" <> comma
, text "arising from the" <+> ppr stmtOrig <> comma ]
pprFixedRuntimeRepContext FRRBindStmtGuard
= sep [ text "The body of the bind statement" ]
pprFixedRuntimeRepContext (FRRArrow arrowContext)
= pprFRRArrowContext arrowContext
pprFixedRuntimeRepContext (FRRExpectedFunTy funTyOrig arg_pos)
= pprExpectedFunTyOrigin funTyOrig arg_pos
instance Outputable FixedRuntimeRepContext where
ppr = pprFixedRuntimeRepContext
data StmtOrigin
= MonadComprehension
| DoNotation
instance Outputable StmtOrigin where
ppr MonadComprehension = text "monad comprehension"
ppr DoNotation = quotes ( text "do" ) <+> text "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 (ArrowCmdResTy cmd)
= vcat [ hang (text "The arrow command") 2 (quotes (ppr cmd)) ]
pprFRRArrowContext (ArrowCmdApp fun arg)
= vcat [ text "The argument in the arrow command application of"
, nest 2 (quotes (ppr fun))
, text "to"
, nest 2 (quotes (ppr arg)) ]
pprFRRArrowContext (ArrowCmdArrApp fun arg ho_app)
= vcat [ text "The function in the" <+> pprHsArrType ho_app <+> text "of"
, nest 2 (quotes (ppr fun))
, text "to"
, nest 2 (quotes (ppr arg)) ]
pprFRRArrowContext ArrowCmdCase
= text "The scrutinee of the arrow case command"
pprFRRArrowContext (ArrowFun fun)
= vcat [ text "The return type of the arrow function"
, nest 2 (quotes (ppr fun)) ]
instance Outputable FRRArrowContext where
ppr = 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 funTy_origin i =
case funTy_origin of
ExpectedFunTySyntaxOp orig op ->
vcat [ sep [ the_arg_of
, text "the rebindable syntax operator"
, quotes (ppr op) ]
, nest 2 (ppr orig) ]
ExpectedFunTyViewPat expr ->
vcat [ the_arg_of <+> text "the view pattern"
, nest 2 (ppr expr) ]
ExpectedFunTyArg fun arg ->
sep [ text "The argument"
, quotes (ppr arg)
, text "of"
, quotes (ppr fun) ]
ExpectedFunTyMatches fun (MG { mg_alts = L _ alts })
| null alts
-> the_arg_of <+> quotes (ppr fun)
| otherwise
-> text "The" <+> speakNth i <+> text "pattern in the equation" <> plural alts
<+> text "for" <+> quotes (ppr fun)
ExpectedFunTyLam {} -> binder_of $ text "lambda"
ExpectedFunTyLamCase lc_variant _ -> binder_of $ lamCaseKeyword lc_variant
where
the_arg_of :: SDoc
the_arg_of = text "The" <+> speakNth i <+> text "argument of"
binder_of :: SDoc -> SDoc
binder_of what = text "The binder of the" <+> what <+> text "expression"
pprExpectedFunTyHerald :: ExpectedFunTyOrigin -> SDoc
pprExpectedFunTyHerald (ExpectedFunTySyntaxOp {})
= text "This rebindable syntax expects a function with"
pprExpectedFunTyHerald (ExpectedFunTyViewPat {})
= text "A view pattern expression expects"
pprExpectedFunTyHerald (ExpectedFunTyArg fun _)
= sep [ text "The function" <+> quotes (ppr fun)
, text "is applied to" ]
pprExpectedFunTyHerald (ExpectedFunTyMatches fun (MG { mg_alts = L _ alts }))
= text "The equation" <> plural alts <+> text "for" <+> quotes (ppr fun) <+> hasOrHave alts
pprExpectedFunTyHerald (ExpectedFunTyLam match)
= sep [ text "The lambda expression" <+>
quotes (pprSetDepth (PartWay 1) $
pprMatches match)
, text "has" ]
pprExpectedFunTyHerald (ExpectedFunTyLamCase _ expr)
= sep [ text "The function" <+> quotes (ppr expr)
, text "requires" ]