From e6d89fbd617bbdd60544c752835c2e1f8d146b57 Mon Sep 17 00:00:00 2001 From: simonpj Date: Fri, 3 Dec 2004 13:49:05 +0000 Subject: [PATCH] [project @ 2004-12-03 13:49:00 by simonpj] A fix to kind signatures for GADT data type decls --- ghc/compiler/typecheck/TcHsType.lhs | 48 ++++++++++++++++++++++++------- ghc/compiler/typecheck/TcTyClsDecls.lhs | 22 +++++++------- ghc/compiler/types/TyCon.lhs | 4 +-- 3 files changed, 52 insertions(+), 22 deletions(-) diff --git a/ghc/compiler/typecheck/TcHsType.lhs b/ghc/compiler/typecheck/TcHsType.lhs index 08effa7..21b9b48 100644 --- a/ghc/compiler/typecheck/TcHsType.lhs +++ b/ghc/compiler/typecheck/TcHsType.lhs @@ -14,7 +14,7 @@ module TcHsType ( -- Typechecking kinded types tcHsKindedContext, tcHsKindedType, tcHsBangType, - tcTyVarBndrs, dsHsType, tcLHsConSig, + tcTyVarBndrs, dsHsType, tcLHsConSig, tcDataKindSig, tcHsPatSigType, tcAddLetBoundTyVars, @@ -28,13 +28,10 @@ import HsSyn ( HsType(..), LHsType, HsTyVarBndr(..), LHsTyVarBndr, HsBang, LHsContext, HsPred(..), LHsPred, LHsBinds, getBangStrictness, collectSigTysFromHsBinds ) import RnHsSyn ( extractHsTyVars ) -import TcHsSyn ( TcId ) - import TcRnMonad import TcEnv ( tcExtendTyVarEnv, tcExtendKindEnv, tcLookup, tcLookupClass, tcLookupTyCon, - TyThing(..), TcTyThing(..), - getInLocalScope, wrongThingErr + TyThing(..), getInLocalScope, wrongThingErr ) import TcMType ( newKindVar, tcSkolType, newMetaTyVar, zonkTcKindToKind, @@ -48,21 +45,22 @@ import TcType ( Type, PredType(..), ThetaType, mkForAllTys, mkFunTys, tcEqType, isPredTy, mkSigmaTy, mkPredTy, mkGenTyConApp, mkTyConApp, mkAppTys, tcSplitFunTy_maybe, tcSplitForAllTys ) -import Kind ( liftedTypeKind, ubxTupleKind, openTypeKind, argTypeKind ) -import Inst ( InstOrigin(..) ) - +import Kind ( Kind, isLiftedTypeKind, liftedTypeKind, ubxTupleKind, + openTypeKind, argTypeKind, splitKindFunTys ) import Id ( idName, idType ) import Var ( TyVar, mkTyVar, tyVarKind ) import TyCon ( TyCon, tyConKind ) import Class ( Class, classTyCon ) -import Name ( Name ) +import Name ( Name, mkInternalName ) +import OccName ( mkOccName, tvName ) import NameSet import PrelNames ( genUnitTyConName ) import Type ( deShadowTy ) import TysWiredIn ( mkListTy, mkPArrTy, mkTupleTy ) import Bag ( bagToList ) import BasicTypes ( Boxity(..) ) -import SrcLoc ( Located(..), unLoc, noLoc ) +import SrcLoc ( Located(..), unLoc, noLoc, srcSpanStart ) +import UniqSupply ( uniqsFromSupply ) import Outputable import List ( nubBy ) \end{code} @@ -618,6 +616,36 @@ tcTyVarBndrs bndrs thing_inside returnM (mkTyVar name kind') zonk (UserTyVar name) = pprTrace "Un-kinded tyvar" (ppr name) $ returnM (mkTyVar name liftedTypeKind) + +----------------------------------- +tcDataKindSig :: Maybe Kind -> TcM [TyVar] +-- GADT decls can have a (perhpas partial) kind signature +-- e.g. data T :: * -> * -> * where ... +-- This function makes up suitable (kinded) type variables for +-- the argument kinds, and checks that the result kind is indeed * +tcDataKindSig Nothing = return [] +tcDataKindSig (Just kind) + = do { checkTc (isLiftedTypeKind res_kind) (badKindSig kind) + ; span <- getSrcSpanM + ; us <- newUniqueSupply + ; let loc = srcSpanStart span + uniqs = uniqsFromSupply us + ; return [ mk_tv loc uniq str kind + | ((kind, str), uniq) <- arg_kinds `zip` names `zip` uniqs ] } + where + (arg_kinds, res_kind) = splitKindFunTys kind + mk_tv loc uniq str kind = mkTyVar name kind + where + name = mkInternalName uniq occ loc + occ = mkOccName tvName str + + names :: [String] -- a,b,c...aa,ab,ac etc + names = [ c:cs | cs <- "" : names, c <- ['a'..'z'] ] + +badKindSig :: Kind -> SDoc +badKindSig kind + = hang (ptext SLIT("Kind signature on data type declaration has non-* return kind")) + 2 (ppr kind) \end{code} diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 3e72f0e..b008bbe 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -21,7 +21,7 @@ import HscTypes ( implicitTyThings ) import BuildTyCl ( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon, mkDataTyConRhs, mkNewTyConRhs ) import TcRnMonad -import TcEnv ( TcTyThing(..), TyThing(..), +import TcEnv ( TyThing(..), tcLookupLocated, tcLookupLocatedGlobal, tcExtendGlobalEnv, tcExtendKindEnv, tcExtendRecEnv, tcLookupTyVar ) @@ -29,7 +29,7 @@ import TcTyDecls ( calcTyConArgVrcs, calcRecFlags, calcClassCycles, calcSynCycle import TcClassDcl ( tcClassSigs, tcAddDeclCtxt ) import TcHsType ( kcHsTyVars, kcHsLiftedSigType, kcHsType, kcHsContext, tcTyVarBndrs, tcHsKindedType, tcHsKindedContext, - kcHsSigType, tcHsBangType, tcLHsConSig ) + kcHsSigType, tcHsBangType, tcLHsConSig, tcDataKindSig ) import TcMType ( newKindVar, checkValidTheta, checkValidType, checkFreeness, UserTypeCtxt(..), SourceTyCtxt(..) ) import TcUnify ( unifyKind ) @@ -41,7 +41,7 @@ import Generics ( validGenericMethodType, canDoGenerics ) import Class ( Class, className, classTyCon, DefMeth(..), classBigSig, classTyVars ) import TyCon ( TyCon, ArgVrcs, tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon, - tyConStupidTheta, getSynTyConDefn, tyConDataCons, isSynTyCon, tyConName ) + tyConStupidTheta, getSynTyConDefn, isSynTyCon, tyConName ) import DataCon ( DataCon, dataConWrapId, dataConName, dataConSig, dataConFieldLabels, dataConOrigArgTys, dataConTyCon ) import Type ( zipTopTvSubst, substTys ) @@ -328,7 +328,7 @@ kcTyClDeclBody decl thing_inside ; thing_inside kinded_tvs } where result_kind (TyData { tcdKindSig = Just kind }) = kind - result_kind other = liftedTypeKind + result_kind other = liftedTypeKind -- On GADT-style declarations we allow a kind signature -- data T :: *->* where { ... } @@ -366,21 +366,23 @@ tcTyClDecl calc_vrcs calc_isrec decl tcTyClDecl1 calc_vrcs calc_isrec (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs, - tcdLName = L _ tc_name, tcdCons = cons}) - = tcTyVarBndrs tvs $ \ tvs' -> do - { stupid_theta <- tcStupidTheta ctxt cons + tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons}) + = tcTyVarBndrs tvs $ \ tvs' -> do + { extra_tvs <- tcDataKindSig mb_ksig + ; let final_tvs = tvs' ++ extra_tvs + ; stupid_theta <- tcStupidTheta ctxt cons ; want_generic <- doptM Opt_Generics ; tycon <- fixM (\ tycon -> do { unbox_strict <- doptM Opt_UnboxStrictFields ; gla_exts <- doptM Opt_GlasgowExts ; checkTc (gla_exts || h98_syntax) (badGadtDecl tc_name) - ; data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data tycon tvs')) cons + ; data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data tycon final_tvs)) cons ; let tc_rhs = case new_or_data of DataType -> mkDataTyConRhs stupid_theta data_cons NewType -> ASSERT( isSingleton data_cons ) mkNewTyConRhs tycon (head data_cons) - ; buildAlgTyCon tc_name tvs' tc_rhs arg_vrcs is_rec + ; buildAlgTyCon tc_name final_tvs tc_rhs arg_vrcs is_rec (want_generic && canDoGenerics data_cons) }) ; return (ATyCon tycon) @@ -612,7 +614,7 @@ checkValidDataCon tc con -- ; checkFreeness tvs ex_theta } where ctxt = ConArgCtxt (dataConName con) - (tvs, ex_theta, _, _, _) = dataConSig con +-- (tvs, ex_theta, _, _, _) = dataConSig con ------------------------------- diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index 3c7206b..9fad373 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -91,8 +91,8 @@ data TyCon tyConKind :: Kind, tyConArity :: Arity, - tyConTyVars :: [TyVar], -- Scopes over (a) the [PredType] in DataTyCon - -- (b) the cached types in NewTyCon + tyConTyVars :: [TyVar], -- Scopes over (a) the [PredType] in AlgTyConRhs.DataTyCon + -- (b) the cached types in AlgTyConRhs.NewTyCon -- (c) the types in algTcFields -- But not over the data constructors argVrcs :: ArgVrcs, -- 1.7.10.4