X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fiface%2FIfaceType.lhs;h=b7139083e2a6bba1967753214945afaa7d7b3057;hb=8e67f5502e2e316245806ee3735a2f41a844b611;hp=a4cf18376ac6e650b0322d205bd2f5914b0cca98;hpb=98643c2d5bd08ec71edd555e8989e530de6f5921;p=ghc-hetmet.git diff --git a/ghc/compiler/iface/IfaceType.lhs b/ghc/compiler/iface/IfaceType.lhs index a4cf183..b713908 100644 --- a/ghc/compiler/iface/IfaceType.lhs +++ b/ghc/compiler/iface/IfaceType.lhs @@ -2,46 +2,40 @@ % (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, -- 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 ) -import TypeRep ( Type(..), TyNote(..), PredType(..), Kind, ThetaType ) +import Kind ( Kind(..) ) +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 - -#ifdef DEBUG -import TypeRep( crudePprType ) -#endif \end{code} @@ -53,12 +47,13 @@ import TypeRep( crudePprType ) \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 @@ -69,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} @@ -89,19 +103,13 @@ type IfaceIdBndr = (OccName, IfaceType) -- OccName, because always local 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 @@ -187,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,8 +218,8 @@ pprIfaceBndrs bs = sep (map ppr bs) 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) @@ -231,50 +229,43 @@ 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 @@ -287,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 @@ -325,7 +322,7 @@ pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") \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 @@ -334,23 +331,10 @@ toIfaceBndr ext var | 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" (crudePprType k) IfaceOpenTypeKind -#endif - ---------------------- 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)