From 1e3348f855578fc60ed52fa62bb4846798a5cd3e Mon Sep 17 00:00:00 2001 From: Adam Megacz Date: Sun, 8 May 2011 23:31:17 -0700 Subject: [PATCH] update compiler using *->*->* as the kind of environment classifiers --- compiler/hetmet | 2 +- compiler/prelude/TysPrim.lhs | 6 +++++- compiler/prelude/TysWiredIn.lhs | 4 +++- compiler/typecheck/TcExpr.lhs | 2 +- compiler/types/TypeRep.lhs | 7 +++++-- libraries/base | 2 +- 6 files changed, 16 insertions(+), 7 deletions(-) diff --git a/compiler/hetmet b/compiler/hetmet index cb42497..4ad68fe 160000 --- a/compiler/hetmet +++ b/compiler/hetmet @@ -1 +1 @@ -Subproject commit cb424978e057bc2b4868517302738d52246fba04 +Subproject commit 4ad68fe2894b35c21f2feb7b176d2b0f146ff6d3 diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs index ac3a528..a5d9335 100644 --- a/compiler/prelude/TysPrim.lhs +++ b/compiler/prelude/TysPrim.lhs @@ -10,7 +10,7 @@ -- They are all, therefore, wired-in TyCons. C.f module TysWiredIn module TysPrim( alphaTyVars, betaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar, - alphaTy, betaTy, gammaTy, deltaTy, + alphaTy, betaTy, gammaTy, deltaTy, ecTyVars, openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar, openAlphaTyVars, argAlphaTy, argAlphaTyVar, argBetaTy, argBetaTyVar, @@ -58,6 +58,7 @@ import OccName ( mkTcOcc ) import OccName ( mkTyVarOccFS, mkTcOccFS ) import TyCon ( TyCon, mkPrimTyCon, mkLiftedPrimTyCon, mkAnyTyCon ) import Type +import TypeRep ( ecKind ) import Coercion import SrcLoc import Unique ( mkAlphaTyVarUnique ) @@ -158,6 +159,9 @@ tyVarList kind = [ mkTyVar (mkInternalName (mkAlphaTyVarUnique u) where c = chr (u-2 + ord 'a') ] +ecTyVars :: [TyVar] +ecTyVars = tyVarList ecKind + alphaTyVars :: [TyVar] alphaTyVars = tyVarList liftedTypeKind diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index 29fa628..2f1b637 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -633,9 +633,11 @@ Heterogeneous Metaprogramming mkHetMetCodeTypeTy :: TyVar -> Type -> Type mkHetMetCodeTypeTy ecn ty = mkTyConApp hetMetCodeTypeTyCon [(mkTyVarTy ecn), ty] +ecTyVar = head ecTyVars + -- | Represents the type constructor of box types hetMetCodeTypeTyCon :: TyCon -hetMetCodeTypeTyCon = pcNonRecDataTyCon hetMetCodeTypeTyConName [alphaTyVar, betaTyVar] [hetMetCodeTypeDataCon] +hetMetCodeTypeTyCon = pcNonRecDataTyCon hetMetCodeTypeTyConName [ecTyVar, betaTyVar] [hetMetCodeTypeDataCon] -- | Check whether a type constructor is the constructor for box types isHetMetCodeTypeTyCon :: TyCon -> Bool diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 976aca7..7d7c461 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -167,7 +167,7 @@ tcExpr (HsVar name) res_ty = tcCheckId name res_ty tcExpr (HsHetMetBrak _ e) res_ty = do { (coi, [inferred_name,elt_ty]) <- matchExpectedTyConApp hetMetCodeTypeTyCon res_ty - ; fresh_ec_name <- newFlexiTyVar liftedTypeKind + ; fresh_ec_name <- newFlexiTyVar ecKind ; expr' <- updHetMetLevel (\old_lev -> (fresh_ec_name:old_lev)) $ tcPolyExpr e elt_ty ; unifyType (TyVarTy fresh_ec_name) inferred_name diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index 1be55d7..a7cfd5a 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -25,7 +25,7 @@ module TypeRep ( -- Kinds liftedTypeKind, unliftedTypeKind, openTypeKind, - argTypeKind, ubxTupleKind, + argTypeKind, ubxTupleKind, ecKind, isLiftedTypeKindCon, isLiftedTypeKind, mkArrowKind, mkArrowKinds, isCoercionKind, coVarPred, @@ -343,13 +343,16 @@ kindTyConType :: TyCon -> Type kindTyConType kind = TyConApp kind [] -- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's -liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind :: Kind +liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind, ecKind :: Kind liftedTypeKind = kindTyConType liftedTypeKindTyCon unliftedTypeKind = kindTyConType unliftedTypeKindTyCon openTypeKind = kindTyConType openTypeKindTyCon argTypeKind = kindTyConType argTypeKindTyCon ubxTupleKind = kindTyConType ubxTupleKindTyCon +ecKind = liftedTypeKind `mkArrowKind` (liftedTypeKind `mkArrowKind` liftedTypeKind) +-- NOTE: if you change ecKind, you must also change the explicit kind signatures +-- on hetmet_{brak,esc,csp} in GHC.Hetmet.CodeTypes -- | Given two kinds @k1@ and @k2@, creates the 'Kind' @k1 -> k2@ mkArrowKind :: Kind -> Kind -> Kind diff --git a/libraries/base b/libraries/base index e1f4f45..5fb5033 160000 --- a/libraries/base +++ b/libraries/base @@ -1 +1 @@ -Subproject commit e1f4f4560778857133cd778b5bc66c1074add312 +Subproject commit 5fb503378b4f2110ef044404092fdf21be48117e -- 1.7.10.4