X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fiface%2FIfaceType.lhs;h=76438ddb239afcc39b3ab3ddb986e45a44bda1b8;hb=274a7b1ab7cf30fd1ceaddd02f991eaf694cc37c;hp=b771e5a403984b2b9a261b34a371015dee5ec7b9;hpb=23f40f0e9be6d4aa5cf9ea31d73f4013f8e7b4bd;p=ghc-hetmet.git diff --git a/ghc/compiler/iface/IfaceType.lhs b/ghc/compiler/iface/IfaceType.lhs index b771e5a..76438dd 100644 --- a/ghc/compiler/iface/IfaceType.lhs +++ b/ghc/compiler/iface/IfaceType.lhs @@ -9,11 +9,13 @@ module IfaceType ( IfaceType(..), IfaceKind, IfacePredType(..), IfaceTyCon(..), IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, - IfaceExtName(..), mkIfaceExtName, ifaceTyConName, + IfaceExtName(..), mkIfaceExtName, isLocalIfaceExtName, + ifaceTyConName, interactiveExtNameFun, -- Conversion from Type -> IfaceType toIfaceType, toIfacePred, toIfaceContext, toIfaceBndr, toIfaceIdBndr, toIfaceTvBndrs, + toIfaceTyCon, toIfaceTyCon_name, -- Printing pprIfaceType, pprParendIfaceType, pprIfaceContext, @@ -25,13 +27,14 @@ module IfaceType ( #include "HsVersions.h" import Kind ( Kind(..) ) -import TypeRep ( Type(..), TyNote(..), PredType(..), Kind, ThetaType ) -import TyCon ( TyCon, isTupleTyCon, tyConArity, tupleTyConBoxity ) +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 ) -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 @@ -46,12 +49,13 @@ 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 @@ -62,8 +66,27 @@ data IfaceExtName -- 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} @@ -182,13 +205,10 @@ instance Outputable IfaceExtName where ppr (LocalTop occ) = ppr occ -- Do we want to distinguish these ppr (LocalTopSub occ _) = ppr occ -- from an ordinary occurrence? -pprExt :: ModuleName -> OccName -> SDoc -pprExt mod occ - = getPprStyle $ \ sty -> - if unqualStyle sty mod occ then - ppr occ - else - ppr mod <> dot <> ppr occ +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 @@ -260,7 +280,7 @@ pprIfaceForAllPart tvs ctxt doc | otherwise = ptext SLIT("forall") <+> pprIfaceTvBndrs tvs <> dot ------------------- -ppr_tc_app ctxt_prec tc [] = ppr tc +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 @@ -268,13 +288,19 @@ ppr_tc_app ctxt_prec (IfaceTupTc bx arity) 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 @@ -283,10 +309,13 @@ instance Outputable IfaceTyCon where ------------------- 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} @@ -308,19 +337,37 @@ toIfaceBndr ext var --------------------- 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 @@ -328,8 +375,6 @@ mkIfaceTc ext tc | nm == listTyConName = IfaceListTc | nm == parrTyConName = IfacePArrTc | otherwise = IfaceTc (ext nm) - where - nm = getName tc ---------------- toIfaceTypes ext ts = map (toIfaceType ext) ts