From 6dc63dc5e8f22618dd98cd07cad7e9bdb9524304 Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Fri, 4 Aug 2006 21:39:46 +0000 Subject: [PATCH] Massive patch for the first months work adding System FC to GHC #19 Broken up massive patch -=chak Original log message: This is (sadly) all done in one patch to avoid Darcs bugs. It's not complete work... more FC stuff to come. A compiler using just this patch will fail dismally. --- compiler/iface/IfaceType.lhs | 60 ++++++++++++++++++++++++++++++------------ 1 file changed, 43 insertions(+), 17 deletions(-) diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs index a487489..9e76cdd 100644 --- a/compiler/iface/IfaceType.lhs +++ b/compiler/iface/IfaceType.lhs @@ -7,7 +7,7 @@ \begin{code} module IfaceType ( IfaceType(..), IfaceKind, IfacePredType(..), IfaceTyCon(..), - IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, + IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, IfaceCoercion, IfaceExtName(..), mkIfaceExtName, isLocalIfaceExtName, ifaceTyConName, @@ -26,8 +26,12 @@ module IfaceType ( #include "HsVersions.h" -import Kind ( Kind(..) ) -import TypeRep ( TyThing(..), Type(..), PredType(..), ThetaType ) +import Type ( Kind ) +import Coercion ( Coercion ) +import TypeRep ( TyThing(..), Type(..), PredType(..), ThetaType, + unliftedTypeKindTyConName, openTypeKindTyConName, + ubxTupleKindTyConName, argTypeKindTyConName, + liftedTypeKindTyConName, isLiftedTypeKind ) import TyCon ( TyCon, isTupleTyCon, tyConArity, tupleTyConBoxity, tyConName ) import Var ( isId, tyVarKind, idType ) import TysWiredIn ( listTyConName, parrTyConName, tupleTyCon, intTyConName, charTyConName, boolTyConName ) @@ -99,7 +103,9 @@ type IfaceIdBndr = (FastString, IfaceType) type IfaceTvBndr = (FastString, IfaceKind) ------------------------------- -type IfaceKind = Kind -- Re-use the Kind type, but no KindVars in it +type IfaceKind = IfaceType -- Re-use the Kind type, but no KindVars in it + +type IfaceCoercion = IfaceType data IfaceType = IfaceTyVar FastString -- Type variable only, not tycon @@ -113,6 +119,7 @@ data IfaceType data IfacePredType -- NewTypes are handled as ordinary TyConApps = IfaceClassP IfaceExtName [IfaceType] | IfaceIParam (IPName OccName) IfaceType + | IfaceEqPred IfaceType IfaceType type IfaceContext = [IfacePredType] @@ -121,6 +128,8 @@ data IfaceTyCon -- Abbreviations for common tycons with known names | IfaceIntTc | IfaceBoolTc | IfaceCharTc | IfaceListTc | IfacePArrTc | IfaceTupTc Boxity Arity + | IfaceLiftedTypeKindTc | IfaceOpenTypeKindTc | IfaceUnliftedTypeKindTc + | IfaceUbxTupleKindTc | IfaceArgTypeKindTc ifaceTyConName :: IfaceTyCon -> Name -- Works for all except IfaceTc ifaceTyConName IfaceIntTc = intTyConName @@ -129,7 +138,14 @@ ifaceTyConName IfaceCharTc = charTyConName ifaceTyConName IfaceListTc = listTyConName ifaceTyConName IfacePArrTc = parrTyConName ifaceTyConName (IfaceTupTc bx ar) = getName (tupleTyCon bx ar) +ifaceTyConName IfaceLiftedTypeKindTc = liftedTypeKindTyConName +ifaceTyConName IfaceOpenTypeKindTc = openTypeKindTyConName +ifaceTyConName IfaceUnliftedTypeKindTc = unliftedTypeKindTyConName +ifaceTyConName IfaceUbxTupleKindTc = ubxTupleKindTyConName +ifaceTyConName IfaceArgTypeKindTc = argTypeKindTyConName ifaceTyConName (IfaceTc ext) = pprPanic "ifaceTyConName" (ppr ext) + + \end{code} @@ -211,9 +227,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} @@ -289,6 +305,7 @@ 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) <+> sep (map pprParendIfaceType ts) @@ -318,7 +335,7 @@ pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") \begin{code} ---------------- -toIfaceTvBndr tyvar = (occNameFS (getOccName tyvar), tyVarKind tyvar) +toIfaceTvBndr tyvar = (occNameFS (getOccName tyvar), toIfaceKind (tyVarKind tyvar)) toIfaceIdBndr ext id = (occNameFS (getOccName id), toIfaceType ext (idType id)) toIfaceTvBndrs tyvars = map toIfaceTvBndr tyvars @@ -326,6 +343,9 @@ toIfaceBndr ext var | isId var = IfaceIdBndr (toIfaceIdBndr ext var) | otherwise = IfaceTvBndr (toIfaceTvBndr var) +-- we had better not have to use ext for kinds +toIfaceKind = toIfaceType (\name -> pprPanic "toIfaceKind ext used on:" (ppr name)) + --------------------- toIfaceType :: (Name -> IfaceExtName) -> Type -> IfaceType -- Synonyms are retained in the interface type @@ -359,20 +379,26 @@ toIfaceTyCon_name 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) + | 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 (ext nm) ---------------- toIfaceTypes ext ts = map (toIfaceType ext) 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 ext (ClassP cls ts) = IfaceClassP (ext (getName cls)) (toIfaceTypes ext ts) +toIfacePred ext (IParam ip t) = IfaceIParam (mapIPName getOccName ip) (toIfaceType ext t) +toIfacePred ext (EqPred ty1 ty2) = IfaceEqPred (toIfaceType ext ty1) (toIfaceType ext ty2) ---------------- toIfaceContext :: (Name -> IfaceExtName) -> ThetaType -> IfaceContext -- 1.7.10.4