module IfaceType (
IfExtName, IfLclName,
IfaceType(..), IfacePredType, IfaceKind, IfaceCoercion(..),
IfaceUnivCoProv(..),
IfaceTyCon(..), IfaceTyConInfo(..), IfaceTyConSort(..), IsPromoted(..),
IfaceTyLit(..), IfaceTcArgs(..),
IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr,
IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder,
IfaceForAllBndr, ArgFlag(..), ShowForAllFlag(..),
ifForAllBndrTyVar, ifForAllBndrName,
ifTyConBinderTyVar, ifTyConBinderName,
isIfaceLiftedTypeKind,
tcArgsIfaceTypes,
pprIfaceType, pprParendIfaceType, pprPrecIfaceType,
pprIfaceContext, pprIfaceContextArr,
pprIfaceIdBndr, pprIfaceLamBndr, pprIfaceTvBndr, pprIfaceTyConBinders,
pprIfaceBndrs, pprIfaceTcArgs, pprParendIfaceTcArgs,
pprIfaceForAllPart, pprIfaceForAllPartMust, pprIfaceForAll,
pprIfaceSigmaType, pprIfaceTyLit,
pprIfaceCoercion, pprParendIfaceCoercion,
splitIfaceSigmaTy, pprIfaceTypeApp, pprUserIfaceForAll,
pprIfaceCoTcApp, pprTyTcApp, pprIfacePrefixApp,
suppressIfaceInvisibles,
stripIfaceInvisVars,
stripInvisArgs,
mkIfaceTySubst, substIfaceTyVar, substIfaceTcArgs, inDomIfaceTySubst
) where
#include "HsVersions.h"
import GhcPrelude
import TysWiredIn ( coercibleTyCon, heqTyCon
, liftedRepDataConTyCon )
import TyCoRep ( isRuntimeRepTy )
import DynFlags
import TyCon hiding ( pprPromotionQuote )
import CoAxiom
import Var
import PrelNames
import Name
import BasicTypes
import Binary
import Outputable
import FastString
import FastStringEnv
import Util
import Data.Maybe( isJust )
import Data.List (foldl')
import qualified Data.Semigroup as Semi
type IfLclName = FastString
type IfExtName = Name
data IfaceBndr
= IfaceIdBndr !IfaceIdBndr
| IfaceTvBndr !IfaceTvBndr
type IfaceIdBndr = (IfLclName, IfaceType)
type IfaceTvBndr = (IfLclName, IfaceKind)
ifaceTvBndrName :: IfaceTvBndr -> IfLclName
ifaceTvBndrName (n,_) = n
type IfaceLamBndr = (IfaceBndr, IfaceOneShot)
data IfaceOneShot
= IfaceNoOneShot
| IfaceOneShot
type IfaceKind = IfaceType
data IfaceType
= IfaceFreeTyVar TyVar
| IfaceTyVar IfLclName
| IfaceLitTy IfaceTyLit
| IfaceAppTy IfaceType IfaceType
| IfaceFunTy IfaceType IfaceType
| IfaceDFunTy IfaceType IfaceType
| IfaceForAllTy IfaceForAllBndr IfaceType
| IfaceTyConApp IfaceTyCon IfaceTcArgs
| IfaceCastTy IfaceType IfaceCoercion
| IfaceCoercionTy IfaceCoercion
| IfaceTupleTy
TupleSort
IsPromoted
IfaceTcArgs
type IfacePredType = IfaceType
type IfaceContext = [IfacePredType]
data IfaceTyLit
= IfaceNumTyLit Integer
| IfaceStrTyLit FastString
deriving (Eq)
type IfaceTyConBinder = TyVarBndr IfaceTvBndr TyConBndrVis
type IfaceForAllBndr = TyVarBndr IfaceTvBndr ArgFlag
data IfaceTcArgs
= ITC_Nil
| ITC_Vis IfaceType IfaceTcArgs
| ITC_Invis IfaceKind IfaceTcArgs
instance Semi.Semigroup IfaceTcArgs where
ITC_Nil <> xs = xs
ITC_Vis ty rest <> xs = ITC_Vis ty (rest Semi.<> xs)
ITC_Invis ki rest <> xs = ITC_Invis ki (rest Semi.<> xs)
instance Monoid IfaceTcArgs where
mempty = ITC_Nil
mappend = (Semi.<>)
data IfaceTyCon = IfaceTyCon { ifaceTyConName :: IfExtName
, ifaceTyConInfo :: IfaceTyConInfo }
deriving (Eq)
data IsPromoted = IsNotPromoted | IsPromoted
deriving (Eq)
data IfaceTyConSort = IfaceNormalTyCon
| IfaceTupleTyCon !Arity !TupleSort
| IfaceSumTyCon !Arity
| IfaceEqualityTyCon
deriving (Eq)
data IfaceTyConInfo
= IfaceTyConInfo { ifaceTyConIsPromoted :: IsPromoted
, ifaceTyConSort :: IfaceTyConSort }
deriving (Eq)
data IfaceCoercion
= IfaceReflCo Role IfaceType
| IfaceFunCo Role IfaceCoercion IfaceCoercion
| IfaceTyConAppCo Role IfaceTyCon [IfaceCoercion]
| IfaceAppCo IfaceCoercion IfaceCoercion
| IfaceForAllCo IfaceTvBndr IfaceCoercion IfaceCoercion
| IfaceCoVarCo IfLclName
| IfaceAxiomInstCo IfExtName BranchIndex [IfaceCoercion]
| IfaceAxiomRuleCo IfLclName [IfaceCoercion]
| IfaceUnivCo IfaceUnivCoProv Role IfaceType IfaceType
| IfaceSymCo IfaceCoercion
| IfaceTransCo IfaceCoercion IfaceCoercion
| IfaceNthCo Int IfaceCoercion
| IfaceLRCo LeftOrRight IfaceCoercion
| IfaceInstCo IfaceCoercion IfaceCoercion
| IfaceCoherenceCo IfaceCoercion IfaceCoercion
| IfaceKindCo IfaceCoercion
| IfaceSubCo IfaceCoercion
| IfaceFreeCoVar CoVar
| IfaceHoleCo CoVar
data IfaceUnivCoProv
= IfaceUnsafeCoerceProv
| IfacePhantomProv IfaceCoercion
| IfaceProofIrrelProv IfaceCoercion
| IfacePluginProv String
ifaceTyConHasKey :: IfaceTyCon -> Unique -> Bool
ifaceTyConHasKey tc key = ifaceTyConName tc `hasKey` key
isIfaceLiftedTypeKind :: IfaceKind -> Bool
isIfaceLiftedTypeKind (IfaceTyConApp tc ITC_Nil)
= isLiftedTypeKindTyConName (ifaceTyConName tc)
isIfaceLiftedTypeKind (IfaceTyConApp tc
(ITC_Vis (IfaceTyConApp ptr_rep_lifted ITC_Nil) ITC_Nil))
= tc `ifaceTyConHasKey` tYPETyConKey
&& ptr_rep_lifted `ifaceTyConHasKey` liftedRepDataConKey
isIfaceLiftedTypeKind _ = False
splitIfaceSigmaTy :: IfaceType -> ([IfaceForAllBndr], [IfacePredType], IfaceType)
splitIfaceSigmaTy ty
= case (bndrs, theta) of
([], []) -> (bndrs, theta, tau)
_ -> let (bndrs', theta', tau') = splitIfaceSigmaTy tau
in (bndrs ++ bndrs', theta ++ theta', tau')
where
(bndrs, rho) = split_foralls ty
(theta, tau) = split_rho rho
split_foralls (IfaceForAllTy bndr ty)
= case split_foralls ty of { (bndrs, rho) -> (bndr:bndrs, rho) }
split_foralls rho = ([], rho)
split_rho (IfaceDFunTy ty1 ty2)
= case split_rho ty2 of { (ps, tau) -> (ty1:ps, tau) }
split_rho tau = ([], tau)
suppressIfaceInvisibles :: DynFlags -> [IfaceTyConBinder] -> [a] -> [a]
suppressIfaceInvisibles dflags tys xs
| gopt Opt_PrintExplicitKinds dflags = xs
| otherwise = suppress tys xs
where
suppress _ [] = []
suppress [] a = a
suppress (k:ks) (x:xs)
| isInvisibleTyConBinder k = suppress ks xs
| otherwise = x : suppress ks xs
stripIfaceInvisVars :: DynFlags -> [IfaceTyConBinder] -> [IfaceTyConBinder]
stripIfaceInvisVars dflags tyvars
| gopt Opt_PrintExplicitKinds dflags = tyvars
| otherwise = filterOut isInvisibleTyConBinder tyvars
ifForAllBndrTyVar :: IfaceForAllBndr -> IfaceTvBndr
ifForAllBndrTyVar = binderVar
ifForAllBndrName :: IfaceForAllBndr -> IfLclName
ifForAllBndrName fab = ifaceTvBndrName (ifForAllBndrTyVar fab)
ifTyConBinderTyVar :: IfaceTyConBinder -> IfaceTvBndr
ifTyConBinderTyVar = binderVar
ifTyConBinderName :: IfaceTyConBinder -> IfLclName
ifTyConBinderName tcb = ifaceTvBndrName (ifTyConBinderTyVar tcb)
ifTypeIsVarFree :: IfaceType -> Bool
ifTypeIsVarFree ty = go ty
where
go (IfaceTyVar {}) = False
go (IfaceFreeTyVar {}) = False
go (IfaceAppTy fun arg) = go fun && go arg
go (IfaceFunTy arg res) = go arg && go res
go (IfaceDFunTy arg res) = go arg && go res
go (IfaceForAllTy {}) = False
go (IfaceTyConApp _ args) = go_args args
go (IfaceTupleTy _ _ args) = go_args args
go (IfaceLitTy _) = True
go (IfaceCastTy {}) = False
go (IfaceCoercionTy {}) = False
go_args ITC_Nil = True
go_args (ITC_Vis arg args) = go arg && go_args args
go_args (ITC_Invis arg args) = go arg && go_args args
type IfaceTySubst = FastStringEnv IfaceType
mkIfaceTySubst :: [(IfLclName,IfaceType)] -> IfaceTySubst
mkIfaceTySubst eq_spec = mkFsEnv eq_spec
inDomIfaceTySubst :: IfaceTySubst -> IfaceTvBndr -> Bool
inDomIfaceTySubst subst (fs, _) = isJust (lookupFsEnv subst fs)
substIfaceType :: IfaceTySubst -> IfaceType -> IfaceType
substIfaceType env ty
= go ty
where
go (IfaceFreeTyVar tv) = IfaceFreeTyVar tv
go (IfaceTyVar tv) = substIfaceTyVar env tv
go (IfaceAppTy t1 t2) = IfaceAppTy (go t1) (go t2)
go (IfaceFunTy t1 t2) = IfaceFunTy (go t1) (go t2)
go (IfaceDFunTy t1 t2) = IfaceDFunTy (go t1) (go t2)
go ty@(IfaceLitTy {}) = ty
go (IfaceTyConApp tc tys) = IfaceTyConApp tc (substIfaceTcArgs env tys)
go (IfaceTupleTy s i tys) = IfaceTupleTy s i (substIfaceTcArgs env tys)
go (IfaceForAllTy {}) = pprPanic "substIfaceType" (ppr ty)
go (IfaceCastTy ty co) = IfaceCastTy (go ty) (go_co co)
go (IfaceCoercionTy co) = IfaceCoercionTy (go_co co)
go_co (IfaceReflCo r ty) = IfaceReflCo r (go ty)
go_co (IfaceFunCo r c1 c2) = IfaceFunCo r (go_co c1) (go_co c2)
go_co (IfaceTyConAppCo r tc cos) = IfaceTyConAppCo r tc (go_cos cos)
go_co (IfaceAppCo c1 c2) = IfaceAppCo (go_co c1) (go_co c2)
go_co (IfaceForAllCo {}) = pprPanic "substIfaceCoercion" (ppr ty)
go_co (IfaceFreeCoVar cv) = IfaceFreeCoVar cv
go_co (IfaceCoVarCo cv) = IfaceCoVarCo cv
go_co (IfaceHoleCo cv) = IfaceHoleCo cv
go_co (IfaceAxiomInstCo a i cos) = IfaceAxiomInstCo a i (go_cos cos)
go_co (IfaceUnivCo prov r t1 t2) = IfaceUnivCo (go_prov prov) r (go t1) (go t2)
go_co (IfaceSymCo co) = IfaceSymCo (go_co co)
go_co (IfaceTransCo co1 co2) = IfaceTransCo (go_co co1) (go_co co2)
go_co (IfaceNthCo n co) = IfaceNthCo n (go_co co)
go_co (IfaceLRCo lr co) = IfaceLRCo lr (go_co co)
go_co (IfaceInstCo c1 c2) = IfaceInstCo (go_co c1) (go_co c2)
go_co (IfaceCoherenceCo c1 c2) = IfaceCoherenceCo (go_co c1) (go_co c2)
go_co (IfaceKindCo co) = IfaceKindCo (go_co co)
go_co (IfaceSubCo co) = IfaceSubCo (go_co co)
go_co (IfaceAxiomRuleCo n cos) = IfaceAxiomRuleCo n (go_cos cos)
go_cos = map go_co
go_prov IfaceUnsafeCoerceProv = IfaceUnsafeCoerceProv
go_prov (IfacePhantomProv co) = IfacePhantomProv (go_co co)
go_prov (IfaceProofIrrelProv co) = IfaceProofIrrelProv (go_co co)
go_prov (IfacePluginProv str) = IfacePluginProv str
substIfaceTcArgs :: IfaceTySubst -> IfaceTcArgs -> IfaceTcArgs
substIfaceTcArgs env args
= go args
where
go ITC_Nil = ITC_Nil
go (ITC_Vis ty tys) = ITC_Vis (substIfaceType env ty) (go tys)
go (ITC_Invis ty tys) = ITC_Invis (substIfaceType env ty) (go tys)
substIfaceTyVar :: IfaceTySubst -> IfLclName -> IfaceType
substIfaceTyVar env tv
| Just ty <- lookupFsEnv env tv = ty
| otherwise = IfaceTyVar tv
stripInvisArgs :: DynFlags -> IfaceTcArgs -> IfaceTcArgs
stripInvisArgs dflags tys
| gopt Opt_PrintExplicitKinds dflags = tys
| otherwise = suppress_invis tys
where
suppress_invis c
= case c of
ITC_Nil -> ITC_Nil
ITC_Invis _ ts -> suppress_invis ts
ITC_Vis t ts -> ITC_Vis t $ suppress_invis ts
tcArgsIfaceTypes :: IfaceTcArgs -> [IfaceType]
tcArgsIfaceTypes ITC_Nil = []
tcArgsIfaceTypes (ITC_Invis t ts) = t : tcArgsIfaceTypes ts
tcArgsIfaceTypes (ITC_Vis t ts) = t : tcArgsIfaceTypes ts
ifaceVisTcArgsLength :: IfaceTcArgs -> Int
ifaceVisTcArgsLength = go 0
where
go !n ITC_Nil = n
go n (ITC_Vis _ rest) = go (n+1) rest
go n (ITC_Invis _ rest) = go n rest
if_print_coercions :: SDoc
-> SDoc
-> SDoc
if_print_coercions yes no
= sdocWithDynFlags $ \dflags ->
getPprStyle $ \style ->
if gopt Opt_PrintExplicitCoercions dflags
|| dumpStyle style || debugStyle style
then yes
else no
pprIfaceInfixApp :: PprPrec -> SDoc -> SDoc -> SDoc -> SDoc
pprIfaceInfixApp ctxt_prec pp_tc pp_ty1 pp_ty2
= maybeParen ctxt_prec opPrec $
sep [pp_ty1, pp_tc <+> pp_ty2]
pprIfacePrefixApp :: PprPrec -> SDoc -> [SDoc] -> SDoc
pprIfacePrefixApp ctxt_prec pp_fun pp_tys
| null pp_tys = pp_fun
| otherwise = maybeParen ctxt_prec appPrec $
hang pp_fun 2 (sep pp_tys)
instance Outputable IfaceBndr where
ppr (IfaceIdBndr bndr) = pprIfaceIdBndr bndr
ppr (IfaceTvBndr bndr) = char '@' <+> pprIfaceTvBndr False bndr
pprIfaceBndrs :: [IfaceBndr] -> SDoc
pprIfaceBndrs bs = sep (map ppr bs)
pprIfaceLamBndr :: IfaceLamBndr -> SDoc
pprIfaceLamBndr (b, IfaceNoOneShot) = ppr b
pprIfaceLamBndr (b, IfaceOneShot) = ppr b <> text "[OneShot]"
pprIfaceIdBndr :: IfaceIdBndr -> SDoc
pprIfaceIdBndr (name, ty) = parens (ppr name <+> dcolon <+> ppr ty)
pprIfaceTvBndr :: Bool -> IfaceTvBndr -> SDoc
pprIfaceTvBndr use_parens (tv, ki)
| isIfaceLiftedTypeKind ki = ppr tv
| otherwise = maybe_parens (ppr tv <+> dcolon <+> ppr ki)
where
maybe_parens | use_parens = parens
| otherwise = id
pprIfaceTyConBinders :: [IfaceTyConBinder] -> SDoc
pprIfaceTyConBinders = sep . map go
where
go tcb = pprIfaceTvBndr True (ifTyConBinderTyVar tcb)
instance Binary IfaceBndr where
put_ bh (IfaceIdBndr aa) = do
putByte bh 0
put_ bh aa
put_ bh (IfaceTvBndr ab) = do
putByte bh 1
put_ bh ab
get bh = do
h <- getByte bh
case h of
0 -> do aa <- get bh
return (IfaceIdBndr aa)
_ -> do ab <- get bh
return (IfaceTvBndr ab)
instance Binary IfaceOneShot where
put_ bh IfaceNoOneShot = do
putByte bh 0
put_ bh IfaceOneShot = do
putByte bh 1
get bh = do
h <- getByte bh
case h of
0 -> do return IfaceNoOneShot
_ -> do return IfaceOneShot
instance Outputable IfaceType where
ppr ty = pprIfaceType ty
pprIfaceType, pprParendIfaceType :: IfaceType -> SDoc
pprIfaceType = pprPrecIfaceType topPrec
pprParendIfaceType = pprPrecIfaceType appPrec
pprPrecIfaceType :: PprPrec -> IfaceType -> SDoc
pprPrecIfaceType prec ty = eliminateRuntimeRep (ppr_ty prec) ty
ppr_ty :: PprPrec -> IfaceType -> SDoc
ppr_ty _ (IfaceFreeTyVar tyvar) = ppr tyvar
ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar
ppr_ty ctxt_prec (IfaceTyConApp tc tys) = pprTyTcApp ctxt_prec tc tys
ppr_ty ctxt_prec (IfaceTupleTy i p tys) = pprTuple ctxt_prec i p tys
ppr_ty _ (IfaceLitTy n) = pprIfaceTyLit n
ppr_ty ctxt_prec (IfaceFunTy ty1 ty2)
=
maybeParen ctxt_prec funPrec $
sep [ppr_ty funPrec ty1, sep (ppr_fun_tail ty2)]
where
ppr_fun_tail (IfaceFunTy ty1 ty2)
= (arrow <+> ppr_ty funPrec ty1) : ppr_fun_tail ty2
ppr_fun_tail other_ty
= [arrow <+> pprIfaceType other_ty]
ppr_ty ctxt_prec (IfaceAppTy ty1 ty2)
= if_print_coercions
ppr_app_ty
ppr_app_ty_no_casts
where
ppr_app_ty =
maybeParen ctxt_prec appPrec
$ ppr_ty funPrec ty1 <+> ppr_ty appPrec ty2
ppr_app_ty_no_casts =
case split_app_tys ty1 (ITC_Vis ty2 ITC_Nil) of
(IfaceCastTy head _, args) -> ppr_ty ctxt_prec (mk_app_tys head args)
_ -> ppr_app_ty
split_app_tys :: IfaceType -> IfaceTcArgs -> (IfaceType, IfaceTcArgs)
split_app_tys (IfaceAppTy t1 t2) args = split_app_tys t1 (t2 `ITC_Vis` args)
split_app_tys head args = (head, args)
mk_app_tys :: IfaceType -> IfaceTcArgs -> IfaceType
mk_app_tys (IfaceTyConApp tc tys1) tys2 =
IfaceTyConApp tc (tys1 `mappend` tys2)
mk_app_tys t1 tys2 =
foldl' IfaceAppTy t1 (tcArgsIfaceTypes tys2)
ppr_ty ctxt_prec (IfaceCastTy ty co)
= if_print_coercions
(parens (ppr_ty topPrec ty <+> text "|>" <+> ppr co))
(ppr_ty ctxt_prec ty)
ppr_ty ctxt_prec (IfaceCoercionTy co)
= if_print_coercions
(ppr_co ctxt_prec co)
(text "<>")
ppr_ty ctxt_prec ty
= maybeParen ctxt_prec funPrec (pprIfaceSigmaType ShowForAllMust ty)
defaultRuntimeRepVars :: PprStyle -> IfaceType -> IfaceType
defaultRuntimeRepVars sty = go emptyFsEnv
where
go :: FastStringEnv () -> IfaceType -> IfaceType
go subs (IfaceForAllTy bndr ty)
| isRuntimeRep var_kind
, isInvisibleArgFlag (binderArgFlag bndr)
= let subs' = extendFsEnv subs var ()
in go subs' ty
| otherwise
= IfaceForAllTy (TvBndr (var, go subs var_kind) (binderArgFlag bndr))
(go subs ty)
where
var :: IfLclName
(var, var_kind) = binderVar bndr
go subs ty@(IfaceTyVar tv)
| tv `elemFsEnv` subs
= IfaceTyConApp liftedRep ITC_Nil
| otherwise
= ty
go _ ty@(IfaceFreeTyVar tv)
| userStyle sty && TyCoRep.isRuntimeRepTy (tyVarKind tv)
= IfaceTyConApp liftedRep ITC_Nil
| otherwise
= ty
go subs (IfaceTyConApp tc tc_args)
= IfaceTyConApp tc (go_args subs tc_args)
go subs (IfaceTupleTy sort is_prom tc_args)
= IfaceTupleTy sort is_prom (go_args subs tc_args)
go subs (IfaceFunTy arg res)
= IfaceFunTy (go subs arg) (go subs res)
go subs (IfaceAppTy x y)
= IfaceAppTy (go subs x) (go subs y)
go subs (IfaceDFunTy x y)
= IfaceDFunTy (go subs x) (go subs y)
go subs (IfaceCastTy x co)
= IfaceCastTy (go subs x) co
go _ ty@(IfaceLitTy {}) = ty
go _ ty@(IfaceCoercionTy {}) = ty
go_args :: FastStringEnv () -> IfaceTcArgs -> IfaceTcArgs
go_args _ ITC_Nil = ITC_Nil
go_args subs (ITC_Vis ty args) = ITC_Vis (go subs ty) (go_args subs args)
go_args subs (ITC_Invis ty args) = ITC_Invis (go subs ty) (go_args subs args)
liftedRep :: IfaceTyCon
liftedRep =
IfaceTyCon dc_name (IfaceTyConInfo IsPromoted IfaceNormalTyCon)
where dc_name = getName liftedRepDataConTyCon
isRuntimeRep :: IfaceType -> Bool
isRuntimeRep (IfaceTyConApp tc _) =
tc `ifaceTyConHasKey` runtimeRepTyConKey
isRuntimeRep _ = False
eliminateRuntimeRep :: (IfaceType -> SDoc) -> IfaceType -> SDoc
eliminateRuntimeRep f ty = sdocWithDynFlags $ \dflags ->
if gopt Opt_PrintExplicitRuntimeReps dflags
then f ty
else getPprStyle $ \sty -> f (defaultRuntimeRepVars sty ty)
instance Outputable IfaceTcArgs where
ppr tca = pprIfaceTcArgs tca
pprIfaceTcArgs, pprParendIfaceTcArgs :: IfaceTcArgs -> SDoc
pprIfaceTcArgs = ppr_tc_args topPrec
pprParendIfaceTcArgs = ppr_tc_args appPrec
ppr_tc_args :: PprPrec -> IfaceTcArgs -> SDoc
ppr_tc_args ctx_prec args
= let ppr_rest = ppr_tc_args ctx_prec
pprTys t ts = ppr_ty ctx_prec t <+> ppr_rest ts
in case args of
ITC_Nil -> empty
ITC_Vis t ts -> pprTys t ts
ITC_Invis t ts -> sdocWithDynFlags $ \dflags ->
if gopt Opt_PrintExplicitKinds dflags
then pprTys t ts
else ppr_rest ts
pprIfaceForAllPart :: [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc
pprIfaceForAllPart tvs ctxt sdoc
= ppr_iface_forall_part ShowForAllWhen tvs ctxt sdoc
pprIfaceForAllPartMust :: [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc
pprIfaceForAllPartMust tvs ctxt sdoc
= ppr_iface_forall_part ShowForAllMust tvs ctxt sdoc
pprIfaceForAllCoPart :: [(IfLclName, IfaceCoercion)] -> SDoc -> SDoc
pprIfaceForAllCoPart tvs sdoc
= sep [ pprIfaceForAllCo tvs, sdoc ]
ppr_iface_forall_part :: ShowForAllFlag
-> [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc
ppr_iface_forall_part show_forall tvs ctxt sdoc
= sep [ case show_forall of
ShowForAllMust -> pprIfaceForAll tvs
ShowForAllWhen -> pprUserIfaceForAll tvs
, pprIfaceContextArr ctxt
, sdoc]
pprIfaceForAll :: [IfaceForAllBndr] -> SDoc
pprIfaceForAll [] = empty
pprIfaceForAll bndrs@(TvBndr _ vis : _)
= add_separator (forAllLit <+> doc) <+> pprIfaceForAll bndrs'
where
(bndrs', doc) = ppr_itv_bndrs bndrs vis
add_separator stuff = case vis of
Required -> stuff <+> arrow
_inv -> stuff <> dot
ppr_itv_bndrs :: [IfaceForAllBndr]
-> ArgFlag
-> ([IfaceForAllBndr], SDoc)
ppr_itv_bndrs all_bndrs@(bndr@(TvBndr _ vis) : bndrs) vis1
| vis `sameVis` vis1 = let (bndrs', doc) = ppr_itv_bndrs bndrs vis1 in
(bndrs', pprIfaceForAllBndr bndr <+> doc)
| otherwise = (all_bndrs, empty)
ppr_itv_bndrs [] _ = ([], empty)
pprIfaceForAllCo :: [(IfLclName, IfaceCoercion)] -> SDoc
pprIfaceForAllCo [] = empty
pprIfaceForAllCo tvs = text "forall" <+> pprIfaceForAllCoBndrs tvs <> dot
pprIfaceForAllCoBndrs :: [(IfLclName, IfaceCoercion)] -> SDoc
pprIfaceForAllCoBndrs bndrs = hsep $ map pprIfaceForAllCoBndr bndrs
pprIfaceForAllBndr :: IfaceForAllBndr -> SDoc
pprIfaceForAllBndr (TvBndr tv Inferred) = sdocWithDynFlags $ \dflags ->
if gopt Opt_PrintExplicitForalls dflags
then braces $ pprIfaceTvBndr False tv
else pprIfaceTvBndr True tv
pprIfaceForAllBndr (TvBndr tv _) = pprIfaceTvBndr True tv
pprIfaceForAllCoBndr :: (IfLclName, IfaceCoercion) -> SDoc
pprIfaceForAllCoBndr (tv, kind_co)
= parens (ppr tv <+> dcolon <+> pprIfaceCoercion kind_co)
data ShowForAllFlag = ShowForAllMust | ShowForAllWhen
pprIfaceSigmaType :: ShowForAllFlag -> IfaceType -> SDoc
pprIfaceSigmaType show_forall ty
= eliminateRuntimeRep ppr_fn ty
where
ppr_fn iface_ty =
let (tvs, theta, tau) = splitIfaceSigmaTy iface_ty
in ppr_iface_forall_part show_forall tvs theta (ppr tau)
pprUserIfaceForAll :: [IfaceForAllBndr] -> SDoc
pprUserIfaceForAll tvs
= sdocWithDynFlags $ \dflags ->
ppWhen (any tv_has_kind_var tvs
|| any tv_is_required tvs
|| gopt Opt_PrintExplicitForalls dflags) $
pprIfaceForAll tvs
where
tv_has_kind_var (TvBndr (_,kind) _) = not (ifTypeIsVarFree kind)
tv_is_required = isVisibleArgFlag . binderArgFlag
pprSpaceIfPromotedTyCon :: IfaceType -> SDoc -> SDoc
pprSpaceIfPromotedTyCon (IfaceTyConApp tyCon _)
= case ifaceTyConIsPromoted (ifaceTyConInfo tyCon) of
IsPromoted -> (space <>)
_ -> id
pprSpaceIfPromotedTyCon _
= id
pprIfaceTyList :: PprPrec -> IfaceType -> IfaceType -> SDoc
pprIfaceTyList ctxt_prec ty1 ty2
= case gather ty2 of
(arg_tys, Nothing)
-> char '\'' <> brackets (pprSpaceIfPromotedTyCon ty1 (fsep
(punctuate comma (map (ppr_ty topPrec) (ty1:arg_tys)))))
(arg_tys, Just tl)
-> maybeParen ctxt_prec funPrec $ hang (ppr_ty funPrec ty1)
2 (fsep [ colon <+> ppr_ty funPrec ty | ty <- arg_tys ++ [tl]])
where
gather :: IfaceType -> ([IfaceType], Maybe IfaceType)
gather (IfaceTyConApp tc tys)
| tc `ifaceTyConHasKey` consDataConKey
, (ITC_Invis _ (ITC_Vis ty1 (ITC_Vis ty2 ITC_Nil))) <- tys
, (args, tl) <- gather ty2
= (ty1:args, tl)
| tc `ifaceTyConHasKey` nilDataConKey
= ([], Nothing)
gather ty = ([], Just ty)
pprIfaceTypeApp :: PprPrec -> IfaceTyCon -> IfaceTcArgs -> SDoc
pprIfaceTypeApp prec tc args = pprTyTcApp prec tc args
pprTyTcApp :: PprPrec -> IfaceTyCon -> IfaceTcArgs -> SDoc
pprTyTcApp ctxt_prec tc tys =
sdocWithDynFlags $ \dflags ->
getPprStyle $ \style ->
pprTyTcApp' ctxt_prec tc tys dflags style
pprTyTcApp' :: PprPrec -> IfaceTyCon -> IfaceTcArgs
-> DynFlags -> PprStyle -> SDoc
pprTyTcApp' ctxt_prec tc tys dflags style
| ifaceTyConName tc `hasKey` ipClassKey
, ITC_Vis (IfaceLitTy (IfaceStrTyLit n)) (ITC_Vis ty ITC_Nil) <- tys
= maybeParen ctxt_prec funPrec
$ char '?' <> ftext n <> text "::" <> ppr_ty topPrec ty
| IfaceTupleTyCon arity sort <- ifaceTyConSort info
, not (debugStyle style)
, arity == ifaceVisTcArgsLength tys
= pprTuple ctxt_prec sort (ifaceTyConIsPromoted info) tys
| IfaceSumTyCon arity <- ifaceTyConSort info
= pprSum arity (ifaceTyConIsPromoted info) tys
| tc `ifaceTyConHasKey` consDataConKey
, not (gopt Opt_PrintExplicitKinds dflags)
, ITC_Invis _ (ITC_Vis ty1 (ITC_Vis ty2 ITC_Nil)) <- tys
= pprIfaceTyList ctxt_prec ty1 ty2
| tc `ifaceTyConHasKey` tYPETyConKey
, ITC_Vis (IfaceTyConApp rep ITC_Nil) ITC_Nil <- tys
, rep `ifaceTyConHasKey` liftedRepDataConKey
= kindType
| otherwise
= getPprDebug $ \dbg ->
if | not dbg && tc `ifaceTyConHasKey` errorMessageTypeErrorFamKey
-> text "(TypeError ...)"
| Just doc <- ppr_equality ctxt_prec tc (tcArgsIfaceTypes tys)
-> doc
| otherwise
-> ppr_iface_tc_app ppr_ty ctxt_prec tc tys_wo_kinds
where
info = ifaceTyConInfo tc
tys_wo_kinds = tcArgsIfaceTypes $ stripInvisArgs dflags tys
ppr_equality :: PprPrec -> IfaceTyCon -> [IfaceType] -> Maybe SDoc
ppr_equality ctxt_prec tc args
| hetero_eq_tc
, [k1, k2, t1, t2] <- args
= Just $ print_equality (k1, k2, t1, t2)
| hom_eq_tc
, [k, t1, t2] <- args
= Just $ print_equality (k, k, t1, t2)
| otherwise
= Nothing
where
homogeneous = tc_name `hasKey` eqTyConKey
|| hetero_tc_used_homogeneously
where
hetero_tc_used_homogeneously
= case ifaceTyConSort $ ifaceTyConInfo tc of
IfaceEqualityTyCon -> True
_other -> False
tc_name = ifaceTyConName tc
pp = ppr_ty
hom_eq_tc = tc_name `hasKey` eqTyConKey
hetero_eq_tc = tc_name `hasKey` eqPrimTyConKey
|| tc_name `hasKey` eqReprPrimTyConKey
|| tc_name `hasKey` heqTyConKey
nominal_eq_tc = tc_name `hasKey` heqTyConKey
|| tc_name `hasKey` eqPrimTyConKey
print_equality args =
sdocWithDynFlags $ \dflags ->
getPprStyle $ \style ->
print_equality' args style dflags
print_equality' (ki1, ki2, ty1, ty2) style dflags
|
print_eqs
= ppr_infix_eq (ppr tc)
|
nominal_eq_tc, homogeneous
= ppr_infix_eq (text "~")
|
not homogeneous
= ppr_infix_eq (ppr heqTyCon)
|
tc_name `hasKey` eqReprPrimTyConKey, homogeneous
= let ki | print_kinds = [pp appPrec ki1]
| otherwise = []
in pprIfacePrefixApp ctxt_prec (ppr coercibleTyCon)
(ki ++ [pp appPrec ty1, pp appPrec ty2])
| otherwise
= ppr_infix_eq (ppr tc)
where
ppr_infix_eq :: SDoc -> SDoc
ppr_infix_eq eq_op = pprIfaceInfixApp ctxt_prec eq_op
(pp_ty_ki ty1 ki1) (pp_ty_ki ty2 ki2)
where
pp_ty_ki ty ki
| print_kinds
= parens (pp topPrec ty <+> dcolon <+> pp opPrec ki)
| otherwise
= pp opPrec ty
print_kinds = gopt Opt_PrintExplicitKinds dflags
print_eqs = gopt Opt_PrintEqualityRelations dflags ||
dumpStyle style || debugStyle style
pprIfaceCoTcApp :: PprPrec -> IfaceTyCon -> [IfaceCoercion] -> SDoc
pprIfaceCoTcApp ctxt_prec tc tys = ppr_iface_tc_app ppr_co ctxt_prec tc tys
ppr_iface_tc_app :: (PprPrec -> a -> SDoc) -> PprPrec -> IfaceTyCon -> [a] -> SDoc
ppr_iface_tc_app pp _ tc [ty]
| tc `ifaceTyConHasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp topPrec ty)
ppr_iface_tc_app pp ctxt_prec tc tys
| tc `ifaceTyConHasKey` liftedTypeKindTyConKey
= kindType
| not (isSymOcc (nameOccName (ifaceTyConName tc)))
= pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp appPrec) tys)
| [ty1,ty2] <- tys
= pprIfaceInfixApp ctxt_prec (ppr tc)
(pp opPrec ty1) (pp opPrec ty2)
| otherwise
= pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp appPrec) tys)
pprSum :: Arity -> IsPromoted -> IfaceTcArgs -> SDoc
pprSum _arity is_promoted args
=
let tys = tcArgsIfaceTypes args
args' = drop (length tys `div` 2) tys
in pprPromotionQuoteI is_promoted
<> sumParens (pprWithBars (ppr_ty topPrec) args')
pprTuple :: PprPrec -> TupleSort -> IsPromoted -> IfaceTcArgs -> SDoc
pprTuple ctxt_prec ConstraintTuple IsNotPromoted ITC_Nil
= maybeParen ctxt_prec appPrec $
text "() :: Constraint"
pprTuple _ sort IsPromoted args
= let tys = tcArgsIfaceTypes args
args' = drop (length tys `div` 2) tys
spaceIfPromoted = case args' of
arg0:_ -> pprSpaceIfPromotedTyCon arg0
_ -> id
in pprPromotionQuoteI IsPromoted <>
tupleParens sort (spaceIfPromoted (pprWithCommas pprIfaceType args'))
pprTuple _ sort promoted args
=
let tys = tcArgsIfaceTypes args
args' = case sort of
UnboxedTuple -> drop (length tys `div` 2) tys
_ -> tys
in
pprPromotionQuoteI promoted <>
tupleParens sort (pprWithCommas pprIfaceType args')
pprIfaceTyLit :: IfaceTyLit -> SDoc
pprIfaceTyLit (IfaceNumTyLit n) = integer n
pprIfaceTyLit (IfaceStrTyLit n) = text (show n)
pprIfaceCoercion, pprParendIfaceCoercion :: IfaceCoercion -> SDoc
pprIfaceCoercion = ppr_co topPrec
pprParendIfaceCoercion = ppr_co appPrec
ppr_co :: PprPrec -> IfaceCoercion -> SDoc
ppr_co _ (IfaceReflCo r ty) = angleBrackets (ppr ty) <> ppr_role r
ppr_co ctxt_prec (IfaceFunCo r co1 co2)
= maybeParen ctxt_prec funPrec $
sep (ppr_co funPrec co1 : ppr_fun_tail co2)
where
ppr_fun_tail (IfaceFunCo r co1 co2)
= (arrow <> ppr_role r <+> ppr_co funPrec co1) : ppr_fun_tail co2
ppr_fun_tail other_co
= [arrow <> ppr_role r <+> pprIfaceCoercion other_co]
ppr_co _ (IfaceTyConAppCo r tc cos)
= parens (pprIfaceCoTcApp topPrec tc cos) <> ppr_role r
ppr_co ctxt_prec (IfaceAppCo co1 co2)
= maybeParen ctxt_prec appPrec $
ppr_co funPrec co1 <+> pprParendIfaceCoercion co2
ppr_co ctxt_prec co@(IfaceForAllCo {})
= maybeParen ctxt_prec funPrec $
pprIfaceForAllCoPart tvs (pprIfaceCoercion inner_co)
where
(tvs, inner_co) = split_co co
split_co (IfaceForAllCo (name, _) kind_co co')
= let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'')
split_co co' = ([], co')
ppr_co _ (IfaceFreeCoVar covar) = ppr covar
ppr_co _ (IfaceCoVarCo covar) = ppr covar
ppr_co _ (IfaceHoleCo covar) = braces (ppr covar)
ppr_co ctxt_prec (IfaceUnivCo IfaceUnsafeCoerceProv r ty1 ty2)
= maybeParen ctxt_prec appPrec $
text "UnsafeCo" <+> ppr r <+>
pprParendIfaceType ty1 <+> pprParendIfaceType ty2
ppr_co _ (IfaceUnivCo prov role ty1 ty2)
= text "Univ" <> (parens $
sep [ ppr role <+> pprIfaceUnivCoProv prov
, dcolon <+> ppr ty1 <> comma <+> ppr ty2 ])
ppr_co ctxt_prec (IfaceInstCo co ty)
= maybeParen ctxt_prec appPrec $
text "Inst" <+> pprParendIfaceCoercion co
<+> pprParendIfaceCoercion ty
ppr_co ctxt_prec (IfaceAxiomRuleCo tc cos)
= maybeParen ctxt_prec appPrec $ ppr tc <+> parens (interpp'SP cos)
ppr_co ctxt_prec (IfaceAxiomInstCo n i cos)
= ppr_special_co ctxt_prec (ppr n <> brackets (ppr i)) cos
ppr_co ctxt_prec (IfaceSymCo co)
= ppr_special_co ctxt_prec (text "Sym") [co]
ppr_co ctxt_prec (IfaceTransCo co1 co2)
= maybeParen ctxt_prec opPrec $
ppr_co opPrec co1 <+> semi <+> ppr_co opPrec co2
ppr_co ctxt_prec (IfaceNthCo d co)
= ppr_special_co ctxt_prec (text "Nth:" <> int d) [co]
ppr_co ctxt_prec (IfaceLRCo lr co)
= ppr_special_co ctxt_prec (ppr lr) [co]
ppr_co ctxt_prec (IfaceSubCo co)
= ppr_special_co ctxt_prec (text "Sub") [co]
ppr_co ctxt_prec (IfaceCoherenceCo co1 co2)
= ppr_special_co ctxt_prec (text "Coh") [co1,co2]
ppr_co ctxt_prec (IfaceKindCo co)
= ppr_special_co ctxt_prec (text "Kind") [co]
ppr_special_co :: PprPrec -> SDoc -> [IfaceCoercion] -> SDoc
ppr_special_co ctxt_prec doc cos
= maybeParen ctxt_prec appPrec
(sep [doc, nest 4 (sep (map pprParendIfaceCoercion cos))])
ppr_role :: Role -> SDoc
ppr_role r = underscore <> pp_role
where pp_role = case r of
Nominal -> char 'N'
Representational -> char 'R'
Phantom -> char 'P'
pprIfaceUnivCoProv :: IfaceUnivCoProv -> SDoc
pprIfaceUnivCoProv IfaceUnsafeCoerceProv
= text "unsafe"
pprIfaceUnivCoProv (IfacePhantomProv co)
= text "phantom" <+> pprParendIfaceCoercion co
pprIfaceUnivCoProv (IfaceProofIrrelProv co)
= text "irrel" <+> pprParendIfaceCoercion co
pprIfaceUnivCoProv (IfacePluginProv s)
= text "plugin" <+> doubleQuotes (text s)
instance Outputable IfaceTyCon where
ppr tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc)
pprPromotionQuote :: IfaceTyCon -> SDoc
pprPromotionQuote tc =
pprPromotionQuoteI $ ifaceTyConIsPromoted $ ifaceTyConInfo tc
pprPromotionQuoteI :: IsPromoted -> SDoc
pprPromotionQuoteI IsNotPromoted = empty
pprPromotionQuoteI IsPromoted = char '\''
instance Outputable IfaceCoercion where
ppr = pprIfaceCoercion
instance Binary IfaceTyCon where
put_ bh (IfaceTyCon n i) = put_ bh n >> put_ bh i
get bh = do n <- get bh
i <- get bh
return (IfaceTyCon n i)
instance Binary IsPromoted where
put_ bh IsNotPromoted = putByte bh 0
put_ bh IsPromoted = putByte bh 1
get bh = do
n <- getByte bh
case n of
0 -> return IsNotPromoted
1 -> return IsPromoted
_ -> fail "Binary(IsPromoted): fail)"
instance Binary IfaceTyConSort where
put_ bh IfaceNormalTyCon = putByte bh 0
put_ bh (IfaceTupleTyCon arity sort) = putByte bh 1 >> put_ bh arity >> put_ bh sort
put_ bh (IfaceSumTyCon arity) = putByte bh 2 >> put_ bh arity
put_ bh IfaceEqualityTyCon = putByte bh 3
get bh = do
n <- getByte bh
case n of
0 -> return IfaceNormalTyCon
1 -> IfaceTupleTyCon <$> get bh <*> get bh
2 -> IfaceSumTyCon <$> get bh
_ -> return IfaceEqualityTyCon
instance Binary IfaceTyConInfo where
put_ bh (IfaceTyConInfo i s) = put_ bh i >> put_ bh s
get bh = IfaceTyConInfo <$> get bh <*> get bh
instance Outputable IfaceTyLit where
ppr = pprIfaceTyLit
instance Binary IfaceTyLit where
put_ bh (IfaceNumTyLit n) = putByte bh 1 >> put_ bh n
put_ bh (IfaceStrTyLit n) = putByte bh 2 >> put_ bh n
get bh =
do tag <- getByte bh
case tag of
1 -> do { n <- get bh
; return (IfaceNumTyLit n) }
2 -> do { n <- get bh
; return (IfaceStrTyLit n) }
_ -> panic ("get IfaceTyLit " ++ show tag)
instance Binary IfaceTcArgs where
put_ bh tk =
case tk of
ITC_Vis t ts -> putByte bh 0 >> put_ bh t >> put_ bh ts
ITC_Invis t ts -> putByte bh 1 >> put_ bh t >> put_ bh ts
ITC_Nil -> putByte bh 2
get bh =
do c <- getByte bh
case c of
0 -> do
t <- get bh
ts <- get bh
return $! ITC_Vis t ts
1 -> do
t <- get bh
ts <- get bh
return $! ITC_Invis t ts
2 -> return ITC_Nil
_ -> panic ("get IfaceTcArgs " ++ show c)
pprIfaceContextArr :: [IfacePredType] -> SDoc
pprIfaceContextArr [] = empty
pprIfaceContextArr [pred] = ppr_ty funPrec pred <+> darrow
pprIfaceContextArr preds = ppr_parend_preds preds <+> darrow
pprIfaceContext :: PprPrec -> [IfacePredType] -> SDoc
pprIfaceContext _ [] = text "()"
pprIfaceContext prec [pred] = ppr_ty prec pred
pprIfaceContext _ preds = ppr_parend_preds preds
ppr_parend_preds :: [IfacePredType] -> SDoc
ppr_parend_preds preds = parens (fsep (punctuate comma (map ppr preds)))
instance Binary IfaceType where
put_ _ (IfaceFreeTyVar tv)
= pprPanic "Can't serialise IfaceFreeTyVar" (ppr tv)
put_ bh (IfaceForAllTy aa ab) = do
putByte bh 0
put_ bh aa
put_ bh ab
put_ bh (IfaceTyVar ad) = do
putByte bh 1
put_ bh ad
put_ bh (IfaceAppTy ae af) = do
putByte bh 2
put_ bh ae
put_ bh af
put_ bh (IfaceFunTy ag ah) = do
putByte bh 3
put_ bh ag
put_ bh ah
put_ bh (IfaceDFunTy ag ah) = do
putByte bh 4
put_ bh ag
put_ bh ah
put_ bh (IfaceTyConApp tc tys)
= do { putByte bh 5; put_ bh tc; put_ bh tys }
put_ bh (IfaceCastTy a b)
= do { putByte bh 6; put_ bh a; put_ bh b }
put_ bh (IfaceCoercionTy a)
= do { putByte bh 7; put_ bh a }
put_ bh (IfaceTupleTy s i tys)
= do { putByte bh 8; put_ bh s; put_ bh i; put_ bh tys }
put_ bh (IfaceLitTy n)
= do { putByte bh 9; put_ bh n }
get bh = do
h <- getByte bh
case h of
0 -> do aa <- get bh
ab <- get bh
return (IfaceForAllTy aa ab)
1 -> do ad <- get bh
return (IfaceTyVar ad)
2 -> do ae <- get bh
af <- get bh
return (IfaceAppTy ae af)
3 -> do ag <- get bh
ah <- get bh
return (IfaceFunTy ag ah)
4 -> do ag <- get bh
ah <- get bh
return (IfaceDFunTy ag ah)
5 -> do { tc <- get bh; tys <- get bh
; return (IfaceTyConApp tc tys) }
6 -> do { a <- get bh; b <- get bh
; return (IfaceCastTy a b) }
7 -> do { a <- get bh
; return (IfaceCoercionTy a) }
8 -> do { s <- get bh; i <- get bh; tys <- get bh
; return (IfaceTupleTy s i tys) }
_ -> do n <- get bh
return (IfaceLitTy n)
instance Binary IfaceCoercion where
put_ bh (IfaceReflCo a b) = do
putByte bh 1
put_ bh a
put_ bh b
put_ bh (IfaceFunCo a b c) = do
putByte bh 2
put_ bh a
put_ bh b
put_ bh c
put_ bh (IfaceTyConAppCo a b c) = do
putByte bh 3
put_ bh a
put_ bh b
put_ bh c
put_ bh (IfaceAppCo a b) = do
putByte bh 4
put_ bh a
put_ bh b
put_ bh (IfaceForAllCo a b c) = do
putByte bh 5
put_ bh a
put_ bh b
put_ bh c
put_ bh (IfaceCoVarCo a) = do
putByte bh 6
put_ bh a
put_ bh (IfaceAxiomInstCo a b c) = do
putByte bh 7
put_ bh a
put_ bh b
put_ bh c
put_ bh (IfaceUnivCo a b c d) = do
putByte bh 8
put_ bh a
put_ bh b
put_ bh c
put_ bh d
put_ bh (IfaceSymCo a) = do
putByte bh 9
put_ bh a
put_ bh (IfaceTransCo a b) = do
putByte bh 10
put_ bh a
put_ bh b
put_ bh (IfaceNthCo a b) = do
putByte bh 11
put_ bh a
put_ bh b
put_ bh (IfaceLRCo a b) = do
putByte bh 12
put_ bh a
put_ bh b
put_ bh (IfaceInstCo a b) = do
putByte bh 13
put_ bh a
put_ bh b
put_ bh (IfaceCoherenceCo a b) = do
putByte bh 14
put_ bh a
put_ bh b
put_ bh (IfaceKindCo a) = do
putByte bh 15
put_ bh a
put_ bh (IfaceSubCo a) = do
putByte bh 16
put_ bh a
put_ bh (IfaceAxiomRuleCo a b) = do
putByte bh 17
put_ bh a
put_ bh b
put_ _ (IfaceFreeCoVar cv)
= pprPanic "Can't serialise IfaceFreeCoVar" (ppr cv)
put_ _ (IfaceHoleCo cv)
= pprPanic "Can't serialise IfaceHoleCo" (ppr cv)
get bh = do
tag <- getByte bh
case tag of
1 -> do a <- get bh
b <- get bh
return $ IfaceReflCo a b
2 -> do a <- get bh
b <- get bh
c <- get bh
return $ IfaceFunCo a b c
3 -> do a <- get bh
b <- get bh
c <- get bh
return $ IfaceTyConAppCo a b c
4 -> do a <- get bh
b <- get bh
return $ IfaceAppCo a b
5 -> do a <- get bh
b <- get bh
c <- get bh
return $ IfaceForAllCo a b c
6 -> do a <- get bh
return $ IfaceCoVarCo a
7 -> do a <- get bh
b <- get bh
c <- get bh
return $ IfaceAxiomInstCo a b c
8 -> do a <- get bh
b <- get bh
c <- get bh
d <- get bh
return $ IfaceUnivCo a b c d
9 -> do a <- get bh
return $ IfaceSymCo a
10-> do a <- get bh
b <- get bh
return $ IfaceTransCo a b
11-> do a <- get bh
b <- get bh
return $ IfaceNthCo a b
12-> do a <- get bh
b <- get bh
return $ IfaceLRCo a b
13-> do a <- get bh
b <- get bh
return $ IfaceInstCo a b
14-> do a <- get bh
b <- get bh
return $ IfaceCoherenceCo a b
15-> do a <- get bh
return $ IfaceKindCo a
16-> do a <- get bh
return $ IfaceSubCo a
17-> do a <- get bh
b <- get bh
return $ IfaceAxiomRuleCo a b
_ -> panic ("get IfaceCoercion " ++ show tag)
instance Binary IfaceUnivCoProv where
put_ bh IfaceUnsafeCoerceProv = putByte bh 1
put_ bh (IfacePhantomProv a) = do
putByte bh 2
put_ bh a
put_ bh (IfaceProofIrrelProv a) = do
putByte bh 3
put_ bh a
put_ bh (IfacePluginProv a) = do
putByte bh 4
put_ bh a
get bh = do
tag <- getByte bh
case tag of
1 -> return $ IfaceUnsafeCoerceProv
2 -> do a <- get bh
return $ IfacePhantomProv a
3 -> do a <- get bh
return $ IfaceProofIrrelProv a
4 -> do a <- get bh
return $ IfacePluginProv a
_ -> panic ("get IfaceUnivCoProv " ++ show tag)
instance Binary (DefMethSpec IfaceType) where
put_ bh VanillaDM = putByte bh 0
put_ bh (GenericDM t) = putByte bh 1 >> put_ bh t
get bh = do
h <- getByte bh
case h of
0 -> return VanillaDM
_ -> do { t <- get bh; return (GenericDM t) }