Skip to content

GitLab

Commit fc6e8220 authored by simonpj's avatar simonpj
Browse files

[project @ 2004-10-01 16:39:26 by simonpj] 

Allow kind signatures in GADT data type declarations
parent 356b0d0f
Hide whitespace changes
Inline Side-by-side
ghc/compiler/hsSyn/Convert.lhs
View file @ fc6e8220
......@@ -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)
......
ghc/compiler/hsSyn/HsDecls.lhs
View file @ fc6e8220
......@@ -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})
......
ghc/compiler/parser/Parser.y.pp
View file @ fc6e8220
......@@ -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.
......
ghc/compiler/parser/ParserCore.y
View file @ fc6e8220
......@@ -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
......
ghc/compiler/parser/RdrHsSyn.lhs
View file @ fc6e8220
......@@ -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}
......
ghc/compiler/rename/RnSource.lhs
View file @ fc6e8220
......@@ -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) }
......
ghc/compiler/typecheck/TcTyClsDecls.lhs
View file @ fc6e8220
......@@ -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}
......
Supports Markdown
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