Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/aad93f5c9eb9d53cddf85019192ba0da6004d17e >--------------------------------------------------------------- commit aad93f5c9eb9d53cddf85019192ba0da6004d17e Author: Simon Peyton Jones <simo...@microsoft.com> Date: Wed Dec 19 17:35:51 2012 +0000 Move the kind Nat and Symbol out of TysPrim and into TysWiredIn They properly belong in TysWiredIn, since they are defined in Haskell in GHC.TypeLits. Moveover, make them WiredIn (again as they should be) and use checkWiredInTyCon when encountering them in TcHsType.tc_hs_type, so that the interface file is loaded. This fixes Trac #7502. >--------------------------------------------------------------- compiler/prelude/PrelNames.lhs | 8 +------- compiler/prelude/TysPrim.lhs | 7 ------- compiler/prelude/TysWiredIn.lhs | 29 +++++++++++++++++++++++++++++ compiler/prelude/TysWiredIn.lhs-boot | 1 + compiler/typecheck/TcHsType.lhs | 15 +++++++++------ compiler/types/Kind.lhs | 1 - compiler/types/Type.lhs | 2 +- 7 files changed, 41 insertions(+), 22 deletions(-) diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 4394309..c763b70 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -281,8 +281,6 @@ basicKnownKeyNames randomClassName, randomGenClassName, monadPlusClassName, -- Type-level naturals - typeNatKindConName, - typeStringKindConName, singIClassName, typeNatLeqClassName, typeNatAddTyFamName, @@ -1089,12 +1087,8 @@ randomGenClassName = clsQual rANDOM (fsLit "RandomGen") randomGenClassKey isStringClassName = clsQual dATA_STRING (fsLit "IsString") isStringClassKey -- Type-level naturals -typeNatKindConName, typeStringKindConName, - singIClassName, typeNatLeqClassName, +singIClassName, typeNatLeqClassName, typeNatAddTyFamName, typeNatMulTyFamName, typeNatExpTyFamName :: Name -typeNatKindConName = tcQual gHC_TYPELITS (fsLit "Nat") typeNatKindConNameKey -typeStringKindConName = tcQual gHC_TYPELITS (fsLit "Symbol") - typeStringKindConNameKey singIClassName = clsQual gHC_TYPELITS (fsLit "SingI") singIClassNameKey typeNatLeqClassName = clsQual gHC_TYPELITS (fsLit "<=") typeNatLeqClassNameKey typeNatAddTyFamName = tcQual gHC_TYPELITS (fsLit "+") typeNatAddTyFamNameKey diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs index 8c8b4b7..8b9cbf9 100644 --- a/compiler/prelude/TysPrim.lhs +++ b/compiler/prelude/TysPrim.lhs @@ -34,7 +34,6 @@ module TysPrim( -- Kinds anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, constraintKind, mkArrowKind, mkArrowKinds, - typeNatKind, typeStringKind, funTyCon, funTyConName, primTyCons, @@ -344,12 +343,6 @@ unliftedTypeKind = kindTyConType unliftedTypeKindTyCon openTypeKind = kindTyConType openTypeKindTyCon constraintKind = kindTyConType constraintKindTyCon -typeNatKind :: Kind -typeNatKind = kindTyConType (mkKindTyCon typeNatKindConName superKind) - -typeStringKind :: Kind -typeStringKind = kindTyConType (mkKindTyCon typeStringKindConName superKind) - -- | Given two kinds @k1@ and @k2@, creates the 'Kind' @k1 -> k2@ mkArrowKind :: Kind -> Kind -> Kind mkArrowKind k1 k2 = FunTy k1 k2 diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index 4b05e0e..942f102 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -64,6 +64,9 @@ module TysWiredIn ( -- * Unit unitTy, + -- * Kinds + typeNatKindCon, typeNatKind, typeStringKindCon, typeStringKind, + -- * Parallel arrays mkPArrTy, parrTyCon, parrFakeCon, isPArrTyCon, isPArrFakeCon, @@ -148,6 +151,8 @@ wiredInTyCons = [ unitTyCon -- Not treated like other tuples, because , listTyCon , parrTyCon , eqTyCon + , typeNatKindCon + , typeStringKindCon ] ++ (case cIntegerLibraryType of IntegerGMP -> [integerTyCon] @@ -193,6 +198,11 @@ floatDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "F#") floa doubleTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Double") doubleTyConKey doubleTyCon doubleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "D#") doubleDataConKey doubleDataCon +-- Kinds +typeNatKindConName, typeStringKindConName :: Name +typeNatKindConName = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "Nat") typeNatKindConNameKey typeNatKindCon +typeStringKindConName = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "Symbol") typeStringKindConNameKey typeStringKindCon + -- For integer-gmp only: integerRealTyConName :: Name integerRealTyConName = case cIntegerLibraryType of @@ -290,6 +300,25 @@ pcDataConWithFixity' declared_infix dc_name wrk_key tyvars arg_tys tycon %************************************************************************ %* * + Kinds +%* * +%************************************************************************ + +\begin{code} +typeNatKindCon, typeStringKindCon :: TyCon +-- data Nat +-- data Symbol +typeNatKindCon = pcNonRecDataTyCon typeNatKindConName Nothing [] [] +typeStringKindCon = pcNonRecDataTyCon typeStringKindConName Nothing [] [] + +typeNatKind, typeStringKind :: Kind +typeNatKind = TyConApp (promoteTyCon typeNatKindCon) [] +typeStringKind = TyConApp (promoteTyCon typeStringKindCon) [] +\end{code} + + +%************************************************************************ +%* * \subsection[TysWiredIn-tuples]{The tuple types} %* * %************************************************************************ diff --git a/compiler/prelude/TysWiredIn.lhs-boot b/compiler/prelude/TysWiredIn.lhs-boot index 9740c0a..65c03c8 100644 --- a/compiler/prelude/TysWiredIn.lhs-boot +++ b/compiler/prelude/TysWiredIn.lhs-boot @@ -6,5 +6,6 @@ import {-# SOURCE #-} TypeRep (Type) eqTyCon :: TyCon +typeNatKind, typeStringKind :: Type mkBoxedTupleTy :: [Type] -> Type \end{code} diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index c8ce732..200d74e 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -504,12 +504,15 @@ tc_hs_type ty@(HsSpliceTy {}) _exp_kind tc_hs_type (HsWrapTy {}) _exp_kind = panic "tc_hs_type HsWrapTy" -- We kind checked something twice -tc_hs_type hs_ty@(HsTyLit tl) exp_kind = do - let (ty,k) = case tl of - HsNumTy n -> (mkNumLitTy n, typeNatKind) - HsStrTy s -> (mkStrLitTy s, typeStringKind) - checkExpectedKind hs_ty k exp_kind - return ty +tc_hs_type hs_ty@(HsTyLit (HsNumTy n)) exp_kind + = do { checkExpectedKind hs_ty typeNatKind exp_kind + ; checkWiredInTyCon typeNatKindCon + ; return (mkNumLitTy n) } + +tc_hs_type hs_ty@(HsTyLit (HsStrTy s)) exp_kind + = do { checkExpectedKind hs_ty typeStringKind exp_kind + ; checkWiredInTyCon typeStringKindCon + ; return (mkStrLitTy s) } --------------------------- tc_tuple :: HsType Name -> HsTupleSort -> [LHsType Name] -> ExpKind -> TcM TcType diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs index dbd131f..aa99aac 100644 --- a/compiler/types/Kind.lhs +++ b/compiler/types/Kind.lhs @@ -17,7 +17,6 @@ module Kind ( -- Kinds anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, constraintKind, mkArrowKind, mkArrowKinds, - typeNatKind, typeStringKind, -- Kind constructors... anyKindTyCon, liftedTypeKindTyCon, openTypeKindTyCon, diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index f741078..3fc1cef 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -152,7 +152,7 @@ import VarSet import Class import TyCon import TysPrim -import {-# SOURCE #-} TysWiredIn ( eqTyCon ) +import {-# SOURCE #-} TysWiredIn ( eqTyCon, typeNatKind, typeStringKind ) import PrelNames ( eqTyConKey, ipClassNameKey, constraintKindTyConKey, liftedTypeKindTyConKey ) _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
