X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fiface%2FIfaceType.lhs;h=b7139083e2a6bba1967753214945afaa7d7b3057;hb=8e67f5502e2e316245806ee3735a2f41a844b611;hp=5cbd163237ba81d94ac94da2c54daf7633a6f3d7;hpb=d357373cebec0a8779cbb116842ccfe074851571;p=ghc-hetmet.git diff --git a/ghc/compiler/iface/IfaceType.lhs b/ghc/compiler/iface/IfaceType.lhs index 5cbd163..b713908 100644 --- a/ghc/compiler/iface/IfaceType.lhs +++ b/ghc/compiler/iface/IfaceType.lhs @@ -9,7 +9,8 @@ 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, @@ -18,7 +19,6 @@ module IfaceType ( -- Printing pprIfaceType, pprParendIfaceType, pprIfaceContext, pprIfaceIdBndr, pprIfaceTvBndr, pprIfaceTvBndrs, pprIfaceBndrs, - getIfaceExt, tOP_PREC, tYCON_PREC, noParens, maybeParen, pprIfaceForAllPart ) where @@ -26,13 +26,13 @@ module IfaceType ( #include "HsVersions.h" import Kind ( Kind(..) ) -import TypeRep ( Type(..), TyNote(..), PredType(..), Kind, ThetaType ) +import TypeRep ( Type(..), TyNote(..), PredType(..), ThetaType ) import TyCon ( TyCon, isTupleTyCon, tyConArity, tupleTyConBoxity ) 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 ) +import Module ( Module ) import BasicTypes ( IPName(..), Arity, Version, mapIPName, tupleParens, Boxity ) import Outputable import FastString @@ -47,12 +47,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 @@ -63,8 +64,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} @@ -86,10 +106,10 @@ type IfaceTvBndr = (OccName, IfaceKind) 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 @@ -175,28 +195,18 @@ maybeParen ctxt_prec inner_prec pretty ----------------------------- 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 @@ -220,36 +230,42 @@ pprIfaceTvBndrs tyvars = hsep (map pprIfaceTvBndr tyvars) \begin{code} --------------------------------- 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 @@ -262,21 +278,27 @@ pprIfaceForAllPart tvs ctxt doc | 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 @@ -313,7 +335,6 @@ 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 (NewTcApp tc tys) = IfaceTyConApp (mkIfaceTc ext tc) (toIfaceTypes ext tys) toIfaceType ext (TyConApp tc tys) = IfaceTyConApp (mkIfaceTc ext tc) (toIfaceTypes ext tys) toIfaceType ext (ForAllTy tv t) = IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType ext t) toIfaceType ext (PredTy st) = IfacePredTy (toIfacePred ext st)