From fc6e8220115637e4610ef4ac1c0aa55fe4ca529f Mon Sep 17 00:00:00 2001 From: simonpj Date: Fri, 1 Oct 2004 16:39:39 +0000 Subject: [PATCH] [project @ 2004-10-01 16:39:26 by simonpj] Allow kind signatures in GADT data type declarations --- ghc/compiler/hsSyn/Convert.lhs | 8 ++++---- ghc/compiler/hsSyn/HsDecls.lhs | 14 ++++++++++++-- ghc/compiler/parser/Parser.y.pp | 22 +++++++++++++--------- ghc/compiler/parser/ParserCore.y | 4 ++-- ghc/compiler/parser/RdrHsSyn.lhs | 4 ++-- ghc/compiler/rename/RnSource.lhs | 10 ++++++---- ghc/compiler/typecheck/TcTyClsDecls.lhs | 8 +++++++- 7 files changed, 46 insertions(+), 24 deletions(-) diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs index e709d4d..af3350c 100644 --- a/ghc/compiler/hsSyn/Convert.lhs +++ b/ghc/compiler/hsSyn/Convert.lhs @@ -78,14 +78,14 @@ cvt_top (TySynD tc tvs rhs) cvt_top (DataD ctxt tc tvs constrs derivs) = Left $ TyClD (mkTyData DataType - (cvt_context ctxt, noLoc (tconName tc), cvt_tvs tvs) - (map mk_con constrs) + (noLoc (cvt_context ctxt, noLoc (tconName tc), cvt_tvs tvs)) + Nothing (map mk_con constrs) (mk_derivs derivs)) cvt_top (NewtypeD ctxt tc tvs constr derivs) = Left $ TyClD (mkTyData NewType - (cvt_context ctxt, noLoc (tconName tc), cvt_tvs tvs) - [mk_con constr] + (noLoc (cvt_context ctxt, noLoc (tconName tc), cvt_tvs tvs)) + Nothing [mk_con constr] (mk_derivs derivs)) cvt_top (ClassD ctxt cl tvs decs) diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 4b1b028..981c70a 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -36,6 +36,7 @@ import HsImpExp ( pprHsVar ) import HsTypes import HscTypes ( DeprecTxt ) import CoreSyn ( RuleName ) +import Kind ( Kind, pprKind ) import BasicTypes ( Activation(..) ) import ForeignCall ( CCallTarget(..), DNCallSpec, CCallConv, Safety, CExportSpec(..), CLabelString ) @@ -302,7 +303,13 @@ data TyClDecl name tcdCtxt :: LHsContext name, -- Context tcdLName :: Located name, -- Type constructor tcdTyVars :: [LHsTyVarBndr name], -- Type variables + tcdKindSig :: Maybe Kind, -- Optional kind sig; + -- (only for the 'where' form) + tcdCons :: [LConDecl name], -- Data constructors + -- For data T a = T1 | T2 a the LConDecls are all ConDecls + -- For data T a where { T1 :: T a } the LConDecls are all GadtDecls + tcdDerivs :: Maybe [LHsType name] -- Derivings; Nothing => not specified -- Just [] => derive exactly what is asked @@ -401,11 +408,14 @@ instance OutputableBndr name 4 (ppr mono_ty) ppr (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = ltycon, - tcdTyVars = tyvars, tcdCons = condecls, + tcdTyVars = tyvars, tcdKindSig = mb_sig, tcdCons = condecls, tcdDerivs = derivings}) - = pp_tydecl (ppr new_or_data <+> pp_decl_head (unLoc context) ltycon tyvars) + = pp_tydecl (ppr new_or_data <+> pp_decl_head (unLoc context) ltycon tyvars <+> ppr_sig mb_sig) (pp_condecls condecls) derivings + where + ppr_sig Nothing = empty + ppr_sig (Just kind) = dcolon <+> pprKind kind ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, tcdMeths = methods}) diff --git a/ghc/compiler/parser/Parser.y.pp b/ghc/compiler/parser/Parser.y.pp index 058f582..0d8b974 100644 --- a/ghc/compiler/parser/Parser.y.pp +++ b/ghc/compiler/parser/Parser.y.pp @@ -332,13 +332,13 @@ ifacedecl :: { HsDecl RdrName } | 'type' syn_hdr '=' ctype { let (tc,tvs) = $2 in TyClD (TySynonym tc tvs $4) } | 'data' tycl_hdr constrs -- No deriving in hi-boot - { TyClD (mkTyData DataType (unLoc $2) (reverse (unLoc $3)) Nothing) } + { TyClD (mkTyData DataType $2 Nothing (reverse (unLoc $3)) Nothing) } | 'data' tycl_hdr 'where' gadt_constrlist - { TyClD (mkTyData DataType (unLoc $2) (reverse (unLoc $4)) Nothing) } + { TyClD (mkTyData DataType $2 Nothing (reverse (unLoc $4)) Nothing) } | 'newtype' tycl_hdr -- Constructor is optional - { TyClD (mkTyData NewType (unLoc $2) [] Nothing) } + { TyClD (mkTyData NewType $2 Nothing [] Nothing) } | 'newtype' tycl_hdr '=' newconstr - { TyClD (mkTyData NewType (unLoc $2) [$4] Nothing) } + { TyClD (mkTyData NewType $2 Nothing [$4] Nothing) } | 'class' tycl_hdr fds { TyClD (mkClassDecl (unLoc $2) (unLoc $3) [] emptyBag) } @@ -455,15 +455,15 @@ tycl_decl :: { LTyClDecl RdrName } | 'data' tycl_hdr constrs deriving { L (comb4 $1 $2 $3 $4) - (mkTyData DataType (unLoc $2) (reverse (unLoc $3)) (unLoc $4)) } + (mkTyData DataType $2 Nothing (reverse (unLoc $3)) (unLoc $4)) } - | 'data' tycl_hdr 'where' gadt_constrlist -- No deriving for GADTs - { L (comb4 $1 $2 $3 $4) - (mkTyData DataType (unLoc $2) (reverse (unLoc $4)) Nothing) } + | 'data' tycl_hdr opt_kind_sig 'where' gadt_constrlist -- No deriving for GADTs + { L (comb4 $1 $2 $4 $5) + (mkTyData DataType $2 $3 (reverse (unLoc $5)) Nothing) } | 'newtype' tycl_hdr '=' newconstr deriving { L (comb3 $1 $4 $5) - (mkTyData NewType (unLoc $2) [$4] (unLoc $5)) } + (mkTyData NewType $2 Nothing [$4] (unLoc $5)) } | 'class' tycl_hdr fds where { let @@ -472,6 +472,10 @@ tycl_decl :: { LTyClDecl RdrName } L (comb4 $1 $2 $3 $4) (mkClassDecl (unLoc $2) (unLoc $3) sigs binds) } +opt_kind_sig :: { Maybe Kind } + : { Nothing } + | '::' kind { Just $2 } + syn_hdr :: { (Located RdrName, [LHsTyVarBndr RdrName]) } -- We don't retain the syntax of an infix -- type synonym declaration. Oh well. diff --git a/ghc/compiler/parser/ParserCore.y b/ghc/compiler/parser/ParserCore.y index c777137..75f7b1b 100644 --- a/ghc/compiler/parser/ParserCore.y +++ b/ghc/compiler/parser/ParserCore.y @@ -84,10 +84,10 @@ tdefs :: { [TyClDecl RdrName] } tdef :: { TyClDecl RdrName } : '%data' q_tc_name tv_bndrs '=' '{' cons1 '}' - { mkTyData DataType (noLoc [], noLoc (ifaceExtRdrName $2), map toHsTvBndr $3) $6 Nothing } + { mkTyData DataType (noLoc (noLoc [], noLoc (ifaceExtRdrName $2), map toHsTvBndr $3)) Nothing $6 Nothing } | '%newtype' q_tc_name tv_bndrs trep { let tc_rdr = ifaceExtRdrName $2 in - mkTyData NewType (noLoc [], noLoc tc_rdr, map toHsTvBndr $3) ($4 (rdrNameOcc tc_rdr)) Nothing } + mkTyData NewType (noLoc (noLoc [], noLoc tc_rdr, map toHsTvBndr $3)) Nothing ($4 (rdrNameOcc tc_rdr)) Nothing } -- For a newtype we have to invent a fake data constructor name -- It doesn't matter what it is, because it won't be used diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index c9c59cc..d99908d 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -164,10 +164,10 @@ mkClassDecl (cxt, cname, tyvars) fds sigs mbinds tcdMeths = mbinds } -mkTyData new_or_data (context, tname, tyvars) data_cons maybe +mkTyData new_or_data (L _ (context, tname, tyvars)) ksig data_cons maybe_deriv = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname, tcdTyVars = tyvars, tcdCons = data_cons, - tcdDerivs = maybe } + tcdKindSig = ksig, tcdDerivs = maybe_deriv } \end{code} \begin{code} diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 7d3d308..1439531 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -487,16 +487,18 @@ rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_ rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon, tcdTyVars = tyvars, tcdCons = condecls, - tcdDerivs = derivs}) + tcdKindSig = sig, tcdDerivs = derivs}) | is_vanilla -- Normal Haskell data type decl - = bindTyVarsRn data_doc tyvars $ \ tyvars' -> + = ASSERT( isNothing sig ) -- In normal H98 form, kind signature on the + -- data type is syntactically illegal + bindTyVarsRn data_doc tyvars $ \ tyvars' -> do { tycon' <- lookupLocatedTopBndrRn tycon ; context' <- rnContext data_doc context ; (derivs', deriv_fvs) <- rn_derivs derivs ; checkDupNames data_doc con_names ; condecls' <- rnConDecls (unLoc tycon') condecls ; returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdLName = tycon', - tcdTyVars = tyvars', tcdCons = condecls', + tcdTyVars = tyvars', tcdKindSig = Nothing, tcdCons = condecls', tcdDerivs = derivs'}, delFVs (map hsLTyVarName tyvars') $ extractHsCtxtTyNames context' `plusFV` @@ -515,7 +517,7 @@ rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon, ; checkDupNames data_doc con_names ; condecls' <- rnConDecls (unLoc tycon') condecls ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], tcdLName = tycon', - tcdTyVars = tyvars', tcdCons = condecls', + tcdTyVars = tyvars', tcdCons = condecls', tcdKindSig = sig, tcdDerivs = derivs'}, plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs) } diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 120e6f8..295b259 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -322,8 +322,14 @@ kcTyClDeclBody decl thing_inside do { tc_ty_thing <- tcLookupLocated (tcdLName decl) ; let tc_kind = case tc_ty_thing of { AThing k -> k } ; unifyKind tc_kind (foldr (mkArrowKind . kindedTyVarKind) - liftedTypeKind kinded_tvs) + (result_kind decl) + kinded_tvs) ; thing_inside kinded_tvs } + where + result_kind (TyData { tcdKindSig = Just kind }) = kind + result_kind other = liftedTypeKind + -- On GADT-style declarations we allow a kind signature + -- data T :: *->* where { ... } kindedTyVarKind (L _ (KindedTyVar _ k)) = k \end{code} -- 1.7.10.4