module GHC.Core.TyCo.Ppr
(
PprPrec(..), topPrec, sigPrec, opPrec, funPrec, appPrec, maybeParen,
pprType, pprParendType, pprTidiedType, pprPrecType, pprPrecTypeX,
pprTypeApp, pprTCvBndr, pprTCvBndrs,
pprSigmaType,
pprTheta, pprParendTheta, pprForAll, pprUserForAll,
pprTyVar, pprTyVars,
pprThetaArrowTy, pprClassPred,
pprKind, pprParendKind, pprTyLit,
pprDataCons, pprWithExplicitKindsWhen,
pprWithTYPE, pprSourceTyCon,
pprCo, pprParendCo,
debugPprType,
pprTyThingCategory, pprShortTyThing,
) where
import GHC.Prelude
import GHC.CoreToIface
( toIfaceTypeX, toIfaceTyLit, toIfaceForAllBndr
, toIfaceTyCon, toIfaceTcArgs, toIfaceCoercionX )
import GHC.Core.DataCon
( dataConFullSig , dataConUserTyVarBinders
, DataCon )
import GHC.Core.Type ( isLiftedTypeKind, pattern One, pattern Many )
import GHC.Core.TyCon
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Tidy
import GHC.Core.TyCo.FVs
import GHC.Core.Class
import GHC.Types.Var
import GHC.Iface.Type
import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Utils.Outputable
import GHC.Types.Basic ( PprPrec(..), topPrec, sigPrec, opPrec
, funPrec, appPrec, maybeParen )
pprType, pprParendType, pprTidiedType :: Type -> SDoc
pprType = pprPrecType topPrec
pprParendType = pprPrecType appPrec
pprTidiedType = pprIfaceType . toIfaceTypeX emptyVarSet
pprPrecType :: PprPrec -> Type -> SDoc
pprPrecType = pprPrecTypeX emptyTidyEnv
pprPrecTypeX :: TidyEnv -> PprPrec -> Type -> SDoc
pprPrecTypeX env prec ty
= getPprStyle $ \sty ->
getPprDebug $ \debug ->
if debug
then debug_ppr_ty prec ty
else pprPrecIfaceType prec (tidyToIfaceTypeStyX env ty sty)
pprTyLit :: TyLit -> SDoc
pprTyLit = pprIfaceTyLit . toIfaceTyLit
pprKind, pprParendKind :: Kind -> SDoc
pprKind = pprType
pprParendKind = pprParendType
tidyToIfaceTypeStyX :: TidyEnv -> Type -> PprStyle -> IfaceType
tidyToIfaceTypeStyX env ty sty
| userStyle sty = tidyToIfaceTypeX env ty
| otherwise = toIfaceTypeX (tyCoVarsOfType ty) ty
tidyToIfaceType :: Type -> IfaceType
tidyToIfaceType = tidyToIfaceTypeX emptyTidyEnv
tidyToIfaceTypeX :: TidyEnv -> Type -> IfaceType
tidyToIfaceTypeX env ty = toIfaceTypeX (mkVarSet free_tcvs) (tidyType env' ty)
where
env' = tidyFreeTyCoVars env free_tcvs
free_tcvs = tyCoVarsOfTypeWellScoped ty
pprCo, pprParendCo :: Coercion -> SDoc
pprCo co = getPprStyle $ \ sty -> pprIfaceCoercion (tidyToIfaceCoSty co sty)
pprParendCo co = getPprStyle $ \ sty -> pprParendIfaceCoercion (tidyToIfaceCoSty co sty)
tidyToIfaceCoSty :: Coercion -> PprStyle -> IfaceCoercion
tidyToIfaceCoSty co sty
| userStyle sty = tidyToIfaceCo co
| otherwise = toIfaceCoercionX (tyCoVarsOfCo co) co
tidyToIfaceCo :: Coercion -> IfaceCoercion
tidyToIfaceCo co = toIfaceCoercionX (mkVarSet free_tcvs) (tidyCo env co)
where
env = tidyFreeTyCoVars emptyTidyEnv free_tcvs
free_tcvs = scopedSort $ tyCoVarsOfCoList co
pprClassPred :: Class -> [Type] -> SDoc
pprClassPred clas tys = pprTypeApp (classTyCon clas) tys
pprTheta :: ThetaType -> SDoc
pprTheta = pprIfaceContext topPrec . map tidyToIfaceType
pprParendTheta :: ThetaType -> SDoc
pprParendTheta = pprIfaceContext appPrec . map tidyToIfaceType
pprThetaArrowTy :: ThetaType -> SDoc
pprThetaArrowTy = pprIfaceContextArr . map tidyToIfaceType
pprSigmaType :: Type -> SDoc
pprSigmaType = pprIfaceSigmaType ShowForAllWhen . tidyToIfaceType
pprForAll :: [TyCoVarBinder] -> SDoc
pprForAll tvs = pprIfaceForAll (map toIfaceForAllBndr tvs)
pprUserForAll :: [TyCoVarBinder] -> SDoc
pprUserForAll = pprUserIfaceForAll . map toIfaceForAllBndr
pprTCvBndrs :: [TyCoVarBinder] -> SDoc
pprTCvBndrs tvs = sep (map pprTCvBndr tvs)
pprTCvBndr :: TyCoVarBinder -> SDoc
pprTCvBndr = pprTyVar . binderVar
pprTyVars :: [TyVar] -> SDoc
pprTyVars tvs = sep (map pprTyVar tvs)
pprTyVar :: TyVar -> SDoc
pprTyVar tv
| isLiftedTypeKind kind = ppr tv
| otherwise = parens (ppr tv <+> dcolon <+> ppr kind)
where
kind = tyVarKind tv
debugPprType :: Type -> SDoc
debugPprType ty = debug_ppr_ty topPrec ty
debug_ppr_ty :: PprPrec -> Type -> SDoc
debug_ppr_ty _ (LitTy l)
= ppr l
debug_ppr_ty _ (TyVarTy tv)
= ppr tv
debug_ppr_ty prec ty@(FunTy { ft_af = af, ft_mult = mult, ft_arg = arg, ft_res = res })
= maybeParen prec funPrec $
sep [debug_ppr_ty funPrec arg, arr <+> debug_ppr_ty prec res]
where
arr = case af of
VisArg -> case mult of
One -> lollipop
Many -> arrow
w -> mulArrow (ppr w)
InvisArg -> case mult of
Many -> darrow
_ -> pprPanic "unexpected multiplicity" (ppr ty)
debug_ppr_ty prec (TyConApp tc tys)
| null tys = ppr tc
| otherwise = maybeParen prec appPrec $
hang (ppr tc) 2 (sep (map (debug_ppr_ty appPrec) tys))
debug_ppr_ty _ (AppTy t1 t2)
= hang (debug_ppr_ty appPrec t1)
2 (debug_ppr_ty appPrec t2)
debug_ppr_ty prec (CastTy ty co)
= maybeParen prec topPrec $
hang (debug_ppr_ty topPrec ty)
2 (text "|>" <+> ppr co)
debug_ppr_ty _ (CoercionTy co)
= parens (text "CO" <+> ppr co)
debug_ppr_ty prec ty@(ForAllTy {})
| (tvs, body) <- split ty
= maybeParen prec funPrec $
hang (text "forall" <+> fsep (map ppr tvs) <> dot)
2 (ppr body)
where
split ty | ForAllTy tv ty' <- ty
, (tvs, body) <- split ty'
= (tv:tvs, body)
| otherwise
= ([], ty)
pprDataCons :: TyCon -> SDoc
pprDataCons = sepWithVBars . fmap pprDataConWithArgs . tyConDataCons
where
sepWithVBars [] = empty
sepWithVBars docs = sep (punctuate (space <> vbar) docs)
pprDataConWithArgs :: DataCon -> SDoc
pprDataConWithArgs dc = sep [forAllDoc, thetaDoc, ppr dc <+> argsDoc]
where
(_univ_tvs, _ex_tvs, _eq_spec, theta, arg_tys, _res_ty) = dataConFullSig dc
user_bndrs = tyVarSpecToBinders $ dataConUserTyVarBinders dc
forAllDoc = pprUserForAll user_bndrs
thetaDoc = pprThetaArrowTy theta
argsDoc = hsep (fmap pprParendType (map scaledThing arg_tys))
pprTypeApp :: TyCon -> [Type] -> SDoc
pprTypeApp tc tys
= pprIfaceTypeApp topPrec (toIfaceTyCon tc)
(toIfaceTcArgs tc tys)
pprWithExplicitKindsWhen :: Bool -> SDoc -> SDoc
pprWithExplicitKindsWhen b
= updSDocContext $ \ctx ->
if b then ctx { sdocPrintExplicitKinds = True }
else ctx
pprWithTYPE :: Type -> SDoc
pprWithTYPE ty = updSDocContext (\ctx -> ctx { sdocPrintExplicitRuntimeReps = True }) $
ppr ty
pprSourceTyCon :: TyCon -> SDoc
pprSourceTyCon tycon
| Just (fam_tc, tys) <- tyConFamInst_maybe tycon
= ppr $ fam_tc `TyConApp` tys
| otherwise
= ppr tycon