X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fiface%2FIfaceType.lhs;h=2056a33f09b738c87815d990c5de6d76a7f74061;hb=83ec76b21158a4f6629e6c01947aa2793c264809;hp=04ca8ebcc80bfd5f91005049734c7b1324a07ef1;hpb=576650d4966549866ad2d07d618f99c9a0c7529d;p=ghc-hetmet.git diff --git a/ghc/compiler/iface/IfaceType.lhs b/ghc/compiler/iface/IfaceType.lhs index 04ca8eb..2056a33 100644 --- a/ghc/compiler/iface/IfaceType.lhs +++ b/ghc/compiler/iface/IfaceType.lhs @@ -2,46 +2,42 @@ % (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 ) -import TypeRep ( Type(..), TyNote(..), PredType(..), Kind, ThetaType ) -import TyCon ( TyCon, isTupleTyCon, tyConArity, tupleTyConBoxity ) +import Kind ( Kind(..) ) +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, 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 - -#ifdef DEBUG -import TypeRep( crudePprType ) -#endif \end{code} @@ -53,12 +49,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 +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} @@ -89,19 +105,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 +197,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 +220,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 +231,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 +280,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 @@ -310,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} @@ -325,7 +327,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,32 +336,38 @@ 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 = pprPanic "toIfaceKind" (crudePprType k) -#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 @@ -367,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