summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/prelude/PrelNames.lhs8
-rw-r--r--compiler/prelude/TysPrim.lhs7
-rw-r--r--compiler/prelude/TysWiredIn.lhs29
-rw-r--r--compiler/prelude/TysWiredIn.lhs-boot1
-rw-r--r--compiler/typecheck/TcHsType.lhs15
-rw-r--r--compiler/types/Kind.lhs1
-rw-r--r--compiler/types/Type.lhs2
7 files changed, 41 insertions, 22 deletions
diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 439430959e..c763b70385 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 8c8b4b7bf3..8b9cbf9ac2 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 4b05e0efb0..942f102bc7 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 9740c0ae38..65c03c8e17 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 c8ce732c6a..200d74eda0 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 dbd131fcc6..aa99aacd29 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 f741078058..3fc1cefe81 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 )
View Lorry Controller Status