X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FIfaceType.lhs;h=9cce438b13f3f1c29c908ba92490a862306b689d;hb=dbbd0bdf26cdbfd2b52cccd0809f0e88c9720379;hp=a487489f3a0d006d5eef5131505c3282883da7a3;hpb=61d2625ae2e6a4cdae2ffc92df828905e81c24cc;p=ghc-hetmet.git diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs index a487489..9cce438 100644 --- a/compiler/iface/IfaceType.lhs +++ b/compiler/iface/IfaceType.lhs @@ -1,15 +1,21 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 % - This module defines interface types and binders +This module defines interface types and binders \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module IfaceType ( IfaceType(..), IfaceKind, IfacePredType(..), IfaceTyCon(..), - IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, - - IfaceExtName(..), mkIfaceExtName, isLocalIfaceExtName, + IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, IfaceCoercion, ifaceTyConName, -- Conversion from Type -> IfaceType @@ -24,66 +30,16 @@ module IfaceType ( ) where -#include "HsVersions.h" - -import Kind ( Kind(..) ) -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, parenSymOcc, occNameFS ) -import Name ( Name, getName, getOccName, nameModule, nameOccName, - wiredInNameTyThing_maybe ) -import Module ( Module, ModuleName ) -import BasicTypes ( IPName(..), Arity, Version, mapIPName, tupleParens, Boxity ) +import TypeRep +import TyCon +import Var +import TysWiredIn +import Name +import BasicTypes import Outputable import FastString \end{code} - -%************************************************************************ -%* * - IfaceExtName -%* * -%************************************************************************ - -\begin{code} -data IfaceExtName - = 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 #; in all - -- other respects, HomePkg and ExtPkg are the same. Since this - -- is a home package name, we use ModuleName rather than Module - - | LocalTop OccName -- Top-level from the same module as - -- the enclosing IfaceDecl - - | LocalTopSub -- Same as LocalTop, but for a class method or constr - OccName -- Class-meth/constr name - OccName -- Parent class/datatype name - -- 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 - -ifaceExtOcc :: IfaceExtName -> OccName -ifaceExtOcc (ExtPkg _ occ) = occ -ifaceExtOcc (HomePkg _ occ _) = occ -ifaceExtOcc (LocalTop occ) = occ -ifaceExtOcc (LocalTopSub occ _) = occ -\end{code} - - %************************************************************************ %* * Local (nested) binders @@ -99,7 +55,8 @@ type IfaceIdBndr = (FastString, IfaceType) type IfaceTvBndr = (FastString, IfaceKind) ------------------------------- -type IfaceKind = Kind -- Re-use the Kind type, but no KindVars in it +type IfaceKind = IfaceType +type IfaceCoercion = IfaceType data IfaceType = IfaceTyVar FastString -- Type variable only, not tycon @@ -111,25 +68,36 @@ data IfaceType | IfaceFunTy IfaceType IfaceType data IfacePredType -- NewTypes are handled as ordinary TyConApps - = IfaceClassP IfaceExtName [IfaceType] + = IfaceClassP Name [IfaceType] | IfaceIParam (IPName OccName) IfaceType + | IfaceEqPred IfaceType IfaceType type IfaceContext = [IfacePredType] +-- NB: If you add a data constructor, remember to add a case to +-- IfaceSyn.eqIfTc! data IfaceTyCon -- Abbreviations for common tycons with known names - = IfaceTc IfaceExtName -- The common case + = IfaceTc Name -- The common case | IfaceIntTc | IfaceBoolTc | IfaceCharTc | IfaceListTc | IfacePArrTc | IfaceTupTc Boxity Arity + | IfaceLiftedTypeKindTc | IfaceOpenTypeKindTc | IfaceUnliftedTypeKindTc + | IfaceUbxTupleKindTc | IfaceArgTypeKindTc + deriving( Eq ) -ifaceTyConName :: IfaceTyCon -> Name -- Works for all except IfaceTc +ifaceTyConName :: IfaceTyCon -> Name ifaceTyConName IfaceIntTc = intTyConName ifaceTyConName IfaceBoolTc = boolTyConName ifaceTyConName IfaceCharTc = charTyConName ifaceTyConName IfaceListTc = listTyConName ifaceTyConName IfacePArrTc = parrTyConName ifaceTyConName (IfaceTupTc bx ar) = getName (tupleTyCon bx ar) -ifaceTyConName (IfaceTc ext) = pprPanic "ifaceTyConName" (ppr ext) +ifaceTyConName IfaceLiftedTypeKindTc = liftedTypeKindTyConName +ifaceTyConName IfaceOpenTypeKindTc = openTypeKindTyConName +ifaceTyConName IfaceUnliftedTypeKindTc = unliftedTypeKindTyConName +ifaceTyConName IfaceUbxTupleKindTc = ubxTupleKindTyConName +ifaceTyConName IfaceArgTypeKindTc = argTypeKindTyConName +ifaceTyConName (IfaceTc ext) = ext \end{code} @@ -191,16 +159,6 @@ 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 (LocalTop occ) = ppr occ -- Do we want to distinguish these - ppr (LocalTopSub occ _) = ppr occ -- from an ordinary occurrence? --- No need to worry about printing unqualified becuase that was handled --- in the transiation to IfaceSyn - instance Outputable IfaceBndr where ppr (IfaceIdBndr bndr) = pprIfaceIdBndr bndr ppr (IfaceTvBndr bndr) = char '@' <+> pprIfaceTvBndr bndr @@ -211,9 +169,9 @@ pprIfaceBndrs bs = sep (map ppr bs) pprIfaceIdBndr (name, ty) = hsep [ppr name, dcolon, ppr ty] pprIfaceTvBndr :: IfaceTvBndr -> SDoc -pprIfaceTvBndr (tv, LiftedTypeKind) = ppr tv -pprIfaceTvBndr (tv, kind) = parens (ppr tv <> dcolon <> ppr kind) - +pprIfaceTvBndr (tv, IfaceTyConApp IfaceLiftedTypeKindTc []) + = ppr tv +pprIfaceTvBndr (tv, kind) = parens (ppr tv <> dcolon <> ppr kind) pprIfaceTvBndrs :: [IfaceTvBndr] -> SDoc pprIfaceTvBndrs tyvars = hsep (map pprIfaceTvBndr tyvars) \end{code} @@ -223,14 +181,7 @@ pprIfaceTvBndrs tyvars = hsep (map pprIfaceTvBndr tyvars) \begin{code} --------------------------------- instance Outputable IfaceType where - ppr ty = pprIfaceTypeForUser ty - -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 + ppr ty = pprIfaceType ty pprIfaceType, pprParendIfaceType ::IfaceType -> SDoc pprIfaceType = ppr_ty tOP_PREC @@ -268,7 +219,7 @@ pprIfaceForAllPart tvs ctxt doc = sep [ppr_tvs, pprIfaceContext ctxt, doc] where ppr_tvs | null tvs = empty - | otherwise = ptext SLIT("forall") <+> pprIfaceTvBndrs tvs <> dot + | otherwise = ptext (sLit "forall") <+> pprIfaceTvBndrs tvs <> dot ------------------- ppr_tc_app ctxt_prec tc [] = ppr_tc tc @@ -283,14 +234,15 @@ ppr_tc_app ctxt_prec tc 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@(IfaceTc ext_nm) = parenSymOcc (getOccName ext_nm) (ppr tc) ppr_tc tc = ppr tc ------------------- instance Outputable IfacePredType where -- Print without parens + ppr (IfaceEqPred ty1 ty2)= hsep [ppr ty1, ptext (sLit ":=:"), ppr ty2] ppr (IfaceIParam ip ty) = hsep [ppr ip, dcolon, ppr ty] - ppr (IfaceClassP cls ts) = parenSymOcc (ifaceExtOcc cls) (ppr cls) + ppr (IfaceClassP cls ts) = parenSymOcc (getOccName cls) (ppr cls) <+> sep (map pprParendIfaceType ts) instance Outputable IfaceTyCon where @@ -301,13 +253,13 @@ instance Outputable IfaceTyCon where pprIfaceContext :: IfaceContext -> SDoc -- Prints "(C a, D b) =>", including the arrow pprIfaceContext [] = empty -pprIfaceContext theta = ppr_preds theta <+> ptext SLIT("=>") +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(":]") +pabrackets p = ptext (sLit "[:") <> p <> ptext (sLit ":]") \end{code} %************************************************************************ @@ -318,24 +270,31 @@ pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") \begin{code} ---------------- -toIfaceTvBndr tyvar = (occNameFS (getOccName tyvar), tyVarKind tyvar) -toIfaceIdBndr ext id = (occNameFS (getOccName id), toIfaceType ext (idType id)) +toIfaceTvBndr tyvar = (occNameFS (getOccName tyvar), toIfaceKind (tyVarKind tyvar)) +toIfaceIdBndr id = (occNameFS (getOccName id), toIfaceType (idType id)) toIfaceTvBndrs tyvars = map toIfaceTvBndr tyvars -toIfaceBndr ext var - | isId var = IfaceIdBndr (toIfaceIdBndr ext var) +toIfaceBndr var + | isId var = IfaceIdBndr (toIfaceIdBndr var) | otherwise = IfaceTvBndr (toIfaceTvBndr var) +toIfaceKind = toIfaceType + --------------------- -toIfaceType :: (Name -> IfaceExtName) -> Type -> IfaceType +toIfaceType :: Type -> IfaceType -- Synonyms are retained in the interface type -toIfaceType ext (TyVarTy tv) = IfaceTyVar (occNameFS (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 (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 other_note ty) = toIfaceType ext ty +toIfaceType (TyVarTy tv) = + IfaceTyVar (occNameFS (getOccName tv)) +toIfaceType (AppTy t1 t2) = + IfaceAppTy (toIfaceType t1) (toIfaceType t2) +toIfaceType (FunTy t1 t2) = + IfaceFunTy (toIfaceType t1) (toIfaceType t2) +toIfaceType (TyConApp tc tys) = + IfaceTyConApp (toIfaceTyCon tc) (toIfaceTypes tys) +toIfaceType (ForAllTy tv t) = + IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType t) +toIfaceType (PredTy st) = + IfacePredTy (toIfacePred st) ---------------- -- A little bit of (perhaps optional) trickiness here. When @@ -345,37 +304,46 @@ toIfaceType ext (NoteTy other_note ty) = toIfaceType ext ty -- Hence a tuple tycon may 'miss' in toIfaceTyCon, but then -- toIfaceTyCon_name will still catch it. -toIfaceTyCon :: (Name -> IfaceExtName) -> TyCon -> IfaceTyCon -toIfaceTyCon ext tc +toIfaceTyCon :: TyCon -> IfaceTyCon +toIfaceTyCon tc | isTupleTyCon tc = IfaceTupTc (tupleTyConBoxity tc) (tyConArity tc) - | otherwise = toIfaceTyCon_name ext (tyConName tc) + | otherwise = toIfaceTyCon_name (tyConName tc) -toIfaceTyCon_name :: (Name -> IfaceExtName) -> Name -> IfaceTyCon -toIfaceTyCon_name ext nm +toIfaceTyCon_name :: Name -> IfaceTyCon +toIfaceTyCon_name nm | Just (ATyCon tc) <- wiredInNameTyThing_maybe nm - = toIfaceWiredInTyCon ext tc nm + = toIfaceWiredInTyCon 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 - | nm == charTyConName = IfaceCharTc - | nm == listTyConName = IfaceListTc - | nm == parrTyConName = IfacePArrTc - | otherwise = IfaceTc (ext nm) + = IfaceTc nm + +toIfaceWiredInTyCon :: TyCon -> Name -> IfaceTyCon +toIfaceWiredInTyCon tc nm + | isTupleTyCon tc = IfaceTupTc (tupleTyConBoxity tc) (tyConArity tc) + | nm == intTyConName = IfaceIntTc + | nm == boolTyConName = IfaceBoolTc + | nm == charTyConName = IfaceCharTc + | nm == listTyConName = IfaceListTc + | nm == parrTyConName = IfacePArrTc + | nm == liftedTypeKindTyConName = IfaceLiftedTypeKindTc + | nm == unliftedTypeKindTyConName = IfaceUnliftedTypeKindTc + | nm == openTypeKindTyConName = IfaceOpenTypeKindTc + | nm == argTypeKindTyConName = IfaceArgTypeKindTc + | nm == ubxTupleKindTyConName = IfaceUbxTupleKindTc + | otherwise = IfaceTc nm ---------------- -toIfaceTypes ext ts = map (toIfaceType ext) ts +toIfaceTypes ts = map toIfaceType ts ---------------- -toIfacePred ext (ClassP cls ts) = IfaceClassP (ext (getName cls)) (toIfaceTypes ext ts) -toIfacePred ext (IParam ip t) = IfaceIParam (mapIPName getOccName ip) (toIfaceType ext t) +toIfacePred (ClassP cls ts) = + IfaceClassP (getName cls) (toIfaceTypes ts) +toIfacePred (IParam ip t) = + IfaceIParam (mapIPName getOccName ip) (toIfaceType t) +toIfacePred (EqPred ty1 ty2) = + IfaceEqPred (toIfaceType ty1) (toIfaceType ty2) ---------------- -toIfaceContext :: (Name -> IfaceExtName) -> ThetaType -> IfaceContext -toIfaceContext ext cs = map (toIfacePred ext) cs +toIfaceContext :: ThetaType -> IfaceContext +toIfaceContext cs = map toIfacePred cs \end{code}