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

Allow kind signatures in GADT data type declarations

diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs
index e709d4d..af3350c 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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}