Commit aad93f5c authored by Simon Peyton Jones's avatar Simon Peyton Jones

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.
parent 8c1aab0d
......@@ -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
......
......@@ -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
......
......@@ -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
......@@ -288,6 +298,25 @@ pcDataConWithFixity' declared_infix dc_name wrk_key tyvars arg_tys tycon
\end{code}
%************************************************************************
%* *
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}
......
......@@ -6,5 +6,6 @@ import {-# SOURCE #-} TypeRep (Type)
eqTyCon :: TyCon
typeNatKind, typeStringKind :: Type
mkBoxedTupleTy :: [Type] -> Type
\end{code}
......@@ -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
......
......@@ -17,7 +17,6 @@ module Kind (
-- Kinds
anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, constraintKind,
mkArrowKind, mkArrowKinds,
typeNatKind, typeStringKind,
-- Kind constructors...
anyKindTyCon, liftedTypeKindTyCon, openTypeKindTyCon,
......
......@@ -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 )
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment