{-# LANGUAGE CPP #-}
module TcOrigin (
UserTypeCtxt(..), pprUserTypeCtxt, isSigMaybe,
SkolemInfo(..), pprSigSkolInfo, pprSkolInfo,
CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin,
isVisibleOrigin, toInvisibleOrigin,
pprCtOrigin, isGivenOrigin
) where
#include "GhclibHsVersions.h"
import GhcPrelude
import TcType
import GHC.Hs
import Id
import DataCon
import ConLike
import TyCon
import InstEnv
import PatSyn
import Module
import Name
import RdrName
import qualified GHC.LanguageExtensions as LangExt
import DynFlags
import SrcLoc
import FastString
import Outputable
import BasicTypes
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 "a RULE 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
| DerivSkol Type
| InstSkol
| InstSC TypeSize
| FamInstSkol
| PatSkol
ConLike
(HsMatchContext Name)
| ArrowSkol
| IPSkol [HsIPName]
| RuleSkol RuleName
| InferSkol [(Name,TcType)]
| BracketSkol
| UnifyForAllSkol
TcType
| TyConSkol TyConFlavour Name
| DataConSkol Name
| ReifySkol
| QuantCtxtSkol
| UnkSkol
instance Outputable SkolemInfo where
ppr = pprSkolInfo
pprSkolInfo :: SkolemInfo -> SDoc
pprSkolInfo (SigSkol cx ty _) = pprSigSkolInfo cx ty
pprSkolInfo (SigTypeSkol cx) = pprUserTypeCtxt cx
pprSkolInfo (ForAllSkol doc) = quotes doc
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 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)
= sep [ text "a pattern with constructor:"
, nest 2 $ ppr dc <+> dcolon
<+> pprType (dataConUserType 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
| HoleOrigin
| UnboundOccurrenceOf OccName
| ListOrigin
| StaticOrigin
| FailablePattern (LPat GhcTcId)
| Shouldn'tHappenOrigin String
| InstProvidedOrigin Module ClsInst
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 (unboundVarOcc 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 _ (Just syn) _ _ _) = exprCtOrigin (syn_expr syn)
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 (HsSCC _ _ _ e) = lexprCtOrigin e
exprCtOrigin (HsCoreAnn _ _ _ 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 (HsTickPragma _ _ _ _ e) = lexprCtOrigin e
exprCtOrigin (HsWrap {}) = panic "exprCtOrigin HsWrap"
exprCtOrigin (XExpr nec) = noExtCon nec
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"
matchesCtOrigin (XMatchGroup nec) = noExtCon nec
grhssCtOrigin :: GRHSs GhcRn (LHsExpr GhcRn) -> CtOrigin
grhssCtOrigin (GRHSs { grhssGRHSs = lgrhss }) = lGRHSCtOrigin lgrhss
grhssCtOrigin (XGRHSs nec) = noExtCon nec
lGRHSCtOrigin :: [LGRHS GhcRn (LHsExpr GhcRn)] -> CtOrigin
lGRHSCtOrigin [L _ (GRHS _ _ (L _ e))] = exprCtOrigin e
lGRHSCtOrigin [L _ (XGRHS nec)] = noExtCon nec
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 ty)))
where
ty = dataConOrigArgTys dc !! (n-1)
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 (FailablePattern pat)
= ctoHerald <+> text "the failable pattern" <+> quotes (ppr pat)
$$
text "(this will become an error in a future GHC release)"
pprCtOrigin (Shouldn'tHappenOrigin note)
= sdocWithDynFlags $ \dflags ->
if xopt LangExt.ImpredicativeTypes dflags
then text "a situation created by impredicative types"
else
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 famly 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 HoleOrigin = text "a use of" <+> quotes (text "_")
pprCtO ListOrigin = text "an overloaded list"
pprCtO StaticOrigin = text "a static form"
pprCtO _ = panic "pprCtOrigin"