%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
This module defines interface types and binders
\begin{code}
module IfaceType (
IfExtName, IfLclName,
IfaceType(..), IfacePredType, IfaceKind, IfaceTyCon(..), IfaceCoercion(..),
IfaceTyLit(..),
IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr,
toIfaceType, toIfaceKind, toIfaceContext,
toIfaceBndr, toIfaceIdBndr, toIfaceTvBndrs,
toIfaceTyCon, toIfaceTyCon_name,
toIfaceCoercion,
pprIfaceType, pprParendIfaceType, pprIfaceContext, pprIfaceContextArr,
pprIfaceIdBndr, pprIfaceTvBndr, pprIfaceTvBndrs,
pprIfaceBndrs,
tOP_PREC, tYCON_PREC, noParens, maybeParen, pprIfaceForAllPart,
pprIfaceCoercion, pprParendIfaceCoercion
) where
import Coercion
import TcType
import DynFlags
import TypeRep hiding( maybeParen )
import Unique( hasKey )
import TyCon
import CoAxiom
import Id
import Var
import TysWiredIn
import TysPrim
import PrelNames( funTyConKey )
import Name
import BasicTypes
import Binary
import Outputable
import FastString
import Control.Monad
\end{code}
%************************************************************************
%* *
Local (nested) binders
%* *
%************************************************************************
\begin{code}
type IfLclName = FastString
type IfExtName = Name
data IfaceBndr
= IfaceIdBndr !IfaceIdBndr
| IfaceTvBndr !IfaceTvBndr
type IfaceIdBndr = (IfLclName, IfaceType)
type IfaceTvBndr = (IfLclName, IfaceKind)
type IfaceKind = IfaceType
data IfaceType
= IfaceTyVar IfLclName
| IfaceAppTy IfaceType IfaceType
| IfaceFunTy IfaceType IfaceType
| IfaceForAllTy IfaceTvBndr IfaceType
| IfaceTyConApp IfaceTyCon [IfaceType]
| IfaceLitTy IfaceTyLit
type IfacePredType = IfaceType
type IfaceContext = [IfacePredType]
data IfaceTyLit
= IfaceNumTyLit Integer
| IfaceStrTyLit FastString
newtype IfaceTyCon = IfaceTc { ifaceTyConName :: IfExtName }
data IfaceCoercion
= IfaceReflCo Role IfaceType
| IfaceFunCo Role IfaceCoercion IfaceCoercion
| IfaceTyConAppCo Role IfaceTyCon [IfaceCoercion]
| IfaceAppCo IfaceCoercion IfaceCoercion
| IfaceForAllCo IfaceTvBndr IfaceCoercion
| IfaceCoVarCo IfLclName
| IfaceAxiomInstCo IfExtName BranchIndex [IfaceCoercion]
| IfaceUnivCo Role IfaceType IfaceType
| IfaceSymCo IfaceCoercion
| IfaceTransCo IfaceCoercion IfaceCoercion
| IfaceNthCo Int IfaceCoercion
| IfaceLRCo LeftOrRight IfaceCoercion
| IfaceInstCo IfaceCoercion IfaceType
| IfaceSubCo IfaceCoercion
| IfaceAxiomRuleCo IfLclName [IfaceType] [IfaceCoercion]
\end{code}
%************************************************************************
%* *
Functions over IFaceTypes
%* *
%************************************************************************
\begin{code}
splitIfaceSigmaTy :: IfaceType -> ([IfaceTvBndr], [IfacePredType], IfaceType)
splitIfaceSigmaTy ty
= (tvs, theta, tau)
where
(tvs, rho) = split_foralls ty
(theta, tau) = split_rho rho
split_foralls (IfaceForAllTy tv ty)
= case split_foralls ty of { (tvs, rho) -> (tv:tvs, rho) }
split_foralls rho = ([], rho)
split_rho (IfaceFunTy ty1 ty2)
| isIfacePredTy ty1 = case split_rho ty2 of { (ps, tau) -> (ty1:ps, tau) }
split_rho tau = ([], tau)
\end{code}
%************************************************************************
%* *
Pretty-printing
%* *
%************************************************************************
Precedence
~~~~~~~~~~
@ppr_ty@ takes an @Int@ that is the precedence of the context.
The precedence levels are:
\begin{description}
\item[tOP_PREC] No parens required.
\item[fUN_PREC] Left hand argument of a function arrow.
\item[tYCON_PREC] Argument of a type constructor.
\end{description}
\begin{code}
tOP_PREC, fUN_PREC, tYCON_PREC :: Int
tOP_PREC = 0
fUN_PREC = 1
tYCON_PREC = 2
noParens :: SDoc -> SDoc
noParens pp = pp
maybeParen :: Int -> Int -> SDoc -> SDoc
maybeParen ctxt_prec inner_prec pretty
| ctxt_prec < inner_prec = pretty
| otherwise = parens pretty
\end{code}
----------------------------- Printing binders ------------------------------------
\begin{code}
instance Outputable IfaceBndr where
ppr (IfaceIdBndr bndr) = pprIfaceIdBndr bndr
ppr (IfaceTvBndr bndr) = char '@' <+> pprIfaceTvBndr bndr
pprIfaceBndrs :: [IfaceBndr] -> SDoc
pprIfaceBndrs bs = sep (map ppr bs)
pprIfaceIdBndr :: (IfLclName, IfaceType) -> SDoc
pprIfaceIdBndr (name, ty) = hsep [ppr name, dcolon, ppr ty]
pprIfaceTvBndr :: IfaceTvBndr -> SDoc
pprIfaceTvBndr (tv, IfaceTyConApp tc [])
| ifaceTyConName tc == liftedTypeKindTyConName = ppr tv
pprIfaceTvBndr (tv, kind) = parens (ppr tv <> dcolon <> ppr kind)
pprIfaceTvBndrs :: [IfaceTvBndr] -> SDoc
pprIfaceTvBndrs tyvars = sep (map pprIfaceTvBndr tyvars)
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)
\end{code}
----------------------------- Printing IfaceType ------------------------------------
\begin{code}
instance Outputable IfaceType where
ppr ty = pprIfaceType ty
pprIfaceType, pprParendIfaceType ::IfaceType -> SDoc
pprIfaceType = ppr_ty tOP_PREC
pprParendIfaceType = ppr_ty tYCON_PREC
isIfacePredTy :: IfaceType -> Bool
isIfacePredTy _ = False
ppr_ty :: Int -> IfaceType -> SDoc
ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar
ppr_ty ctxt_prec (IfaceTyConApp tc tys) = ppr_tc_app ppr_ty ctxt_prec tc tys
ppr_ty _ (IfaceLitTy n) = ppr_tylit n
ppr_ty ctxt_prec (IfaceFunTy ty1 ty2)
=
maybeParen ctxt_prec fUN_PREC $
sep (ppr_ty fUN_PREC ty1 : ppr_fun_tail ty2)
where
arr | isIfacePredTy ty1 = darrow
| otherwise = arrow
ppr_fun_tail (IfaceFunTy ty1 ty2)
= (arr <+> ppr_ty fUN_PREC ty1) : ppr_fun_tail ty2
ppr_fun_tail other_ty
= [arr <+> pprIfaceType other_ty]
ppr_ty ctxt_prec (IfaceAppTy ty1 ty2)
= maybeParen ctxt_prec tYCON_PREC $
ppr_ty fUN_PREC ty1 <+> pprParendIfaceType ty2
ppr_ty ctxt_prec ty@(IfaceForAllTy _ _)
= maybeParen ctxt_prec fUN_PREC (pprIfaceForAllPart tvs theta (pprIfaceType tau))
where
(tvs, theta, tau) = splitIfaceSigmaTy ty
pprIfaceForAllPart :: Outputable a => [IfaceTvBndr] -> [a] -> SDoc -> SDoc
pprIfaceForAllPart tvs ctxt doc
= sep [ppr_tvs, pprIfaceContextArr ctxt, doc]
where
ppr_tvs | null tvs = empty
| otherwise = sdocWithDynFlags $ \ dflags ->
if gopt Opt_PrintExplicitForalls dflags
then ptext (sLit "forall") <+> pprIfaceTvBndrs tvs <> dot
else empty
ppr_tc_app :: (Int -> a -> SDoc) -> Int -> IfaceTyCon -> [a] -> SDoc
ppr_tc_app _ _ tc [] = ppr_tc tc
ppr_tc_app pp _ (IfaceTc n) [ty]
| n == listTyConName
= brackets (pp tOP_PREC ty)
| n == parrTyConName
= paBrackets (pp tOP_PREC ty)
ppr_tc_app pp _ (IfaceTc n) tys
| Just (ATyCon tc) <- wiredInNameTyThing_maybe n
, Just sort <- tyConTuple_maybe tc
, tyConArity tc == length tys
= tupleParens sort (sep (punctuate comma (map (pp tOP_PREC) tys)))
ppr_tc_app pp ctxt_prec tc tys
= maybeParen ctxt_prec tYCON_PREC
(sep [ppr_tc tc, nest 4 (sep (map (pp tYCON_PREC) tys))])
ppr_tc :: IfaceTyCon -> SDoc
ppr_tc tc = wrap (ifaceTyConName tc) (ppr tc)
where
wrap name | name == liftedTypeKindTyConName = id
wrap name = parenSymOcc (getOccName name)
ppr_tylit :: IfaceTyLit -> SDoc
ppr_tylit (IfaceNumTyLit n) = integer n
ppr_tylit (IfaceStrTyLit n) = text (show n)
pprIfaceCoercion, pprParendIfaceCoercion :: IfaceCoercion -> SDoc
pprIfaceCoercion = ppr_co tOP_PREC
pprParendIfaceCoercion = ppr_co tYCON_PREC
ppr_co :: Int -> IfaceCoercion -> SDoc
ppr_co _ (IfaceReflCo r ty) = angleBrackets (ppr ty) <> ppr_role r
ppr_co ctxt_prec (IfaceFunCo r co1 co2)
= maybeParen ctxt_prec fUN_PREC $
sep (ppr_co fUN_PREC co1 : ppr_fun_tail co2)
where
ppr_fun_tail (IfaceFunCo r co1 co2)
= (arrow <> ppr_role r <+> ppr_co fUN_PREC co1) : ppr_fun_tail co2
ppr_fun_tail other_co
= [arrow <> ppr_role r <+> pprIfaceCoercion other_co]
ppr_co _ (IfaceTyConAppCo r tc cos)
= parens (ppr_tc_app ppr_co tOP_PREC tc cos) <> ppr_role r
ppr_co ctxt_prec (IfaceAppCo co1 co2)
= maybeParen ctxt_prec tYCON_PREC $
ppr_co fUN_PREC co1 <+> pprParendIfaceCoercion co2
ppr_co ctxt_prec co@(IfaceForAllCo _ _)
= maybeParen ctxt_prec fUN_PREC (sep [ppr_tvs, pprIfaceCoercion inner_co])
where
(tvs, inner_co) = split_co co
ppr_tvs = ptext (sLit "forall") <+> pprIfaceTvBndrs tvs <> dot
split_co (IfaceForAllCo tv co')
= let (tvs, co'') = split_co co' in (tv:tvs,co'')
split_co co' = ([], co')
ppr_co _ (IfaceCoVarCo covar) = ppr covar
ppr_co ctxt_prec (IfaceUnivCo r ty1 ty2)
= maybeParen ctxt_prec tYCON_PREC $
ptext (sLit "UnivCo") <+> ppr r <+>
pprParendIfaceType ty1 <+> pprParendIfaceType ty2
ppr_co ctxt_prec (IfaceInstCo co ty)
= maybeParen ctxt_prec tYCON_PREC $
ptext (sLit "Inst") <+> pprParendIfaceCoercion co <+> pprParendIfaceType ty
ppr_co ctxt_prec (IfaceAxiomRuleCo tc tys cos)
= maybeParen ctxt_prec tYCON_PREC
(sep [ppr tc, nest 4 (sep (map pprParendIfaceType tys ++ map pprParendIfaceCoercion cos))])
ppr_co ctxt_prec co
= ppr_special_co ctxt_prec doc cos
where (doc, cos) = case co of
{ IfaceAxiomInstCo n i cos -> (ppr n <> brackets (ppr i), cos)
; IfaceSymCo co -> (ptext (sLit "Sym"), [co])
; IfaceTransCo co1 co2 -> (ptext (sLit "Trans"), [co1,co2])
; IfaceNthCo d co -> (ptext (sLit "Nth:") <> int d,
[co])
; IfaceLRCo lr co -> (ppr lr, [co])
; IfaceSubCo co -> (ptext (sLit "Sub"), [co])
; _ -> panic "pprIfaceCo" }
ppr_special_co :: Int -> SDoc -> [IfaceCoercion] -> SDoc
ppr_special_co ctxt_prec doc cos
= maybeParen ctxt_prec tYCON_PREC
(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'
instance Outputable IfaceTyCon where
ppr = ppr . ifaceTyConName
instance Outputable IfaceCoercion where
ppr = pprIfaceCoercion
instance Binary IfaceTyCon where
put_ bh (IfaceTc ext) = put_ bh ext
get bh = liftM IfaceTc (get bh)
instance Outputable IfaceTyLit where
ppr = ppr_tylit
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)
pprIfaceContextArr :: Outputable a => [a] -> SDoc
pprIfaceContextArr [] = empty
pprIfaceContextArr theta = pprIfaceContext theta <+> darrow
pprIfaceContext :: Outputable a => [a] -> SDoc
pprIfaceContext [pred] = ppr pred
pprIfaceContext preds = parens (sep (punctuate comma (map ppr preds)))
instance Binary IfaceType where
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 (IfaceTyConApp tc tys)
= do { putByte bh 5; put_ bh tc; put_ bh tys }
put_ bh (IfaceLitTy n)
= do { putByte bh 30; 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)
5 -> do { tc <- get bh; tys <- get bh
; return (IfaceTyConApp tc tys) }
30 -> do n <- get bh
return (IfaceLitTy n)
_ -> panic ("get IfaceType " ++ show h)
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) = do
putByte bh 5
put_ bh a
put_ bh b
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) = do
putByte bh 8
put_ bh a
put_ bh b
put_ bh c
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 (IfaceSubCo a) = do
putByte bh 14
put_ bh a
put_ bh (IfaceAxiomRuleCo a b c) = do
putByte bh 15
put_ bh a
put_ bh b
put_ bh c
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
return $ IfaceForAllCo a b
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
return $ IfaceUnivCo a b c
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
return $ IfaceSubCo a
15-> do a <- get bh
b <- get bh
c <- get bh
return $ IfaceAxiomRuleCo a b c
_ -> panic ("get IfaceCoercion " ++ show tag)
\end{code}
%************************************************************************
%* *
Conversion from Type to IfaceType
%* *
%************************************************************************
\begin{code}
toIfaceTvBndr :: TyVar -> (IfLclName, IfaceType)
toIfaceTvBndr tyvar = (occNameFS (getOccName tyvar), toIfaceKind (tyVarKind tyvar))
toIfaceIdBndr :: Id -> (IfLclName, IfaceType)
toIfaceIdBndr id = (occNameFS (getOccName id), toIfaceType (idType id))
toIfaceTvBndrs :: [TyVar] -> [(IfLclName, IfaceType)]
toIfaceTvBndrs tyvars = map toIfaceTvBndr tyvars
toIfaceBndr :: Var -> IfaceBndr
toIfaceBndr var
| isId var = IfaceIdBndr (toIfaceIdBndr var)
| otherwise = IfaceTvBndr (toIfaceTvBndr var)
toIfaceKind :: Type -> IfaceType
toIfaceKind = toIfaceType
toIfaceType :: Type -> IfaceType
toIfaceType (TyVarTy tv) = IfaceTyVar (toIfaceTyVar tv)
toIfaceType (AppTy t1 t2) = IfaceAppTy (toIfaceType t1) (toIfaceType t2)
toIfaceType (FunTy t1 t2) = IfaceFunTy (toIfaceType t1) (toIfaceType t2)
toIfaceType (TyConApp tc tys) = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTypes tys)
toIfaceType (LitTy n) = IfaceLitTy (toIfaceTyLit n)
toIfaceType (ForAllTy tv t) = IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType t)
toIfaceTyVar :: TyVar -> FastString
toIfaceTyVar = occNameFS . getOccName
toIfaceCoVar :: CoVar -> FastString
toIfaceCoVar = occNameFS . getOccName
toIfaceTyCon :: TyCon -> IfaceTyCon
toIfaceTyCon = toIfaceTyCon_name . tyConName
toIfaceTyCon_name :: Name -> IfaceTyCon
toIfaceTyCon_name = IfaceTc
toIfaceTyLit :: TyLit -> IfaceTyLit
toIfaceTyLit (NumTyLit x) = IfaceNumTyLit x
toIfaceTyLit (StrTyLit x) = IfaceStrTyLit x
toIfaceTypes :: [Type] -> [IfaceType]
toIfaceTypes ts = map toIfaceType ts
toIfaceContext :: ThetaType -> IfaceContext
toIfaceContext = toIfaceTypes
toIfaceCoercion :: Coercion -> IfaceCoercion
toIfaceCoercion (Refl r ty) = IfaceReflCo r (toIfaceType ty)
toIfaceCoercion (TyConAppCo r tc cos)
| tc `hasKey` funTyConKey
, [arg,res] <- cos = IfaceFunCo r (toIfaceCoercion arg) (toIfaceCoercion res)
| otherwise = IfaceTyConAppCo r (toIfaceTyCon tc)
(map toIfaceCoercion cos)
toIfaceCoercion (AppCo co1 co2) = IfaceAppCo (toIfaceCoercion co1)
(toIfaceCoercion co2)
toIfaceCoercion (ForAllCo v co) = IfaceForAllCo (toIfaceTvBndr v)
(toIfaceCoercion co)
toIfaceCoercion (CoVarCo cv) = IfaceCoVarCo (toIfaceCoVar cv)
toIfaceCoercion (AxiomInstCo con ind cos)
= IfaceAxiomInstCo (coAxiomName con) ind
(map toIfaceCoercion cos)
toIfaceCoercion (UnivCo r ty1 ty2) = IfaceUnivCo r (toIfaceType ty1)
(toIfaceType ty2)
toIfaceCoercion (SymCo co) = IfaceSymCo (toIfaceCoercion co)
toIfaceCoercion (TransCo co1 co2) = IfaceTransCo (toIfaceCoercion co1)
(toIfaceCoercion co2)
toIfaceCoercion (NthCo d co) = IfaceNthCo d (toIfaceCoercion co)
toIfaceCoercion (LRCo lr co) = IfaceLRCo lr (toIfaceCoercion co)
toIfaceCoercion (InstCo co ty) = IfaceInstCo (toIfaceCoercion co)
(toIfaceType ty)
toIfaceCoercion (SubCo co) = IfaceSubCo (toIfaceCoercion co)
toIfaceCoercion (AxiomRuleCo co ts cs) = IfaceAxiomRuleCo
(coaxrName co)
(map toIfaceType ts)
(map toIfaceCoercion cs)
\end{code}