% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
- This module defines intereace types and binders
+ This module defines interface types and binders
\begin{code}
module IfaceType (
- IfaceType(..), IfaceKind(..), IfacePredType(..), IfaceTyCon(..),
+ IfaceType(..), IfaceKind, IfacePredType(..), IfaceTyCon(..),
IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr,
- IfaceExtName(..), mkIfaceExtName, ifaceTyConName,
+ IfaceExtName(..), mkIfaceExtName, isLocalIfaceExtName,
+ ifaceTyConName, interactiveExtNameFun,
-- Conversion from Type -> IfaceType
- toIfaceType, toIfaceKind, toIfacePred, toIfaceContext,
+ toIfaceType, toIfacePred, toIfaceContext,
toIfaceBndr, toIfaceIdBndr, toIfaceTvBndrs,
+ toIfaceTyCon, toIfaceTyCon_name,
-- Printing
- pprIfaceKind, pprParendIfaceKind,
pprIfaceType, pprParendIfaceType, pprIfaceContext,
pprIfaceIdBndr, pprIfaceTvBndr, pprIfaceTvBndrs, pprIfaceBndrs,
- getIfaceExt,
tOP_PREC, tYCON_PREC, noParens, maybeParen, pprIfaceForAllPart
) where
#include "HsVersions.h"
-import Type ( openTypeKind, liftedTypeKind, unliftedTypeKind,
- splitFunTy_maybe, eqKind, pprType )
-import TypeRep ( Type(..), TyNote(..), PredType(..), Kind, ThetaType )
-import TyCon ( TyCon, isTupleTyCon, tyConArity, tupleTyConBoxity )
+import Kind ( Kind(..) )
+import TypeRep ( TyThing(..), Type(..), PredType(..), ThetaType )
+import TyCon ( TyCon, isTupleTyCon, tyConArity, tupleTyConBoxity, tyConName )
import Var ( isId, tyVarKind, idType )
import TysWiredIn ( listTyConName, parrTyConName, tupleTyCon, intTyConName, charTyConName, boolTyConName )
-import OccName ( OccName )
-import Name ( Name, getName, getOccName, nameModuleName, nameOccName, isInternalName )
-import Module ( ModuleName )
+import OccName ( OccName, parenSymOcc )
+import Name ( Name, getName, getOccName, nameModule, nameOccName,
+ wiredInNameTyThing_maybe )
+import Module ( Module )
import BasicTypes ( IPName(..), Arity, Version, mapIPName, tupleParens, Boxity )
import Outputable
import FastString
\begin{code}
data IfaceExtName
- = ExtPkg ModuleName OccName -- From an external package; no version #
+ = ExtPkg Module OccName -- From an external package; no version #
-- Also used for wired-in things regardless
-- of whether they are home-pkg or not
- | HomePkg ModuleName OccName Version -- From another module in home package;
- -- has version #
+ | HomePkg Module OccName Version -- From another module in home package;
+ -- has version #; in all other respects,
+ -- HomePkg and ExtPkg are the same
| LocalTop OccName -- Top-level from the same module as
-- the enclosing IfaceDecl
-- LocalTopSub is written into iface files as LocalTop; the parent
-- info is only used when computing version information in MkIface
-mkIfaceExtName name = ExtPkg (nameModuleName name) (nameOccName name)
+isLocalIfaceExtName :: IfaceExtName -> Bool
+isLocalIfaceExtName (LocalTop _) = True
+isLocalIfaceExtName (LocalTopSub _ _) = True
+isLocalIfaceExtName other = False
+
+mkIfaceExtName name = ExtPkg (nameModule name) (nameOccName name)
-- Local helper for wired-in names
+
+ifaceExtOcc :: IfaceExtName -> OccName
+ifaceExtOcc (ExtPkg _ occ) = occ
+ifaceExtOcc (HomePkg _ occ _) = occ
+ifaceExtOcc (LocalTop occ) = occ
+ifaceExtOcc (LocalTopSub occ _) = occ
+
+interactiveExtNameFun :: PrintUnqualified -> Name-> IfaceExtName
+interactiveExtNameFun print_unqual name
+ | print_unqual mod occ = LocalTop occ
+ | otherwise = ExtPkg mod occ
+ where
+ mod = nameModule name
+ occ = nameOccName name
\end{code}
type IfaceTvBndr = (OccName, IfaceKind)
-------------------------------
-data IfaceKind
- = IfaceLiftedTypeKind
- | IfaceOpenTypeKind
- | IfaceUnliftedTypeKind
- | IfaceFunKind IfaceKind IfaceKind
- deriving( Eq )
+type IfaceKind = Kind -- Re-use the Kind type, but no KindVars in it
--------------------------------
data IfaceType
- = IfaceTyVar OccName -- Type variable only, not tycon
+ = IfaceTyVar OccName -- Type variable only, not tycon
| IfaceAppTy IfaceType IfaceType
| IfaceForAllTy IfaceTvBndr IfaceType
- | IfacePredTy IfacePredType
+ | IfacePredTy IfacePredType
| IfaceTyConApp IfaceTyCon [IfaceType] -- Not necessarily saturated
-- Includes newtypes, synonyms, tuples
| IfaceFunTy IfaceType IfaceType
----------------------------- Printing binders ------------------------------------
\begin{code}
+-- These instances are used only when printing for the user, either when
+-- debugging, or in GHCi when printing the results of a :info command
instance Outputable IfaceExtName where
- ppr (ExtPkg mod occ) = ppr mod <> dot <> ppr occ
- ppr (HomePkg mod occ vers) = ppr mod <> dot <> ppr occ <> braces (ppr vers)
+ ppr (ExtPkg mod occ) = pprExt mod occ
+ ppr (HomePkg mod occ vers) = pprExt mod occ <> braces (ppr vers)
ppr (LocalTop occ) = ppr occ -- Do we want to distinguish these
ppr (LocalTopSub occ _) = ppr occ -- from an ordinary occurrence?
-getIfaceExt :: ((Name -> IfaceExtName) -> SDoc) -> SDoc
--- Uses the print-unqual info from the SDoc to make an 'ext'
--- which in turn tells toIfaceType when to make a qualified name
--- This is only used when making Iface stuff to print out for the user;
--- e.g. we use this in pprType
-getIfaceExt thing_inside
- = getPprStyle $ \ sty ->
- let
- ext nm | unqualStyle sty nm = LocalTop (nameOccName nm)
- | isInternalName nm = LocalTop (nameOccName nm)
- -- This only happens for Kind constructors, which
- -- don't come from any particular module and are unqualified
- -- This hack will go away when kinds are separated from types
- | otherwise = ExtPkg (nameModuleName nm) (nameOccName nm)
- in
- thing_inside ext
+pprExt :: Module -> OccName -> SDoc
+-- No need to worry about printing unqualified becuase that was handled
+-- in the transiation to IfaceSyn
+pprExt mod occ = ppr mod <> dot <> ppr occ
instance Outputable IfaceBndr where
ppr (IfaceIdBndr bndr) = pprIfaceIdBndr bndr
pprIfaceIdBndr (name, ty) = hsep [ppr name, dcolon, ppr ty]
pprIfaceTvBndr :: IfaceTvBndr -> SDoc
-pprIfaceTvBndr (tv, IfaceLiftedTypeKind) = ppr tv
-pprIfaceTvBndr (tv, kind) = parens (ppr tv <> dcolon <> ppr kind)
+pprIfaceTvBndr (tv, LiftedTypeKind) = ppr tv
+pprIfaceTvBndr (tv, kind) = parens (ppr tv <> dcolon <> ppr kind)
pprIfaceTvBndrs :: [IfaceTvBndr] -> SDoc
pprIfaceTvBndrs tyvars = hsep (map pprIfaceTvBndr tyvars)
\begin{code}
---------------------------------
-instance Outputable IfaceKind where
- ppr k = pprIfaceKind tOP_PREC k
-
-pprParendIfaceKind :: IfaceKind -> SDoc
-pprParendIfaceKind k = pprIfaceKind tYCON_PREC k
-
-pprIfaceKind prec IfaceLiftedTypeKind = ptext SLIT("*")
-pprIfaceKind prec IfaceUnliftedTypeKind = ptext SLIT("#")
-pprIfaceKind prec IfaceOpenTypeKind = ptext SLIT("?")
-pprIfaceKind prec (IfaceFunKind k1 k2) = maybeParen prec fUN_PREC $
- sep [ pprIfaceKind fUN_PREC k1, arrow <+> ppr k2]
-
----------------------------------
instance Outputable IfaceType where
- ppr ty = ppr_ty ty
+ ppr ty = pprIfaceTypeForUser ty
-ppr_ty = pprIfaceType tOP_PREC
-pprParendIfaceType = pprIfaceType tYCON_PREC
+pprIfaceTypeForUser ::IfaceType -> SDoc
+-- Drop top-level for-alls; if that's not what you want, use pprIfaceType dire
+pprIfaceTypeForUser ty
+ = pprIfaceForAllPart [] theta (pprIfaceType tau)
+ where
+ (_tvs, theta, tau) = splitIfaceSigmaTy ty
-pprIfaceType :: Int -> IfaceType -> SDoc
+pprIfaceType, pprParendIfaceType ::IfaceType -> SDoc
+pprIfaceType = ppr_ty tOP_PREC
+pprParendIfaceType = ppr_ty tYCON_PREC
- -- Simple cases
-pprIfaceType ctxt_prec (IfaceTyVar tyvar) = ppr tyvar
-pprIfaceType ctxt_prec (IfaceTyConApp tc tys) = ppr_tc_app ctxt_prec tc tys
-pprIfaceType ctxt_prec (IfacePredTy st) = braces (ppr st)
+ppr_ty :: Int -> IfaceType -> SDoc
+ppr_ty ctxt_prec (IfaceTyVar tyvar) = ppr tyvar
+ppr_ty ctxt_prec (IfaceTyConApp tc tys) = ppr_tc_app ctxt_prec tc tys
+ppr_ty ctxt_prec (IfacePredTy st) = ppr st
-- Function types
-pprIfaceType ctxt_prec (IfaceFunTy ty1 ty2)
+ppr_ty ctxt_prec (IfaceFunTy ty1 ty2)
= -- We don't want to lose synonyms, so we mustn't use splitFunTys here.
maybeParen ctxt_prec fUN_PREC $
- sep (pprIfaceType fUN_PREC ty1 : ppr_fun_tail ty2)
+ sep (ppr_ty fUN_PREC ty1 : ppr_fun_tail ty2)
where
ppr_fun_tail (IfaceFunTy ty1 ty2)
- = (arrow <+> pprIfaceType fUN_PREC ty1) : ppr_fun_tail ty2
+ = (arrow <+> ppr_ty fUN_PREC ty1) : ppr_fun_tail ty2
ppr_fun_tail other_ty
- = [arrow <+> ppr_ty other_ty]
+ = [arrow <+> pprIfaceType other_ty]
-pprIfaceType ctxt_prec (IfaceAppTy ty1 ty2)
+ppr_ty ctxt_prec (IfaceAppTy ty1 ty2)
= maybeParen ctxt_prec tYCON_PREC $
- pprIfaceType fUN_PREC ty1 <+> pprParendIfaceType ty2
+ ppr_ty fUN_PREC ty1 <+> pprParendIfaceType ty2
-pprIfaceType ctxt_prec ty@(IfaceForAllTy _ _)
- = maybeParen ctxt_prec fUN_PREC (pprIfaceForAllPart tvs theta (ppr_ty tau))
+ppr_ty ctxt_prec ty@(IfaceForAllTy _ _)
+ = maybeParen ctxt_prec fUN_PREC (pprIfaceForAllPart tvs theta (pprIfaceType tau))
where
(tvs, theta, tau) = splitIfaceSigmaTy ty
| otherwise = ptext SLIT("forall") <+> pprIfaceTvBndrs tvs <> dot
-------------------
-ppr_tc_app ctxt_prec tc [] = ppr tc
-ppr_tc_app ctxt_prec IfaceListTc [ty] = brackets (ppr_ty ty)
-ppr_tc_app ctxt_prec IfacePArrTc [ty] = pabrackets (ppr_ty ty)
+ppr_tc_app ctxt_prec tc [] = ppr_tc tc
+ppr_tc_app ctxt_prec IfaceListTc [ty] = brackets (pprIfaceType ty)
+ppr_tc_app ctxt_prec IfacePArrTc [ty] = pabrackets (pprIfaceType ty)
ppr_tc_app ctxt_prec (IfaceTupTc bx arity) tys
| arity == length tys
- = tupleParens bx (sep (punctuate comma (map ppr_ty tys)))
+ = tupleParens bx (sep (punctuate comma (map pprIfaceType tys)))
ppr_tc_app ctxt_prec tc tys
= maybeParen ctxt_prec tYCON_PREC
- (sep [ppr tc, nest 4 (sep (map pprParendIfaceType tys))])
+ (sep [ppr_tc tc, nest 4 (sep (map pprParendIfaceType tys))])
+
+ppr_tc :: IfaceTyCon -> SDoc
+-- Wrap infix type constructors in parens
+ppr_tc tc@(IfaceTc ext_nm) = parenSymOcc (ifaceExtOcc ext_nm) (ppr tc)
+ppr_tc tc = ppr tc
-------------------
instance Outputable IfacePredType where
-- Print without parens
ppr (IfaceIParam ip ty) = hsep [ppr ip, dcolon, ppr ty]
- ppr (IfaceClassP cls ts) = ppr cls <+> sep (map pprParendIfaceType ts)
+ ppr (IfaceClassP cls ts) = parenSymOcc (ifaceExtOcc cls) (ppr cls)
+ <+> sep (map pprParendIfaceType ts)
instance Outputable IfaceTyCon where
ppr (IfaceTc ext) = ppr ext
-------------------
pprIfaceContext :: IfaceContext -> SDoc
-- Prints "(C a, D b) =>", including the arrow
-pprIfaceContext [] = empty
-pprIfaceContext theta = parens (sep (punctuate comma (map ppr theta)))
- <+> ptext SLIT("=>")
-
+pprIfaceContext [] = empty
+pprIfaceContext theta = ppr_preds theta <+> ptext SLIT("=>")
+
+ppr_preds [pred] = ppr pred -- No parens
+ppr_preds preds = parens (sep (punctuate comma (map ppr preds)))
+
+-------------------
pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]")
\end{code}
\begin{code}
----------------
-toIfaceTvBndr tyvar = (getOccName tyvar, toIfaceKind (tyVarKind tyvar))
+toIfaceTvBndr tyvar = (getOccName tyvar, tyVarKind tyvar)
toIfaceIdBndr ext id = (getOccName id, toIfaceType ext (idType id))
toIfaceTvBndrs tyvars = map toIfaceTvBndr tyvars
| otherwise = IfaceTvBndr (toIfaceTvBndr var)
---------------------
-toIfaceKind :: Kind -> IfaceKind
-toIfaceKind k
- | k `eqKind` openTypeKind = IfaceOpenTypeKind
- | k `eqKind` liftedTypeKind = IfaceLiftedTypeKind
- | k `eqKind` unliftedTypeKind = IfaceUnliftedTypeKind
- | Just (arg,res) <- splitFunTy_maybe k
- = IfaceFunKind (toIfaceKind arg) (toIfaceKind res)
-#ifdef DEBUG
- | otherwise = pprTrace "toIfaceKind" (pprType k) IfaceOpenTypeKind
-#endif
-
----------------------
toIfaceType :: (Name -> IfaceExtName) -> Type -> IfaceType
+-- Synonyms are retained in the interface type
toIfaceType ext (TyVarTy tv) = IfaceTyVar (getOccName tv)
toIfaceType ext (AppTy t1 t2) = IfaceAppTy (toIfaceType ext t1) (toIfaceType ext t2)
toIfaceType ext (FunTy t1 t2) = IfaceFunTy (toIfaceType ext t1) (toIfaceType ext t2)
-toIfaceType ext (NewTcApp tc tys) = IfaceTyConApp (mkIfaceTc ext tc) (toIfaceTypes ext tys)
-toIfaceType ext (TyConApp tc tys) = IfaceTyConApp (mkIfaceTc ext tc) (toIfaceTypes ext tys)
+toIfaceType ext (TyConApp tc tys) = IfaceTyConApp (toIfaceTyCon ext tc) (toIfaceTypes ext tys)
toIfaceType ext (ForAllTy tv t) = IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType ext t)
toIfaceType ext (PredTy st) = IfacePredTy (toIfacePred ext st)
-toIfaceType ext (NoteTy (SynNote tc_app) ty) = toIfaceType ext tc_app
toIfaceType ext (NoteTy other_note ty) = toIfaceType ext ty
----------------
-mkIfaceTc :: (Name -> IfaceExtName) -> TyCon -> IfaceTyCon
-mkIfaceTc ext tc
+-- A little bit of (perhaps optional) trickiness here. When
+-- compiling Data.Tuple, the tycons are not TupleTyCons, although
+-- they have a wired-in name. But we'd like to dump them into the Iface
+-- as a tuple tycon, to save lookups when reading the interface
+-- Hence a tuple tycon may 'miss' in toIfaceTyCon, but then
+-- toIfaceTyCon_name will still catch it.
+
+toIfaceTyCon :: (Name -> IfaceExtName) -> TyCon -> IfaceTyCon
+toIfaceTyCon ext tc
+ | isTupleTyCon tc = IfaceTupTc (tupleTyConBoxity tc) (tyConArity tc)
+ | otherwise = toIfaceTyCon_name ext (tyConName tc)
+
+toIfaceTyCon_name :: (Name -> IfaceExtName) -> Name -> IfaceTyCon
+toIfaceTyCon_name ext nm
+ | Just (ATyCon tc) <- wiredInNameTyThing_maybe nm
+ = toIfaceWiredInTyCon ext tc nm
+ | otherwise
+ = IfaceTc (ext nm)
+
+toIfaceWiredInTyCon :: (Name -> IfaceExtName) -> TyCon -> Name -> IfaceTyCon
+toIfaceWiredInTyCon ext tc nm
| isTupleTyCon tc = IfaceTupTc (tupleTyConBoxity tc) (tyConArity tc)
| nm == intTyConName = IfaceIntTc
| nm == boolTyConName = IfaceBoolTc
| nm == listTyConName = IfaceListTc
| nm == parrTyConName = IfacePArrTc
| otherwise = IfaceTc (ext nm)
- where
- nm = getName tc
----------------
toIfaceTypes ext ts = map (toIfaceType ext) ts