module GHC.Tc.Types.Origin (
UserTypeCtxt(..), pprUserTypeCtxt, isSigMaybe,
SkolemInfo(..), pprSigSkolInfo, pprSkolInfo,
CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin,
isVisibleOrigin, toInvisibleOrigin,
pprCtOrigin, isGivenOrigin
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Tc.Utils.TcType
import GHC.Hs
import GHC.Types.Id
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.Name
import GHC.Types.Name.Reader
import GHC.Types.SrcLoc
import GHC.Data.FastString
import GHC.Utils.Outputable
import GHC.Types.Basic
data UserTypeCtxt
= FunSigCtxt
Name
Bool
| InfSigCtxt Name
| ExprSigCtxt
| KindSigCtxt
| StandaloneKindSigCtxt
Name
| TypeAppCtxt
| ConArgCtxt Name
| TySynCtxt Name
| PatSynCtxt Name
| PatSigCtxt
| RuleSigCtxt Name
| ResSigCtxt
| ForSigCtxt Name
| DefaultDeclCtxt
| InstDeclCtxt Bool
| SpecInstCtxt
| ThBrackCtxt
| GenSigCtxt
| GhciCtxt Bool
| ClassSCCtxt Name
| SigmaCtxt
| DataTyCtxt Name
| DerivClauseCtxt
| TyVarBndrKindCtxt Name
| DataKindCtxt Name
| TySynKindCtxt Name
| TyFamResKindCtxt Name
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 ThBrackCtxt = text "a Template Haskell quotation [t|...|]"
pprUserTypeCtxt PatSigCtxt = text "a pattern type signature"
pprUserTypeCtxt ResSigCtxt = text "a result 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
= SigSkol
UserTypeCtxt
TcType
[(Name,TcTyVar)]
| SigTypeSkol UserTypeCtxt
| ForAllSkol
SDoc
SDoc
| DerivSkol Type
| InstSkol
| InstSC TypeSize
| FamInstSkol
| PatSkol
ConLike
(HsMatchContext GhcRn)
| ArrowSkol
| IPSkol [HsIPName]
| RuleSkol RuleName
| InferSkol [(Name,TcType)]
| BracketSkol
| UnifyForAllSkol
TcType
| TyConSkol TyConFlavour Name
| DataConSkol Name
| ReifySkol
| QuantCtxtSkol
| RuntimeUnkSkol
| UnkSkol
instance Outputable SkolemInfo where
ppr = pprSkolInfo
pprSkolInfo :: SkolemInfo -> SDoc
pprSkolInfo (SigSkol cx ty _) = pprSigSkolInfo cx ty
pprSkolInfo (SigTypeSkol cx) = pprUserTypeCtxt cx
pprSkolInfo (ForAllSkol pt _) = quotes pt
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 (InstSC n) = text "the instance declaration" <> whenPprDebug (parens (ppr n))
pprSkolInfo FamInstSkol = text "a family instance declaration"
pprSkolInfo BracketSkol = text "a Template Haskell bracket"
pprSkolInfo (RuleSkol name) = text "the RULE" <+> pprRuleName name
pprSkolInfo ArrowSkol = text "an arrow form"
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 data constructor" <+> 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 UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) text "UnkSkol"
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)
= sdocWithDynFlags (\dflags ->
sep [ text "a pattern with constructor:"
, nest 2 $ ppr dc <+> dcolon
<+> pprType (dataConDisplayType dflags dc) <> comma ])
pprPatSkolInfo (PatSynCon ps)
= sep [ text "a pattern with pattern synonym:"
, nest 2 $ ppr ps <+> dcolon
<+> pprPatSynType ps <> comma ]
data CtOrigin
= GivenOrigin SkolemInfo
| OccurrenceOf Name
| OccurrenceOfRecSel RdrName
| AppOrigin
| SpecPragOrigin UserTypeCtxt
| TypeEqOrigin { uo_actual :: TcType
, uo_expected :: TcType
, uo_thing :: Maybe SDoc
, uo_visible :: Bool
}
| KindEqOrigin
TcType (Maybe TcType)
CtOrigin
(Maybe TypeOrKind)
| IPOccOrigin HsIPName
| OverLabelOrigin FastString
| LiteralOrigin (HsOverLit GhcRn)
| NegateOrigin
| ArithSeqOrigin (ArithSeqInfo GhcRn)
| AssocFamPatOrigin
| SectionOrigin
| 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)
| IfOrigin
| ProcOrigin
| AnnOrigin
| FunDepOrigin1
PredType CtOrigin RealSrcSpan
PredType CtOrigin RealSrcSpan
| FunDepOrigin2
PredType CtOrigin
PredType SrcSpan
| ExprHoleOrigin OccName
| TypeHoleOrigin OccName
| PatCheckOrigin
| UnboundOccurrenceOf OccName
| ListOrigin
| BracketOrigin
| StaticOrigin
| Shouldn'tHappenOrigin String
| InstProvidedOrigin Module ClsInst
| NonLinearPatternOrigin
| UsageEnvironmentOf Name
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 (FunDepOrigin1 _ o1 _ _ o2 _) = isGivenOrigin o1 && isGivenOrigin o2
isGivenOrigin (FunDepOrigin2 _ o1 _ _) = isGivenOrigin o1
isGivenOrigin _ = 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 (HsUnboundVar _ uv) = UnboundOccurrenceOf uv
exprCtOrigin (HsConLikeOut {}) = panic "exprCtOrigin HsConLikeOut"
exprCtOrigin (HsRecFld _ f) = OccurrenceOfRecSel (rdrNameAmbiguousFieldOcc f)
exprCtOrigin (HsOverLabel _ _ l) = OverLabelOrigin l
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 (SectionL _ _ _) = SectionOrigin
exprCtOrigin (SectionR _ _ _) = SectionOrigin
exprCtOrigin (ExplicitTuple {}) = Shouldn'tHappenOrigin "explicit tuple"
exprCtOrigin ExplicitSum{} = Shouldn'tHappenOrigin "explicit sum"
exprCtOrigin (HsCase _ _ matches) = matchesCtOrigin matches
exprCtOrigin (HsIf {}) = Shouldn'tHappenOrigin "if expression"
exprCtOrigin (HsMultiIf _ rhs) = lGRHSCtOrigin rhs
exprCtOrigin (HsLet _ _ e) = lexprCtOrigin e
exprCtOrigin (HsDo {}) = DoOrigin
exprCtOrigin (ExplicitList {}) = Shouldn'tHappenOrigin "list"
exprCtOrigin (RecordCon {}) = Shouldn'tHappenOrigin "record construction"
exprCtOrigin (RecordUpd {}) = Shouldn'tHappenOrigin "record update"
exprCtOrigin (ExprWithTySig {}) = ExprSigOrigin
exprCtOrigin (ArithSeq {}) = Shouldn'tHappenOrigin "arithmetic sequence"
exprCtOrigin (HsPragE _ _ e) = lexprCtOrigin e
exprCtOrigin (HsBracket {}) = Shouldn'tHappenOrigin "TH bracket"
exprCtOrigin (HsRnBracketOut {})= Shouldn'tHappenOrigin "HsRnBracketOut"
exprCtOrigin (HsTcBracketOut {})= panic "exprCtOrigin HsTcBracketOut"
exprCtOrigin (HsSpliceE {}) = Shouldn'tHappenOrigin "TH splice"
exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc"
exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression"
exprCtOrigin (HsTick _ _ e) = lexprCtOrigin e
exprCtOrigin (HsBinTick _ _ _ e) = lexprCtOrigin e
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 (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 (KindEqOrigin t1 (Just t2) _ _)
= hang (ctoHerald <+> text "a kind equality arising from")
2 (sep [ppr t1, char '~', ppr t2])
pprCtOrigin AssocFamPatOrigin
= text "when matching a family LHS with its class instance head"
pprCtOrigin (KindEqOrigin t1 Nothing _ _)
= hang (ctoHerald <+> text "a kind equality when matching")
2 (ppr t1)
pprCtOrigin (UnboundOccurrenceOf name)
= ctoHerald <+> text "an undeclared identifier" <+> quotes (ppr name)
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)
= sdocOption sdocImpredicativeTypes $ \case
True -> text "a situation created by impredicative types"
False -> 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 (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 simple_origin
= ctoHerald <+> pprCtO simple_origin
pprCtO :: 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 IfOrigin = text "an if expression"
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 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 (TypeEqOrigin t1 t2 _ _)= text "a type equality" <+> sep [ppr t1, char '~', ppr t2]
pprCtO AnnOrigin = text "an annotation"
pprCtO (ExprHoleOrigin 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 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 _ = panic "pprCtOrigin"