module HsTypes (
HsType(..), NewHsTypeX(..), LHsType, HsKind, LHsKind,
HsTyVarBndr(..), LHsTyVarBndr,
LHsQTyVars(..), HsQTvsRn(..),
HsImplicitBndrs(..), HsIBRn(..),
HsWildCardBndrs(..),
LHsSigType, LHsSigWcType, LHsWcType,
HsTupleSort(..),
Promoted(..),
HsContext, LHsContext,
HsTyLit(..),
HsIPName(..), hsIPNameFS,
LBangType, BangType,
HsSrcBang(..), HsImplBang(..),
SrcStrictness(..), SrcUnpackedness(..),
getBangType, getBangStrictness,
ConDeclField(..), LConDeclField, pprConDeclFields,
HsConDetails(..),
FieldOcc(..), LFieldOcc, mkFieldOcc,
AmbiguousFieldOcc(..), mkAmbiguousFieldOcc,
rdrNameAmbiguousFieldOcc, selectorAmbiguousFieldOcc,
unambiguousFieldOcc, ambiguousFieldOcc,
HsWildCardInfo(..), mkAnonWildCardTy, pprAnonWildCard,
wildCardName, sameWildCard,
mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody,
mkEmptyImplicitBndrs, mkEmptyWildCardBndrs,
mkHsQTvs, hsQTvExplicit, emptyLHsQTvs, isEmptyLHsQTvs,
isHsKindedTyVar, hsTvbAllKinded, isLHsForAllTy,
hsScopedTvs, hsWcScopedTvs, dropWildCards,
hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames,
hsLTyVarName, hsLTyVarLocName, hsExplicitLTyVarNames,
splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe,
splitLHsPatSynTy,
splitLHsForAllTy, splitLHsQualTy, splitLHsSigmaTy,
splitHsFunType,
splitHsAppTys, hsTyGetAppHead_maybe,
mkHsOpTy, mkHsAppTy, mkHsAppTys,
ignoreParens, hsSigType, hsSigWcType,
hsLTyVarBndrToType, hsLTyVarBndrsToTypes,
pprHsType, pprHsForAll, pprHsForAllTvs, pprHsForAllExtra,
pprHsContext, pprHsContextNoArrow, pprHsContextMaybe,
hsTypeNeedsParens, parenthesizeHsType
) where
import GhcPrelude
import HsExpr ( HsSplice, pprSplice )
import HsExtension
import HsLit ()
import Id ( Id )
import Name( Name )
import RdrName ( RdrName )
import NameSet ( NameSet, emptyNameSet )
import DataCon( HsSrcBang(..), HsImplBang(..),
SrcStrictness(..), SrcUnpackedness(..) )
import TysPrim( funTyConName )
import Type
import HsDoc
import BasicTypes
import SrcLoc
import Outputable
import FastString
import Maybes( isJust )
import Data.Data hiding ( Fixity, Prefix, Infix )
import Data.Maybe ( fromMaybe )
type LBangType pass = Located (BangType pass)
type BangType pass = HsType pass
getBangType :: LHsType a -> LHsType a
getBangType (L _ (HsBangTy _ _ ty)) = ty
getBangType ty = ty
getBangStrictness :: LHsType a -> HsSrcBang
getBangStrictness (L _ (HsBangTy _ s _)) = s
getBangStrictness _ = (HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict)
type LHsContext pass = Located (HsContext pass)
type HsContext pass = [LHsType pass]
type LHsType pass = Located (HsType pass)
type HsKind pass = HsType pass
type LHsKind pass = Located (HsKind pass)
type LHsTyVarBndr pass = Located (HsTyVarBndr pass)
data LHsQTyVars pass
= HsQTvs { hsq_ext :: XHsQTvs pass
, hsq_explicit :: [LHsTyVarBndr pass]
}
| XLHsQTyVars (XXLHsQTyVars pass)
data HsQTvsRn
= HsQTvsRn
{ hsq_implicit :: [Name]
, hsq_dependent :: NameSet
} deriving Data
type instance XHsQTvs GhcPs = NoExt
type instance XHsQTvs GhcRn = HsQTvsRn
type instance XHsQTvs GhcTc = HsQTvsRn
type instance XXLHsQTyVars (GhcPass _) = NoExt
mkHsQTvs :: [LHsTyVarBndr GhcPs] -> LHsQTyVars GhcPs
mkHsQTvs tvs = HsQTvs { hsq_ext = noExt, hsq_explicit = tvs }
hsQTvExplicit :: LHsQTyVars pass -> [LHsTyVarBndr pass]
hsQTvExplicit = hsq_explicit
emptyLHsQTvs :: LHsQTyVars GhcRn
emptyLHsQTvs = HsQTvs (HsQTvsRn [] emptyNameSet) []
isEmptyLHsQTvs :: LHsQTyVars GhcRn -> Bool
isEmptyLHsQTvs (HsQTvs (HsQTvsRn [] _) []) = True
isEmptyLHsQTvs _ = False
data HsImplicitBndrs pass thing
= HsIB { hsib_ext :: XHsIB pass thing
, hsib_body :: thing
}
| XHsImplicitBndrs (XXHsImplicitBndrs pass thing)
data HsIBRn
= HsIBRn { hsib_vars :: [Name]
, hsib_closed :: Bool
} deriving Data
type instance XHsIB GhcPs _ = NoExt
type instance XHsIB GhcRn _ = HsIBRn
type instance XHsIB GhcTc _ = HsIBRn
type instance XXHsImplicitBndrs (GhcPass _) _ = NoExt
data HsWildCardBndrs pass thing
= HsWC { hswc_ext :: XHsWC pass thing
, hswc_body :: thing
}
| XHsWildCardBndrs (XXHsWildCardBndrs pass thing)
type instance XHsWC GhcPs b = NoExt
type instance XHsWC GhcRn b = [Name]
type instance XHsWC GhcTc b = [Name]
type instance XXHsWildCardBndrs (GhcPass _) b = NoExt
type LHsSigType pass = HsImplicitBndrs pass (LHsType pass)
type LHsWcType pass = HsWildCardBndrs pass (LHsType pass)
type LHsSigWcType pass = HsWildCardBndrs pass (LHsSigType pass)
hsImplicitBody :: HsImplicitBndrs pass thing -> thing
hsImplicitBody (HsIB { hsib_body = body }) = body
hsImplicitBody (XHsImplicitBndrs _) = panic "hsImplicitBody"
hsSigType :: LHsSigType pass -> LHsType pass
hsSigType = hsImplicitBody
hsSigWcType :: LHsSigWcType pass -> LHsType pass
hsSigWcType sig_ty = hsib_body (hswc_body sig_ty)
dropWildCards :: LHsSigWcType pass -> LHsSigType pass
dropWildCards sig_ty = hswc_body sig_ty
mkHsImplicitBndrs :: thing -> HsImplicitBndrs GhcPs thing
mkHsImplicitBndrs x = HsIB { hsib_ext = noExt
, hsib_body = x }
mkHsWildCardBndrs :: thing -> HsWildCardBndrs GhcPs thing
mkHsWildCardBndrs x = HsWC { hswc_body = x
, hswc_ext = noExt }
mkEmptyImplicitBndrs :: thing -> HsImplicitBndrs GhcRn thing
mkEmptyImplicitBndrs x = HsIB { hsib_ext = HsIBRn
{ hsib_vars = []
, hsib_closed = False }
, hsib_body = x }
mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs GhcRn thing
mkEmptyWildCardBndrs x = HsWC { hswc_body = x
, hswc_ext = [] }
newtype HsIPName = HsIPName FastString
deriving( Eq, Data )
hsIPNameFS :: HsIPName -> FastString
hsIPNameFS (HsIPName n) = n
instance Outputable HsIPName where
ppr (HsIPName n) = char '?' <> ftext n
instance OutputableBndr HsIPName where
pprBndr _ n = ppr n
pprInfixOcc n = ppr n
pprPrefixOcc n = ppr n
data HsTyVarBndr pass
= UserTyVar
(XUserTyVar pass)
(Located (IdP pass))
| KindedTyVar
(XKindedTyVar pass)
(Located (IdP pass))
(LHsKind pass)
| XTyVarBndr
(XXTyVarBndr pass)
type instance XUserTyVar (GhcPass _) = NoExt
type instance XKindedTyVar (GhcPass _) = NoExt
type instance XXTyVarBndr (GhcPass _) = NoExt
isHsKindedTyVar :: HsTyVarBndr pass -> Bool
isHsKindedTyVar (UserTyVar {}) = False
isHsKindedTyVar (KindedTyVar {}) = True
isHsKindedTyVar (XTyVarBndr{}) = panic "isHsKindedTyVar"
hsTvbAllKinded :: LHsQTyVars pass -> Bool
hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit
data HsType pass
= HsForAllTy
{ hst_xforall :: XForAllTy pass,
hst_bndrs :: [LHsTyVarBndr pass]
, hst_body :: LHsType pass
}
| HsQualTy
{ hst_xqual :: XQualTy pass
, hst_ctxt :: LHsContext pass
, hst_body :: LHsType pass }
| HsTyVar (XTyVar pass)
Promoted
(Located (IdP pass))
| HsAppTy (XAppTy pass)
(LHsType pass)
(LHsType pass)
| HsFunTy (XFunTy pass)
(LHsType pass)
(LHsType pass)
| HsListTy (XListTy pass)
(LHsType pass)
| HsTupleTy (XTupleTy pass)
HsTupleSort
[LHsType pass]
| HsSumTy (XSumTy pass)
[LHsType pass]
| HsOpTy (XOpTy pass)
(LHsType pass) (Located (IdP pass)) (LHsType pass)
| HsParTy (XParTy pass)
(LHsType pass)
| HsIParamTy (XIParamTy pass)
(Located HsIPName)
(LHsType pass)
| HsStarTy (XStarTy pass)
Bool
| HsKindSig (XKindSig pass)
(LHsType pass)
(LHsKind pass)
| HsSpliceTy (XSpliceTy pass)
(HsSplice pass)
| HsDocTy (XDocTy pass)
(LHsType pass) LHsDocString
| HsBangTy (XBangTy pass)
HsSrcBang (LHsType pass)
| HsRecTy (XRecTy pass)
[LConDeclField pass]
| HsExplicitListTy
(XExplicitListTy pass)
Promoted
[LHsType pass]
| HsExplicitTupleTy
(XExplicitTupleTy pass)
[LHsType pass]
| HsTyLit (XTyLit pass) HsTyLit
| HsWildCardTy (XWildCardTy pass)
| XHsType
(XXType pass)
data NewHsTypeX
= NHsCoreTy Type
deriving Data
instance Outputable NewHsTypeX where
ppr (NHsCoreTy ty) = ppr ty
type instance XForAllTy (GhcPass _) = NoExt
type instance XQualTy (GhcPass _) = NoExt
type instance XTyVar (GhcPass _) = NoExt
type instance XAppTy (GhcPass _) = NoExt
type instance XFunTy (GhcPass _) = NoExt
type instance XListTy (GhcPass _) = NoExt
type instance XTupleTy (GhcPass _) = NoExt
type instance XSumTy (GhcPass _) = NoExt
type instance XOpTy (GhcPass _) = NoExt
type instance XParTy (GhcPass _) = NoExt
type instance XIParamTy (GhcPass _) = NoExt
type instance XStarTy (GhcPass _) = NoExt
type instance XKindSig (GhcPass _) = NoExt
type instance XSpliceTy GhcPs = NoExt
type instance XSpliceTy GhcRn = NoExt
type instance XSpliceTy GhcTc = Kind
type instance XDocTy (GhcPass _) = NoExt
type instance XBangTy (GhcPass _) = NoExt
type instance XRecTy (GhcPass _) = NoExt
type instance XExplicitListTy GhcPs = NoExt
type instance XExplicitListTy GhcRn = NoExt
type instance XExplicitListTy GhcTc = Kind
type instance XExplicitTupleTy GhcPs = NoExt
type instance XExplicitTupleTy GhcRn = NoExt
type instance XExplicitTupleTy GhcTc = [Kind]
type instance XTyLit (GhcPass _) = NoExt
type instance XWildCardTy GhcPs = NoExt
type instance XWildCardTy GhcRn = HsWildCardInfo
type instance XWildCardTy GhcTc = HsWildCardInfo
type instance XXType (GhcPass _) = NewHsTypeX
data HsTyLit
= HsNumTy SourceText Integer
| HsStrTy SourceText FastString
deriving Data
newtype HsWildCardInfo
= AnonWildCard (Located Name)
deriving Data
data HsTupleSort = HsUnboxedTuple
| HsBoxedTuple
| HsConstraintTuple
| HsBoxedOrConstraintTuple
deriving Data
data Promoted = Promoted
| NotPromoted
deriving (Data, Eq, Show)
type LConDeclField pass = Located (ConDeclField pass)
data ConDeclField pass
= ConDeclField { cd_fld_ext :: XConDeclField pass,
cd_fld_names :: [LFieldOcc pass],
cd_fld_type :: LBangType pass,
cd_fld_doc :: Maybe LHsDocString }
| XConDeclField (XXConDeclField pass)
type instance XConDeclField (GhcPass _) = NoExt
type instance XXConDeclField (GhcPass _) = NoExt
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (ConDeclField p) where
ppr (ConDeclField _ fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty
ppr (XConDeclField x) = ppr x
data HsConDetails arg rec
= PrefixCon [arg]
| RecCon rec
| InfixCon arg arg
deriving Data
instance (Outputable arg, Outputable rec)
=> Outputable (HsConDetails arg rec) where
ppr (PrefixCon args) = text "PrefixCon" <+> ppr args
ppr (RecCon rec) = text "RecCon:" <+> ppr rec
ppr (InfixCon l r) = text "InfixCon:" <+> ppr [l, r]
hsWcScopedTvs :: LHsSigWcType GhcRn -> [Name]
hsWcScopedTvs sig_ty
| HsWC { hswc_ext = nwcs, hswc_body = sig_ty1 } <- sig_ty
, HsIB { hsib_ext = HsIBRn { hsib_vars = vars}
, hsib_body = sig_ty2 } <- sig_ty1
= case sig_ty2 of
L _ (HsForAllTy { hst_bndrs = tvs }) -> vars ++ nwcs ++
map hsLTyVarName tvs
_ -> nwcs
hsWcScopedTvs (HsWC _ (XHsImplicitBndrs _)) = panic "hsWcScopedTvs"
hsWcScopedTvs (XHsWildCardBndrs _) = panic "hsWcScopedTvs"
hsScopedTvs :: LHsSigType GhcRn -> [Name]
hsScopedTvs sig_ty
| HsIB { hsib_ext = HsIBRn { hsib_vars = vars }
, hsib_body = sig_ty2 } <- sig_ty
, L _ (HsForAllTy { hst_bndrs = tvs }) <- sig_ty2
= vars ++ map hsLTyVarName tvs
| otherwise
= []
hsTyVarName :: HsTyVarBndr pass -> IdP pass
hsTyVarName (UserTyVar _ (L _ n)) = n
hsTyVarName (KindedTyVar _ (L _ n) _) = n
hsTyVarName (XTyVarBndr{}) = panic "hsTyVarName"
hsLTyVarName :: LHsTyVarBndr pass -> IdP pass
hsLTyVarName = hsTyVarName . unLoc
hsExplicitLTyVarNames :: LHsQTyVars pass -> [IdP pass]
hsExplicitLTyVarNames qtvs = map hsLTyVarName (hsQTvExplicit qtvs)
hsAllLTyVarNames :: LHsQTyVars GhcRn -> [Name]
hsAllLTyVarNames (HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = kvs }
, hsq_explicit = tvs })
= kvs ++ map hsLTyVarName tvs
hsAllLTyVarNames (XLHsQTyVars _) = panic "hsAllLTyVarNames"
hsLTyVarLocName :: LHsTyVarBndr pass -> Located (IdP pass)
hsLTyVarLocName = fmap hsTyVarName
hsLTyVarLocNames :: LHsQTyVars pass -> [Located (IdP pass)]
hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs)
hsLTyVarBndrToType :: LHsTyVarBndr (GhcPass p) -> LHsType (GhcPass p)
hsLTyVarBndrToType = fmap cvt
where cvt (UserTyVar _ n) = HsTyVar noExt NotPromoted n
cvt (KindedTyVar _ (L name_loc n) kind)
= HsKindSig noExt
(L name_loc (HsTyVar noExt NotPromoted (L name_loc n))) kind
cvt (XTyVarBndr{}) = panic "hsLTyVarBndrToType"
hsLTyVarBndrsToTypes :: LHsQTyVars (GhcPass p) -> [LHsType (GhcPass p)]
hsLTyVarBndrsToTypes (HsQTvs { hsq_explicit = tvbs }) = map hsLTyVarBndrToType tvbs
hsLTyVarBndrsToTypes (XLHsQTyVars _) = panic "hsLTyVarBndrsToTypes"
wildCardName :: HsWildCardInfo -> Name
wildCardName (AnonWildCard (L _ n)) = n
sameWildCard :: Located HsWildCardInfo -> Located HsWildCardInfo -> Bool
sameWildCard (L l1 (AnonWildCard _)) (L l2 (AnonWildCard _)) = l1 == l2
ignoreParens :: LHsType pass -> LHsType pass
ignoreParens (L _ (HsParTy _ ty)) = ignoreParens ty
ignoreParens ty = ty
isLHsForAllTy :: LHsType p -> Bool
isLHsForAllTy (L _ (HsForAllTy {})) = True
isLHsForAllTy _ = False
mkAnonWildCardTy :: HsType GhcPs
mkAnonWildCardTy = HsWildCardTy noExt
mkHsOpTy :: LHsType (GhcPass p) -> Located (IdP (GhcPass p))
-> LHsType (GhcPass p) -> HsType (GhcPass p)
mkHsOpTy ty1 op ty2 = HsOpTy noExt ty1 op ty2
mkHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
mkHsAppTy t1 t2
= addCLoc t1 t2 (HsAppTy noExt t1 (parenthesizeHsType appPrec t2))
mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)]
-> LHsType (GhcPass p)
mkHsAppTys = foldl mkHsAppTy
splitHsFunType :: LHsType GhcRn -> ([LHsType GhcRn], LHsType GhcRn)
splitHsFunType (L _ (HsParTy _ ty))
= splitHsFunType ty
splitHsFunType (L _ (HsFunTy _ x y))
| (args, res) <- splitHsFunType y
= (x:args, res)
splitHsFunType orig_ty@(L _ (HsAppTy _ t1 t2))
= go t1 [t2]
where
go (L _ (HsTyVar _ _ (L _ fn))) tys | fn == funTyConName
, [t1,t2] <- tys
, (args, res) <- splitHsFunType t2
= (t1:args, res)
go (L _ (HsAppTy _ t1 t2)) tys = go t1 (t2:tys)
go (L _ (HsParTy _ ty)) tys = go ty tys
go _ _ = ([], orig_ty)
splitHsFunType other = ([], other)
hsTyGetAppHead_maybe :: LHsType (GhcPass p)
-> Maybe (Located (IdP (GhcPass p)), [LHsType (GhcPass p)])
hsTyGetAppHead_maybe = go []
where
go tys (L _ (HsTyVar _ _ ln)) = Just (ln, tys)
go tys (L _ (HsAppTy _ l r)) = go (r : tys) l
go tys (L _ (HsOpTy _ l (L loc n) r)) = Just (L loc n, l : r : tys)
go tys (L _ (HsParTy _ t)) = go tys t
go tys (L _ (HsKindSig _ t _)) = go tys t
go _ _ = Nothing
splitHsAppTys :: LHsType GhcRn -> [LHsType GhcRn]
-> (LHsType GhcRn, [LHsType GhcRn])
splitHsAppTys (L _ (HsAppTy _ f a)) as = splitHsAppTys f (a:as)
splitHsAppTys (L _ (HsParTy _ f)) as = splitHsAppTys f as
splitHsAppTys f as = (f,as)
splitLHsPatSynTy :: LHsType pass
-> ( [LHsTyVarBndr pass]
, LHsContext pass
, [LHsTyVarBndr pass]
, LHsContext pass
, LHsType pass)
splitLHsPatSynTy ty = (univs, reqs, exis, provs, ty4)
where
(univs, ty1) = splitLHsForAllTy ty
(reqs, ty2) = splitLHsQualTy ty1
(exis, ty3) = splitLHsForAllTy ty2
(provs, ty4) = splitLHsQualTy ty3
splitLHsSigmaTy :: LHsType pass
-> ([LHsTyVarBndr pass], LHsContext pass, LHsType pass)
splitLHsSigmaTy ty
| (tvs, ty1) <- splitLHsForAllTy ty
, (ctxt, ty2) <- splitLHsQualTy ty1
= (tvs, ctxt, ty2)
splitLHsForAllTy :: LHsType pass -> ([LHsTyVarBndr pass], LHsType pass)
splitLHsForAllTy (L _ (HsParTy _ ty)) = splitLHsForAllTy ty
splitLHsForAllTy (L _ (HsForAllTy { hst_bndrs = tvs, hst_body = body })) = (tvs, body)
splitLHsForAllTy body = ([], body)
splitLHsQualTy :: LHsType pass -> (LHsContext pass, LHsType pass)
splitLHsQualTy (L _ (HsParTy _ ty)) = splitLHsQualTy ty
splitLHsQualTy (L _ (HsQualTy { hst_ctxt = ctxt, hst_body = body })) = (ctxt, body)
splitLHsQualTy body = (noLoc [], body)
splitLHsInstDeclTy :: LHsSigType GhcRn
-> ([Name], LHsContext GhcRn, LHsType GhcRn)
splitLHsInstDeclTy (HsIB { hsib_ext = HsIBRn { hsib_vars = itkvs }
, hsib_body = inst_ty })
| (tvs, cxt, body_ty) <- splitLHsSigmaTy inst_ty
= (itkvs ++ map hsLTyVarName tvs, cxt, body_ty)
splitLHsInstDeclTy (XHsImplicitBndrs _) = panic "splitLHsInstDeclTy"
getLHsInstDeclHead :: LHsSigType pass -> LHsType pass
getLHsInstDeclHead inst_ty
| (_tvs, _cxt, body_ty) <- splitLHsSigmaTy (hsSigType inst_ty)
= body_ty
getLHsInstDeclClass_maybe :: LHsSigType (GhcPass p)
-> Maybe (Located (IdP (GhcPass p)))
getLHsInstDeclClass_maybe inst_ty
= do { let head_ty = getLHsInstDeclHead inst_ty
; (cls, _) <- hsTyGetAppHead_maybe head_ty
; return cls }
type LFieldOcc pass = Located (FieldOcc pass)
data FieldOcc pass = FieldOcc { extFieldOcc :: XCFieldOcc pass
, rdrNameFieldOcc :: Located RdrName
}
| XFieldOcc
(XXFieldOcc pass)
deriving instance (p ~ GhcPass pass, Eq (XCFieldOcc p)) => Eq (FieldOcc p)
deriving instance (p ~ GhcPass pass, Ord (XCFieldOcc p)) => Ord (FieldOcc p)
type instance XCFieldOcc GhcPs = NoExt
type instance XCFieldOcc GhcRn = Name
type instance XCFieldOcc GhcTc = Id
type instance XXFieldOcc (GhcPass _) = NoExt
instance Outputable (FieldOcc pass) where
ppr = ppr . rdrNameFieldOcc
mkFieldOcc :: Located RdrName -> FieldOcc GhcPs
mkFieldOcc rdr = FieldOcc noExt rdr
data AmbiguousFieldOcc pass
= Unambiguous (XUnambiguous pass) (Located RdrName)
| Ambiguous (XAmbiguous pass) (Located RdrName)
| XAmbiguousFieldOcc (XXAmbiguousFieldOcc pass)
type instance XUnambiguous GhcPs = NoExt
type instance XUnambiguous GhcRn = Name
type instance XUnambiguous GhcTc = Id
type instance XAmbiguous GhcPs = NoExt
type instance XAmbiguous GhcRn = NoExt
type instance XAmbiguous GhcTc = Id
type instance XXAmbiguousFieldOcc (GhcPass _) = NoExt
instance p ~ GhcPass pass => Outputable (AmbiguousFieldOcc p) where
ppr = ppr . rdrNameAmbiguousFieldOcc
instance p ~ GhcPass pass => OutputableBndr (AmbiguousFieldOcc p) where
pprInfixOcc = pprInfixOcc . rdrNameAmbiguousFieldOcc
pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc
mkAmbiguousFieldOcc :: Located RdrName -> AmbiguousFieldOcc GhcPs
mkAmbiguousFieldOcc rdr = Unambiguous noExt rdr
rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc (GhcPass p) -> RdrName
rdrNameAmbiguousFieldOcc (Unambiguous _ (L _ rdr)) = rdr
rdrNameAmbiguousFieldOcc (Ambiguous _ (L _ rdr)) = rdr
rdrNameAmbiguousFieldOcc (XAmbiguousFieldOcc _)
= panic "rdrNameAmbiguousFieldOcc"
selectorAmbiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> Id
selectorAmbiguousFieldOcc (Unambiguous sel _) = sel
selectorAmbiguousFieldOcc (Ambiguous sel _) = sel
selectorAmbiguousFieldOcc (XAmbiguousFieldOcc _)
= panic "selectorAmbiguousFieldOcc"
unambiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> FieldOcc GhcTc
unambiguousFieldOcc (Unambiguous rdr sel) = FieldOcc rdr sel
unambiguousFieldOcc (Ambiguous rdr sel) = FieldOcc rdr sel
unambiguousFieldOcc (XAmbiguousFieldOcc _) = panic "unambiguousFieldOcc"
ambiguousFieldOcc :: FieldOcc GhcTc -> AmbiguousFieldOcc GhcTc
ambiguousFieldOcc (FieldOcc sel rdr) = Unambiguous sel rdr
ambiguousFieldOcc (XFieldOcc _) = panic "ambiguousFieldOcc"
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsType p) where
ppr ty = pprHsType ty
instance Outputable HsTyLit where
ppr = ppr_tylit
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (LHsQTyVars p) where
ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs
ppr (XLHsQTyVars x) = ppr x
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (HsTyVarBndr p) where
ppr (UserTyVar _ n) = ppr n
ppr (KindedTyVar _ n k) = parens $ hsep [ppr n, dcolon, ppr k]
ppr (XTyVarBndr n) = ppr n
instance (p ~ GhcPass pass,Outputable thing)
=> Outputable (HsImplicitBndrs p thing) where
ppr (HsIB { hsib_body = ty }) = ppr ty
ppr (XHsImplicitBndrs x) = ppr x
instance (p ~ GhcPass pass,Outputable thing)
=> Outputable (HsWildCardBndrs p thing) where
ppr (HsWC { hswc_body = ty }) = ppr ty
ppr (XHsWildCardBndrs x) = ppr x
instance Outputable HsWildCardInfo where
ppr (AnonWildCard _) = char '_'
pprAnonWildCard :: SDoc
pprAnonWildCard = char '_'
pprHsForAll :: (OutputableBndrId (GhcPass p))
=> [LHsTyVarBndr (GhcPass p)] -> LHsContext (GhcPass p) -> SDoc
pprHsForAll = pprHsForAllExtra Nothing
pprHsForAllExtra :: (OutputableBndrId (GhcPass p))
=> Maybe SrcSpan -> [LHsTyVarBndr (GhcPass p)]
-> LHsContext (GhcPass p) -> SDoc
pprHsForAllExtra extra qtvs cxt
= pprHsForAllTvs qtvs <+> pprHsContextExtra show_extra (unLoc cxt)
where
show_extra = isJust extra
pprHsForAllTvs :: (OutputableBndrId (GhcPass p))
=> [LHsTyVarBndr (GhcPass p)] -> SDoc
pprHsForAllTvs qtvs
| null qtvs = whenPprDebug (forAllLit <+> dot)
| otherwise = forAllLit <+> interppSP qtvs <> dot
pprHsContext :: (OutputableBndrId (GhcPass p)) => HsContext (GhcPass p) -> SDoc
pprHsContext = maybe empty (<+> darrow) . pprHsContextMaybe
pprHsContextNoArrow :: (OutputableBndrId (GhcPass p))
=> HsContext (GhcPass p) -> SDoc
pprHsContextNoArrow = fromMaybe empty . pprHsContextMaybe
pprHsContextMaybe :: (OutputableBndrId (GhcPass p))
=> HsContext (GhcPass p) -> Maybe SDoc
pprHsContextMaybe [] = Nothing
pprHsContextMaybe [L _ pred] = Just $ ppr_mono_ty pred
pprHsContextMaybe cxt = Just $ parens (interpp'SP cxt)
pprHsContextAlways :: (OutputableBndrId (GhcPass p))
=> HsContext (GhcPass p) -> SDoc
pprHsContextAlways [] = parens empty <+> darrow
pprHsContextAlways [L _ ty] = ppr_mono_ty ty <+> darrow
pprHsContextAlways cxt = parens (interpp'SP cxt) <+> darrow
pprHsContextExtra :: (OutputableBndrId (GhcPass p))
=> Bool -> HsContext (GhcPass p) -> SDoc
pprHsContextExtra show_extra ctxt
| not show_extra
= pprHsContext ctxt
| null ctxt
= char '_' <+> darrow
| otherwise
= parens (sep (punctuate comma ctxt')) <+> darrow
where
ctxt' = map ppr ctxt ++ [char '_']
pprConDeclFields :: (OutputableBndrId (GhcPass p))
=> [LConDeclField (GhcPass p)] -> SDoc
pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))
where
ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty,
cd_fld_doc = doc }))
= ppr_names ns <+> dcolon <+> ppr ty <+> ppr_mbDoc doc
ppr_fld (L _ (XConDeclField x)) = ppr x
ppr_names [n] = ppr n
ppr_names ns = sep (punctuate comma (map ppr ns))
pprHsType :: (OutputableBndrId (GhcPass p)) => HsType (GhcPass p) -> SDoc
pprHsType ty = ppr_mono_ty ty
ppr_mono_lty :: (OutputableBndrId (GhcPass p)) => LHsType (GhcPass p) -> SDoc
ppr_mono_lty ty = ppr_mono_ty (unLoc ty)
ppr_mono_ty :: (OutputableBndrId (GhcPass p)) => HsType (GhcPass p) -> SDoc
ppr_mono_ty (HsForAllTy { hst_bndrs = tvs, hst_body = ty })
= sep [pprHsForAllTvs tvs, ppr_mono_lty ty]
ppr_mono_ty (HsQualTy { hst_ctxt = L _ ctxt, hst_body = ty })
= sep [pprHsContextAlways ctxt, ppr_mono_lty ty]
ppr_mono_ty (HsBangTy _ b ty) = ppr b <> ppr_mono_lty ty
ppr_mono_ty (HsRecTy _ flds) = pprConDeclFields flds
ppr_mono_ty (HsTyVar _ NotPromoted (L _ name))= pprPrefixOcc name
ppr_mono_ty (HsTyVar _ Promoted (L _ name))
= space <> quote (pprPrefixOcc name)
ppr_mono_ty (HsFunTy _ ty1 ty2) = ppr_fun_ty ty1 ty2
ppr_mono_ty (HsTupleTy _ con tys) = tupleParens std_con (pprWithCommas ppr tys)
where std_con = case con of
HsUnboxedTuple -> UnboxedTuple
_ -> BoxedTuple
ppr_mono_ty (HsSumTy _ tys)
= tupleParens UnboxedTuple (pprWithBars ppr tys)
ppr_mono_ty (HsKindSig _ ty kind)
= parens (ppr_mono_lty ty <+> dcolon <+> ppr kind)
ppr_mono_ty (HsListTy _ ty) = brackets (ppr_mono_lty ty)
ppr_mono_ty (HsIParamTy _ n ty) = (ppr n <+> dcolon <+> ppr_mono_lty ty)
ppr_mono_ty (HsSpliceTy _ s) = pprSplice s
ppr_mono_ty (HsExplicitListTy _ Promoted tys)
= quote $ brackets (interpp'SP tys)
ppr_mono_ty (HsExplicitListTy _ NotPromoted tys)
= brackets (interpp'SP tys)
ppr_mono_ty (HsExplicitTupleTy _ tys) = quote $ parens (interpp'SP tys)
ppr_mono_ty (HsTyLit _ t) = ppr_tylit t
ppr_mono_ty (HsWildCardTy {}) = char '_'
ppr_mono_ty (HsStarTy _ isUni) = char (if isUni then '★' else '*')
ppr_mono_ty (HsAppTy _ fun_ty arg_ty)
= hsep [ppr_mono_lty fun_ty, ppr_mono_lty arg_ty]
ppr_mono_ty (HsOpTy _ ty1 (L _ op) ty2)
= sep [ ppr_mono_lty ty1
, sep [pprInfixOcc op, ppr_mono_lty ty2 ] ]
ppr_mono_ty (HsParTy _ ty)
= parens (ppr_mono_lty ty)
ppr_mono_ty (HsDocTy _ ty doc)
= ppr_mono_lty ty <+> ppr (unLoc doc)
ppr_mono_ty (XHsType t) = ppr t
ppr_fun_ty :: (OutputableBndrId (GhcPass p))
=> LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc
ppr_fun_ty ty1 ty2
= let p1 = ppr_mono_lty ty1
p2 = ppr_mono_lty ty2
in
sep [p1, text "->" <+> p2]
ppr_tylit :: HsTyLit -> SDoc
ppr_tylit (HsNumTy _ i) = integer i
ppr_tylit (HsStrTy _ s) = text (show s)
hsTypeNeedsParens :: PprPrec -> HsType pass -> Bool
hsTypeNeedsParens p = go
where
go (HsForAllTy{}) = p >= funPrec
go (HsQualTy{}) = p >= funPrec
go (HsBangTy{}) = p > topPrec
go (HsRecTy{}) = False
go (HsTyVar{}) = False
go (HsFunTy{}) = p >= funPrec
go (HsTupleTy{}) = False
go (HsSumTy{}) = False
go (HsKindSig{}) = False
go (HsListTy{}) = False
go (HsIParamTy{}) = p > topPrec
go (HsSpliceTy{}) = False
go (HsExplicitListTy{}) = False
go (HsExplicitTupleTy{}) = False
go (HsTyLit{}) = False
go (HsWildCardTy{}) = False
go (HsStarTy{}) = False
go (HsAppTy{}) = p >= appPrec
go (HsOpTy{}) = p >= opPrec
go (HsParTy{}) = False
go (HsDocTy _ (L _ t) _) = go t
go (XHsType{}) = False
parenthesizeHsType :: PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType p lty@(L loc ty)
| hsTypeNeedsParens p ty = L loc (HsParTy NoExt lty)
| otherwise = lty