X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fiface%2FIfaceType.lhs;h=e6471eb94d42f4c674eb74429862461ca0d6b89a;hb=015aa9723a1e72d7bfe0e82599454bee59f4d472;hp=0ebfa0d88f7d08b0d1084be1b249391d8b93a3f6;hpb=508a505e9853984bfdaa3ad855ae3fcbc6d31787;p=ghc-hetmet.git diff --git a/ghc/compiler/iface/IfaceType.lhs b/ghc/compiler/iface/IfaceType.lhs index 0ebfa0d..e6471eb 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, ifPrintUnqual, + IfaceExtName(..), mkIfaceExtName, isLocalIfaceExtName, + ifaceTyConName, interactiveExtNameFun, -- Conversion from Type -> IfaceType toIfaceType, toIfacePred, toIfaceContext, toIfaceBndr, toIfaceIdBndr, toIfaceTvBndrs, + toIfaceTyCon, toIfaceTyCon_name, -- Printing pprIfaceType, pprParendIfaceType, pprIfaceContext, @@ -25,12 +27,13 @@ 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(..), TyNote(..), 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, nameModule, nameOccName ) +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 @@ -63,13 +66,27 @@ data IfaceExtName -- LocalTopSub is written into iface files as LocalTop; the parent -- info is only used when computing version information in MkIface +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 -ifPrintUnqual :: PrintUnqualified -> IfaceExtName -> Bool -ifPrintUnqual print_unqual (ExtPkg mod occ) = print_unqual mod occ -ifPrintUnqual print_unqual (HomePkg mod occ _) = print_unqual mod occ -ifPrintUnqual print_unqual other = True +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} @@ -189,12 +206,9 @@ instance Outputable IfaceExtName where ppr (LocalTopSub occ _) = ppr occ -- from an ordinary occurrence? pprExt :: Module -> OccName -> SDoc -pprExt mod occ - = getPprStyle $ \ sty -> - if unqualStyle sty mod occ then - ppr occ - else - ppr mod <> dot <> ppr occ +-- 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 @@ -266,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 @@ -274,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 @@ -289,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} @@ -317,15 +340,34 @@ toIfaceType :: (Name -> IfaceExtName) -> Type -> IfaceType 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 (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 (SynNote tc_app) ty) = toIfaceType ext tc_app -- Retain synonyms 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 @@ -333,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