Commit e6d89fbd authored by simonpj's avatar simonpj
Browse files

[project @ 2004-12-03 13:49:00 by simonpj]

A fix to kind signatures for GADT data type decls
parent 6601043c
......@@ -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}
......
......@@ -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
-------------------------------
......
......@@ -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,
......
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