module IfaceType (
IfExtName, IfLclName,
IfaceType(..), IfacePredType, IfaceKind, IfaceCoercion(..),
IfaceMCoercion(..),
IfaceUnivCoProv(..),
IfaceTyCon(..), IfaceTyConInfo(..), IfaceTyConSort(..),
IfaceTyLit(..), IfaceAppArgs(..),
IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr,
IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder,
IfaceForAllBndr, ArgFlag(..), ShowForAllFlag(..),
mkIfaceForAllTvBndr,
ifForAllBndrVar, ifForAllBndrName, ifaceBndrName,
ifTyConBinderVar, ifTyConBinderName,
isIfaceLiftedTypeKind,
appArgsIfaceTypes, appArgsIfaceTypesArgFlags,
pprIfaceType, pprParendIfaceType, pprPrecIfaceType,
pprIfaceContext, pprIfaceContextArr,
pprIfaceIdBndr, pprIfaceLamBndr, pprIfaceTvBndr, pprIfaceTyConBinders,
pprIfaceBndrs, pprIfaceAppArgs, pprParendIfaceAppArgs,
pprIfaceForAllPart, pprIfaceForAllPartMust, pprIfaceForAll,
pprIfaceSigmaType, pprIfaceTyLit,
pprIfaceCoercion, pprParendIfaceCoercion,
splitIfaceSigmaTy, pprIfaceTypeApp, pprUserIfaceForAll,
pprIfaceCoTcApp, pprTyTcApp, pprIfacePrefixApp,
suppressIfaceInvisibles,
stripIfaceInvisVars,
stripInvisArgs,
mkIfaceTySubst, substIfaceTyVar, substIfaceAppArgs, 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 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
ifaceIdBndrName :: IfaceIdBndr -> IfLclName
ifaceIdBndrName (n,_) = n
ifaceBndrName :: IfaceBndr -> IfLclName
ifaceBndrName (IfaceTvBndr bndr) = ifaceTvBndrName bndr
ifaceBndrName (IfaceIdBndr bndr) = ifaceIdBndrName bndr
type IfaceLamBndr = (IfaceBndr, IfaceOneShot)
data IfaceOneShot
= IfaceNoOneShot
| IfaceOneShot
type IfaceKind = IfaceType
data IfaceType
= IfaceFreeTyVar TyVar
| IfaceTyVar IfLclName
| IfaceLitTy IfaceTyLit
| IfaceAppTy IfaceType IfaceAppArgs
| IfaceFunTy IfaceType IfaceType
| IfaceDFunTy IfaceType IfaceType
| IfaceForAllTy IfaceForAllBndr IfaceType
| IfaceTyConApp IfaceTyCon IfaceAppArgs
| IfaceCastTy IfaceType IfaceCoercion
| IfaceCoercionTy IfaceCoercion
| IfaceTupleTy
TupleSort
PromotionFlag
IfaceAppArgs
type IfacePredType = IfaceType
type IfaceContext = [IfacePredType]
data IfaceTyLit
= IfaceNumTyLit Integer
| IfaceStrTyLit FastString
deriving (Eq)
type IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis
type IfaceForAllBndr = VarBndr IfaceBndr ArgFlag
mkIfaceForAllTvBndr :: ArgFlag -> IfaceTvBndr -> IfaceForAllBndr
mkIfaceForAllTvBndr vis var = Bndr (IfaceTvBndr var) vis
data IfaceAppArgs
= IA_Nil
| IA_Arg IfaceType
ArgFlag
IfaceAppArgs
instance Semi.Semigroup IfaceAppArgs where
IA_Nil <> xs = xs
IA_Arg ty argf rest <> xs = IA_Arg ty argf (rest Semi.<> xs)
instance Monoid IfaceAppArgs where
mempty = IA_Nil
mappend = (Semi.<>)
data IfaceTyCon = IfaceTyCon { ifaceTyConName :: IfExtName
, ifaceTyConInfo :: IfaceTyConInfo }
deriving (Eq)
data IfaceTyConSort = IfaceNormalTyCon
| IfaceTupleTyCon !Arity !TupleSort
| IfaceSumTyCon !Arity
| IfaceEqualityTyCon
deriving (Eq)
data IfaceTyConInfo
= IfaceTyConInfo { ifaceTyConIsPromoted :: PromotionFlag
, ifaceTyConSort :: IfaceTyConSort }
deriving (Eq)
data IfaceMCoercion
= IfaceMRefl
| IfaceMCo IfaceCoercion
data IfaceCoercion
= IfaceReflCo IfaceType
| IfaceGReflCo Role IfaceType (IfaceMCoercion)
| IfaceFunCo Role IfaceCoercion IfaceCoercion
| IfaceTyConAppCo Role IfaceTyCon [IfaceCoercion]
| IfaceAppCo IfaceCoercion IfaceCoercion
| IfaceForAllCo IfaceBndr 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
| 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 IA_Nil)
= isLiftedTypeKindTyConName (ifaceTyConName tc)
isIfaceLiftedTypeKind (IfaceTyConApp tc
(IA_Arg (IfaceTyConApp ptr_rep_lifted IA_Nil)
Required IA_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
ifForAllBndrVar :: IfaceForAllBndr -> IfaceBndr
ifForAllBndrVar = binderVar
ifForAllBndrName :: IfaceForAllBndr -> IfLclName
ifForAllBndrName fab = ifaceBndrName (ifForAllBndrVar fab)
ifTyConBinderVar :: IfaceTyConBinder -> IfaceBndr
ifTyConBinderVar = binderVar
ifTyConBinderName :: IfaceTyConBinder -> IfLclName
ifTyConBinderName tcb = ifaceBndrName (ifTyConBinderVar tcb)
ifTypeIsVarFree :: IfaceType -> Bool
ifTypeIsVarFree ty = go ty
where
go (IfaceTyVar {}) = False
go (IfaceFreeTyVar {}) = False
go (IfaceAppTy fun args) = go fun && go_args args
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 IA_Nil = True
go_args (IA_Arg 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 t ts) = IfaceAppTy (go t) (substIfaceAppArgs env ts)
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 (substIfaceAppArgs env tys)
go (IfaceTupleTy s i tys) = IfaceTupleTy s i (substIfaceAppArgs 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_mco IfaceMRefl = IfaceMRefl
go_mco (IfaceMCo co) = IfaceMCo $ go_co co
go_co (IfaceReflCo ty) = IfaceReflCo (go ty)
go_co (IfaceGReflCo r ty mco) = IfaceGReflCo r (go ty) (go_mco mco)
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 (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
substIfaceAppArgs :: IfaceTySubst -> IfaceAppArgs -> IfaceAppArgs
substIfaceAppArgs env args
= go args
where
go IA_Nil = IA_Nil
go (IA_Arg ty arg tys) = IA_Arg (substIfaceType env ty) arg (go tys)
substIfaceTyVar :: IfaceTySubst -> IfLclName -> IfaceType
substIfaceTyVar env tv
| Just ty <- lookupFsEnv env tv = ty
| otherwise = IfaceTyVar tv
stripInvisArgs :: DynFlags -> IfaceAppArgs -> IfaceAppArgs
stripInvisArgs dflags tys
| gopt Opt_PrintExplicitKinds dflags = tys
| otherwise = suppress_invis tys
where
suppress_invis c
= case c of
IA_Nil -> IA_Nil
IA_Arg t argf ts
| isVisibleArgFlag argf
-> IA_Arg t argf $ suppress_invis ts
| otherwise
-> suppress_invis ts
appArgsIfaceTypes :: IfaceAppArgs -> [IfaceType]
appArgsIfaceTypes IA_Nil = []
appArgsIfaceTypes (IA_Arg t _ ts) = t : appArgsIfaceTypes ts
appArgsIfaceTypesArgFlags :: IfaceAppArgs -> [(IfaceType, ArgFlag)]
appArgsIfaceTypesArgFlags IA_Nil = []
appArgsIfaceTypesArgFlags (IA_Arg t a ts)
= (t, a) : appArgsIfaceTypesArgFlags ts
ifaceVisAppArgsLength :: IfaceAppArgs -> Int
ifaceVisAppArgsLength = go 0
where
go !n IA_Nil = n
go n (IA_Arg _ argf rest)
| isVisibleArgFlag argf = go (n+1) rest
| otherwise = 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 :: IfaceTyConBinder -> SDoc
go (Bndr (IfaceIdBndr bndr) _) = pprIfaceIdBndr bndr
go (Bndr (IfaceTvBndr bndr) vis) =
case vis of
AnonTCB -> ppr_bndr True
NamedTCB Required -> ppr_bndr True
NamedTCB Specified -> char '@' <> ppr_bndr True
NamedTCB Inferred -> char '@' <> braces (ppr_bndr False)
where
ppr_bndr use_parens = pprIfaceTvBndr use_parens bndr
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 t ts)
= if_print_coercions
ppr_app_ty
ppr_app_ty_no_casts
where
ppr_app_ty =
sdocWithDynFlags $ \dflags ->
pprIfacePrefixApp ctxt_prec
(ppr_ty funPrec t)
(map (ppr_app_arg appPrec) (tys_wo_kinds dflags))
tys_wo_kinds dflags = appArgsIfaceTypesArgFlags $ stripInvisArgs dflags ts
ppr_app_ty_no_casts =
case t of
IfaceCastTy head _ -> ppr_ty ctxt_prec (mk_app_tys head ts)
_ -> ppr_app_ty
mk_app_tys :: IfaceType -> IfaceAppArgs -> IfaceType
mk_app_tys (IfaceTyConApp tc tys1) tys2 =
IfaceTyConApp tc (tys1 `mappend` tys2)
mk_app_tys t1 tys2 = IfaceAppTy t1 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 :: IfaceType -> IfaceType
defaultRuntimeRepVars ty = go False emptyFsEnv ty
where
go :: Bool
-> FastStringEnv ()
-> IfaceType
-> IfaceType
go ink subs (IfaceForAllTy (Bndr (IfaceTvBndr (var, var_kind)) argf) ty)
| isRuntimeRep var_kind
, isInvisibleArgFlag argf
= let subs' = extendFsEnv subs var ()
in go ink subs' ty
go ink subs (IfaceForAllTy bndr ty)
= IfaceForAllTy (go_ifacebndr subs bndr) (go ink subs ty)
go _ subs ty@(IfaceTyVar tv)
| tv `elemFsEnv` subs
= IfaceTyConApp liftedRep IA_Nil
| otherwise
= ty
go in_kind _ ty@(IfaceFreeTyVar tv)
| in_kind && TyCoRep.isRuntimeRepTy (tyVarKind tv)
= IfaceTyConApp liftedRep IA_Nil
| otherwise
= ty
go ink subs (IfaceTyConApp tc tc_args)
= IfaceTyConApp tc (go_args ink subs tc_args)
go ink subs (IfaceTupleTy sort is_prom tc_args)
= IfaceTupleTy sort is_prom (go_args ink subs tc_args)
go ink subs (IfaceFunTy arg res)
= IfaceFunTy (go ink subs arg) (go ink subs res)
go ink subs (IfaceAppTy t ts)
= IfaceAppTy (go ink subs t) (go_args ink subs ts)
go ink subs (IfaceDFunTy x y)
= IfaceDFunTy (go ink subs x) (go ink subs y)
go ink subs (IfaceCastTy x co)
= IfaceCastTy (go ink subs x) co
go _ _ ty@(IfaceLitTy {}) = ty
go _ _ ty@(IfaceCoercionTy {}) = ty
go_ifacebndr :: FastStringEnv () -> IfaceForAllBndr -> IfaceForAllBndr
go_ifacebndr subs (Bndr (IfaceIdBndr (n, t)) argf)
= Bndr (IfaceIdBndr (n, go True subs t)) argf
go_ifacebndr subs (Bndr (IfaceTvBndr (n, t)) argf)
= Bndr (IfaceTvBndr (n, go True subs t)) argf
go_args :: Bool -> FastStringEnv () -> IfaceAppArgs -> IfaceAppArgs
go_args _ _ IA_Nil = IA_Nil
go_args ink subs (IA_Arg ty argf args)
= IA_Arg (go ink subs ty) argf (go_args ink 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 ->
getPprStyle $ \sty ->
if userStyle sty && not (gopt Opt_PrintExplicitRuntimeReps dflags)
then f (defaultRuntimeRepVars ty)
else f ty
instance Outputable IfaceAppArgs where
ppr tca = pprIfaceAppArgs tca
pprIfaceAppArgs, pprParendIfaceAppArgs :: IfaceAppArgs -> SDoc
pprIfaceAppArgs = ppr_app_args topPrec
pprParendIfaceAppArgs = ppr_app_args appPrec
ppr_app_args :: PprPrec -> IfaceAppArgs -> SDoc
ppr_app_args ctx_prec = go
where
go :: IfaceAppArgs -> SDoc
go IA_Nil = empty
go (IA_Arg t argf ts) = ppr_app_arg ctx_prec (t, argf) <+> go ts
ppr_app_arg :: PprPrec -> (IfaceType, ArgFlag) -> SDoc
ppr_app_arg ctx_prec (t, argf) =
sdocWithDynFlags $ \dflags ->
let print_kinds = gopt Opt_PrintExplicitKinds dflags
in case argf of
Required -> ppr_ty ctx_prec t
Specified | print_kinds
-> char '@' <> ppr_ty appPrec t
Inferred | print_kinds
-> char '@' <> braces (ppr_ty topPrec t)
_ -> empty
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@(Bndr _ vis : _)
= sep [ add_separator (forAllLit <+> fsep docs)
, pprIfaceForAll bndrs' ]
where
(bndrs', docs) = 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@(Bndr _ vis) : bndrs) vis1
| vis `sameVis` vis1 = let (bndrs', doc) = ppr_itv_bndrs bndrs vis1 in
(bndrs', pprIfaceForAllBndr bndr : doc)
| otherwise = (all_bndrs, [])
ppr_itv_bndrs [] _ = ([], [])
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 (Bndr (IfaceTvBndr tv) Inferred)
= sdocWithDynFlags $ \dflags ->
if gopt Opt_PrintExplicitForalls dflags
then braces $ pprIfaceTvBndr False tv
else pprIfaceTvBndr True tv
pprIfaceForAllBndr (Bndr (IfaceTvBndr tv) _) = pprIfaceTvBndr True tv
pprIfaceForAllBndr (Bndr (IfaceIdBndr idv) _) = pprIfaceIdBndr idv
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 (Bndr (IfaceTvBndr (_,kind)) _)
= not (ifTypeIsVarFree kind)
tv_has_kind_var _ = False
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
, IA_Arg _ argf (IA_Arg ty1 Required (IA_Arg ty2 Required IA_Nil)) <- tys
, isInvisibleArgFlag argf
, (args, tl) <- gather ty2
= (ty1:args, tl)
| tc `ifaceTyConHasKey` nilDataConKey
= ([], Nothing)
gather ty = ([], Just ty)
pprIfaceTypeApp :: PprPrec -> IfaceTyCon -> IfaceAppArgs -> SDoc
pprIfaceTypeApp prec tc args = pprTyTcApp prec tc args
pprTyTcApp :: PprPrec -> IfaceTyCon -> IfaceAppArgs -> SDoc
pprTyTcApp ctxt_prec tc tys =
sdocWithDynFlags $ \dflags ->
getPprStyle $ \style ->
pprTyTcApp' ctxt_prec tc tys dflags style
pprTyTcApp' :: PprPrec -> IfaceTyCon -> IfaceAppArgs
-> DynFlags -> PprStyle -> SDoc
pprTyTcApp' ctxt_prec tc tys dflags style
| ifaceTyConName tc `hasKey` ipClassKey
, IA_Arg (IfaceLitTy (IfaceStrTyLit n))
Required (IA_Arg ty Required IA_Nil) <- tys
= maybeParen ctxt_prec funPrec
$ char '?' <> ftext n <> text "::" <> ppr_ty topPrec ty
| IfaceTupleTyCon arity sort <- ifaceTyConSort info
, not (debugStyle style)
, arity == ifaceVisAppArgsLength 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)
, IA_Arg _ argf (IA_Arg ty1 Required (IA_Arg ty2 Required IA_Nil)) <- tys
, isInvisibleArgFlag argf
= pprIfaceTyList ctxt_prec ty1 ty2
| tc `ifaceTyConHasKey` tYPETyConKey
, IA_Arg (IfaceTyConApp rep IA_Nil) Required IA_Nil <- tys
, rep `ifaceTyConHasKey` liftedRepDataConKey
= kindType
| otherwise
= getPprDebug $ \dbg ->
if | not dbg && tc `ifaceTyConHasKey` errorMessageTypeErrorFamKey
-> text "(TypeError ...)"
| Just doc <- ppr_equality ctxt_prec tc (appArgsIfaceTypes tys)
-> doc
| otherwise
-> ppr_iface_tc_app ppr_app_arg ctxt_prec tc tys_wo_kinds
where
info = ifaceTyConInfo tc
tys_wo_kinds = appArgsIfaceTypesArgFlags $ 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 (\prec (co, _) -> ppr_co prec co) ctxt_prec tc
(map (, Required) tys)
ppr_iface_tc_app :: (PprPrec -> (a, ArgFlag) -> SDoc)
-> PprPrec -> IfaceTyCon -> [(a, ArgFlag)] -> 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@(_, Required)
, ty2@(_, Required) ] <- 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 -> PromotionFlag -> IfaceAppArgs -> SDoc
pprSum _arity is_promoted args
=
let tys = appArgsIfaceTypes args
args' = drop (length tys `div` 2) tys
in pprPromotionQuoteI is_promoted
<> sumParens (pprWithBars (ppr_ty topPrec) args')
pprTuple :: PprPrec -> TupleSort -> PromotionFlag -> IfaceAppArgs -> SDoc
pprTuple ctxt_prec ConstraintTuple NotPromoted IA_Nil
= maybeParen ctxt_prec appPrec $
text "() :: Constraint"
pprTuple _ sort IsPromoted args
= let tys = appArgsIfaceTypes 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 = appArgsIfaceTypes 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 ty) = angleBrackets (ppr ty) <> ppr_role Nominal
ppr_co _ (IfaceGReflCo r ty IfaceMRefl)
= angleBrackets (ppr ty) <> ppr_role r
ppr_co ctxt_prec (IfaceGReflCo r ty (IfaceMCo co))
= ppr_special_co ctxt_prec
(text "GRefl" <+> ppr r <+> pprParendIfaceType ty) [co]
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 (IfaceTvBndr (name, _)) kind_co co')
= let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'')
split_co (IfaceForAllCo (IfaceIdBndr (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 (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 :: PromotionFlag -> SDoc
pprPromotionQuoteI NotPromoted = 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 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 IfaceAppArgs where
put_ bh tk =
case tk of
IA_Arg t a ts -> putByte bh 0 >> put_ bh t >> put_ bh a >> put_ bh ts
IA_Nil -> putByte bh 1
get bh =
do c <- getByte bh
case c of
0 -> do
t <- get bh
a <- get bh
ts <- get bh
return $! IA_Arg t a ts
1 -> return IA_Nil
_ -> panic ("get IfaceAppArgs " ++ 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 IfaceMCoercion where
put_ bh IfaceMRefl = do
putByte bh 1
put_ bh (IfaceMCo co) = do
putByte bh 2
put_ bh co
get bh = do
tag <- getByte bh
case tag of
1 -> return IfaceMRefl
2 -> do a <- get bh
return $ IfaceMCo a
_ -> panic ("get IfaceMCoercion " ++ show tag)
instance Binary IfaceCoercion where
put_ bh (IfaceReflCo a) = do
putByte bh 1
put_ bh a
put_ bh (IfaceGReflCo a b c) = do
putByte bh 2
put_ bh a
put_ bh b
put_ bh c
put_ bh (IfaceFunCo a b c) = do
putByte bh 3
put_ bh a
put_ bh b
put_ bh c
put_ bh (IfaceTyConAppCo a b c) = do
putByte bh 4
put_ bh a
put_ bh b
put_ bh c
put_ bh (IfaceAppCo a b) = do
putByte bh 5
put_ bh a
put_ bh b
put_ bh (IfaceForAllCo a b c) = do
putByte bh 6
put_ bh a
put_ bh b
put_ bh c
put_ bh (IfaceCoVarCo a) = do
putByte bh 7
put_ bh a
put_ bh (IfaceAxiomInstCo a b c) = do
putByte bh 8
put_ bh a
put_ bh b
put_ bh c
put_ bh (IfaceUnivCo a b c d) = do
putByte bh 9
put_ bh a
put_ bh b
put_ bh c
put_ bh d
put_ bh (IfaceSymCo a) = do
putByte bh 10
put_ bh a
put_ bh (IfaceTransCo a b) = do
putByte bh 11
put_ bh a
put_ bh b
put_ bh (IfaceNthCo a b) = do
putByte bh 12
put_ bh a
put_ bh b
put_ bh (IfaceLRCo a b) = do
putByte bh 13
put_ bh a
put_ bh b
put_ bh (IfaceInstCo 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
return $ IfaceReflCo a
2 -> do a <- get bh
b <- get bh
c <- get bh
return $ IfaceGReflCo a b c
3 -> do a <- get bh
b <- get bh
c <- get bh
return $ IfaceFunCo a b c
4 -> do a <- get bh
b <- get bh
c <- get bh
return $ IfaceTyConAppCo a b c
5 -> do a <- get bh
b <- get bh
return $ IfaceAppCo a b
6 -> do a <- get bh
b <- get bh
c <- get bh
return $ IfaceForAllCo a b c
7 -> do a <- get bh
return $ IfaceCoVarCo a
8 -> do a <- get bh
b <- get bh
c <- get bh
return $ IfaceAxiomInstCo a b c
9 -> do a <- get bh
b <- get bh
c <- get bh
d <- get bh
return $ IfaceUnivCo a b c d
10-> do a <- get bh
return $ IfaceSymCo a
11-> do a <- get bh
b <- get bh
return $ IfaceTransCo a b
12-> do a <- get bh
b <- get bh
return $ IfaceNthCo a b
13-> do a <- get bh
b <- get bh
return $ IfaceLRCo a b
14-> do a <- get bh
b <- get bh
return $ IfaceInstCo 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) }