[project @ 2002-02-11 15:16:25 by simonpj]

----------------------------------
	Implement kinded type declarations
	----------------------------------

This commit allows the programmer to supply kinds in
	* data decls
	* type decls
	* class decls
	* 'forall's in types

e.g. 	data T (x :: *->*) = MkT

        type Composer c = forall (x :: * -> *) (y :: * -> *) (z :: * -> *).
		          (c y z) -> (c x y) -> (c x z);

This is occasionally useful.

It turned out to be convenient to add the form

	(type :: kind)

to the syntax of types too, so you can put kind signatures in types as well.

diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs
index acdf8fd..3c42629 100644 (file)
--- a/ghc/compiler/hsSyn/HsTypes.lhs
+++ b/ghc/compiler/hsSyn/HsTypes.lhs
@@ -41,7 +41,7 @@ import Name           ( Name, getName )
 import OccName         ( NameSpace, tvName )
 import Var             ( TyVar, tyVarKind )
 import Subst           ( substTyWith )
-import PprType         ( {- instance Outputable Kind -}, pprParendKind )
+import PprType         ( {- instance Outputable Kind -}, pprParendKind, pprKind )
 import BasicTypes      ( Boxity(..), Arity, IPName, tupleParens )
 import PrelNames       ( mkTupConRdrName, listTyConKey, parrTyConKey,
                          usOnceTyConKey, usManyTyConKey, hasKey,
@@ -109,6 +109,9 @@ data HsType name
   -- these next two are only used in interfaces
   | HsPredTy           (HsPred name)
 
+  | HsKindSig          (HsType name)   -- (ty :: kind)
+                       Kind            -- A type with a kind signature
+
 
 -----------------------
 hsUsOnce, hsUsMany :: HsType RdrName
@@ -276,6 +279,7 @@ ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2)
               (sep [p1, (<>) (ptext SLIT("-> ")) p2])
 
 ppr_mono_ty ctxt_prec (HsTupleTy con tys) = hsTupParens con (interpp'SP tys)
+ppr_mono_ty ctxt_prec (HsKindSig ty kind) = parens (ppr_mono_ty pREC_TOP ty <+> dcolon <+> pprKind kind)
 ppr_mono_ty ctxt_prec (HsListTy ty)      = brackets (ppr_mono_ty pREC_TOP ty)
 ppr_mono_ty ctxt_prec (HsPArrTy ty)      = pabrackets (ppr_mono_ty pREC_TOP ty)
   where
@@ -455,6 +459,9 @@ eq_hsType env (HsTupleTy c1 tys1) (HsTupleTy c2 tys2)
 eq_hsType env (HsListTy ty1) (HsListTy ty2)
   = eq_hsType env ty1 ty2
 
+eq_hsType env (HsKindSig ty1 k1) (HsKindSig ty2 k2)
+  = eq_hsType env ty1 ty2 && k1 `eqKind` k2
+
 eq_hsType env (HsPArrTy ty1) (HsPArrTy ty2)
   = eq_hsType env ty1 ty2
 

diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs
index 06fe82f..01fcc3b 100644 (file)
--- a/ghc/compiler/parser/Lex.lhs
+++ b/ghc/compiler/parser/Lex.lhs
@@ -183,6 +183,7 @@ data Token
   | ITdarrow
   | ITminus
   | ITbang
+  | ITstar
   | ITdot
 
   | ITbiglam                   -- GHC-extension symbols
@@ -381,6 +382,7 @@ haskellKeySymsFM = listToUFM $
        ,("=>",         ITdarrow)
        ,("-",          ITminus)
        ,("!",          ITbang)
+       ,("*",          ITstar)
        ,(".",          ITdot)          -- sadly, for 'forall a . t'
        ]
 \end{code}

diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs
index 2ee9664..ca546b8 100644 (file)
--- a/ghc/compiler/parser/ParseUtil.lhs
+++ b/ghc/compiler/parser/ParseUtil.lhs
@@ -113,11 +113,12 @@ checkInstType t
        ty ->   checkDictTy ty [] `thenP` \ dict_ty->
                returnP (HsForAllTy Nothing [] dict_ty)
 
-checkTyVars :: [RdrNameHsTyVar] -> P [RdrNameHsType]
+checkTyVars :: [RdrNameHsType] -> P [RdrNameHsTyVar]
 checkTyVars tvs = mapP chk tvs
                where
-                 chk (UserTyVar tv) = returnP (HsTyVar tv)
-                 chk other          = parseError "Illegal kinded type variable"
+                 chk (HsKindSig (HsTyVar tv) k) = returnP (IfaceTyVar tv k)
+                 chk (HsTyVar tv)               = returnP (UserTyVar tv)
+                 chk other                      = parseError "Type found where type variable expected"
 
 checkContext :: RdrNameHsType -> P RdrNameContext
 checkContext (HsTupleTy _ ts)  -- (Eq a, Ord b) shows up as a tuple type
@@ -131,9 +132,12 @@ checkContext t
     returnP [p]
 
 checkPred :: RdrNameHsType -> P (HsPred RdrName)
+-- Watch out.. in ...deriving( Show )... we use checkPred on 
+-- the list of partially applied predicates in the deriving,
+-- so there can be zero args.
 checkPred (HsPredTy (HsIParam n ty)) = returnP (HsIParam n ty)
-checkPred (HsAppTy l r)
-  = go l [r]
+checkPred ty
+  = go ty []
   where
     go (HsTyVar t) args   | not (isRdrTyVar t) 
                          = returnP (HsClassP t args)

diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y
index c9e2042..e98b1ff 100644 (file)
--- a/ghc/compiler/parser/Parser.y
+++ b/ghc/compiler/parser/Parser.y
@@ -1,6 +1,6 @@
 {-                                                             -*-haskell-*-
 -----------------------------------------------------------------------------
-$Id: Parser.y,v 1.85 2002/02/11 09:27:22 simonpj Exp $
+$Id: Parser.y,v 1.86 2002/02/11 15:16:26 simonpj Exp $
 
 Haskell grammar.
 
@@ -28,6 +28,7 @@ import OccName                ( UserFS, varName, tcName, dataName, tcClsName, tvName )
 import SrcLoc          ( SrcLoc )
 import Module
 import CmdLineOpts     ( opt_SccProfilingOn )
+import Type            ( Kind, mkArrowKind, liftedTypeKind )
 import BasicTypes      ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
                          NewOrData(..), StrictnessMark(..), Activation(..) )
 import Panic
@@ -45,10 +46,14 @@ import Outputable
 -----------------------------------------------------------------------------
 Conflicts: 21 shift/reduce, -=chak[4Feb2]
 
-8 for abiguity in 'if x then y else z + 1'
+9 for abiguity in 'if x then y else z + 1'
        (shift parses as 'if x then y else (z + 1)', as per longest-parse rule)
+       8 because op might be: - ! * . `x` VARSYM CONSYM QVARSYM QCONSYM
 1 for ambiguity in 'if x then y else z :: T'
        (shift parses as 'if x then y else (z :: T)', as per longest-parse rule)
+1 for ambiguity in 'if x then y else z with ?x=3'
+       (shift parses as 'if x then y else (z with ?x=3)'
+
 3 for ambiguity in 'case x of y :: a -> b'
        (don't know whether to reduce 'a' as a btype or shift the '->'.
         conclusion:  bogus expression anyway, doesn't matter)
@@ -166,6 +171,7 @@ Conflicts: 21 shift/reduce, -=chak[4Feb2]
  '=>'          { ITdarrow }
  '-'           { ITminus }
  '!'           { ITbang }
+ '*'           { ITstar }
  '.'           { ITdot }
 
  '{'           { ITocurly }                    -- special symbols
@@ -341,12 +347,13 @@ topdecls :: { [RdrBinding] }
        | topdecl                       { [$1] }
 
 topdecl :: { RdrBinding }
-       : srcloc 'type' simpletype '=' ctype    
+       : srcloc 'type' tycon tv_bndrs '=' ctype        
                -- Note ctype, not sigtype.
                -- We allow an explicit for-all but we don't insert one
                -- in   type Foo a = (b,b)
                -- Instead we just say b is out of scope
-               { RdrHsDecl (TyClD (TySynonym (fst $3) (snd $3) $5 $1)) }
+               { RdrHsDecl (TyClD (TySynonym $3 $4 $6 $1)) }
+
 
        | srcloc 'data' tycl_hdr constrs deriving
                {% returnP (RdrHsDecl (TyClD
@@ -369,7 +376,7 @@ topdecl :: { RdrBinding }
                                (groupBindings $4)
                  in RdrHsDecl (InstD (InstDecl $3 binds sigs Nothing $1)) }
 
-       | srcloc 'default' '(' types0 ')'               { RdrHsDecl (DefD (DefaultDecl $4 $1)) }
+       | srcloc 'default' '(' comma_types0 ')'         { RdrHsDecl (DefD (DefaultDecl $4 $1)) }
        | 'foreign' fdecl                               { RdrHsDecl $2 }
        | '{-# DEPRECATED' deprecations '#-}'           { $2 }
        | '{-# RULES' rules '#-}'                       { $2 }
@@ -382,13 +389,15 @@ topdecl :: { RdrBinding }
 --     (Eq a, Ord b) => T a b
 -- Rather a lot of inlining here, else we get reduce/reduce errors
 tycl_hdr :: { (RdrNameContext, RdrName, [RdrNameHsTyVar]) }
-       : '(' types ')' '=>' tycon tyvars       {% mapP checkPred $2            `thenP` \ cxt ->
-                                                  returnP (cxt, $5, $6) }
-       | tycon tyvars '=>' tycon tyvars        {% checkTyVars $2       `thenP` \ args ->
-                                                  returnP ([HsClassP $1 args], $4, $5) }
-       | qtycon tyvars '=>' tycon tyvars       {% checkTyVars $2       `thenP` \ args ->
-                                                  returnP ([HsClassP $1 args], $4, $5) }
-       | tycon tyvars                          { ([], $1, $2) }
+       : '(' comma_types1 ')' '=>' tycon tv_bndrs      {% mapP checkPred $2    `thenP` \ cxt ->
+                                                          returnP (cxt, $5, $6) }
+       | qtycon atypes1 '=>' tycon atypes0             {% checkTyVars $5       `thenP` \ tvs ->
+                                                          returnP ([HsClassP $1 $2], $4, tvs) }
+       | qtycon  atypes0                               {% checkTyVars $2       `thenP` \ tvs ->
+                                                          returnP ([], $1, tvs) }
+               -- We have to have qtycon in this production to avoid s/r conflicts
+               -- with the previous one.  The renamer will complain if we use
+               -- a qualified tycon.
 
 decls  :: { [RdrBinding] }
        : decls ';' decl                { $3 : $1 }
@@ -642,7 +651,7 @@ sigtypes :: { [RdrNameHsType] }
        | sigtypes ',' sigtype          { $3 : $1 }
 
 sigtype :: { RdrNameHsType }
-       : ctype                         { (mkHsForAllTy Nothing [] $1) }
+       : ctype                         { mkHsForAllTy Nothing [] $1 }
 
 sig_vars :: { [RdrName] }
         : sig_vars ',' var             { $3 : $1 }
@@ -653,7 +662,7 @@ sig_vars :: { [RdrName] }
 
 -- A ctype is a for-all type
 ctype  :: { RdrNameHsType }
-       : 'forall' tyvars '.' ctype     { mkHsForAllTy (Just $2) [] $4 }
+       : 'forall' tv_bndrs '.' ctype   { mkHsForAllTy (Just $2) [] $4 }
        | context '=>' type             { mkHsForAllTy Nothing   $1 $3 }
        -- A type of form (context => type) is an *implicit* HsForAllTy
        | type                          { $1 }
@@ -676,17 +685,18 @@ gentype :: { RdrNameHsType }
         | atype tyconop atype           { HsOpTy $1 $2 $3 }
 
 btype :: { RdrNameHsType }
-       : btype atype                   { (HsAppTy $1 $2) }
+       : btype atype                   { HsAppTy $1 $2 }
        | atype                         { $1 }
 
 atype :: { RdrNameHsType }
        : gtycon                        { HsTyVar $1 }
        | tyvar                         { HsTyVar $1 }
-       | '(' type ',' types ')'        { HsTupleTy (mkHsTupCon tcName Boxed  ($2:$4)) ($2 : reverse $4) }
-       | '(#' types '#)'               { HsTupleTy (mkHsTupCon tcName Unboxed     $2) (reverse $2)      }
+       | '(' type ',' comma_types1 ')' { HsTupleTy (mkHsTupCon tcName Boxed  ($2:$4)) ($2:$4) }
+       | '(#' comma_types1 '#)'        { HsTupleTy (mkHsTupCon tcName Unboxed     $2) $2      }
        | '[' type ']'                  { HsListTy $2 }
        | '[:' type ':]'                { HsPArrTy $2 }
        | '(' ctype ')'                 { $2 }
+       | '(' ctype '::' kind ')'       { HsKindSig $2 $4 }
 -- Generics
         | INTEGER                       { HsNumTy $1 }
 
@@ -697,21 +707,30 @@ atype :: { RdrNameHsType }
 inst_type :: { RdrNameHsType }
        : ctype                         {% checkInstType $1 }
 
-types0  :: { [RdrNameHsType] }
-       : types                         { reverse $1 }
+comma_types0  :: { [RdrNameHsType] }
+       : comma_types1                  { $1 }
        | {- empty -}                   { [] }
 
-types  :: { [RdrNameHsType] }
+comma_types1   :: { [RdrNameHsType] }
        : type                          { [$1] }
-       | types  ',' type               { $3 : $1 }
-
-simpletype :: { (RdrName, [RdrNameHsTyVar]) }
-       : tycon tyvars                  { ($1, reverse $2) }
+       | type  ',' comma_types1        { $1 : $3 }
 
-tyvars :: { [RdrNameHsTyVar] }
-       : tyvar tyvars                  { UserTyVar $1 : $2 }
+atypes0        :: { [RdrNameHsType] }
+       : atypes1                       { $1 }
        | {- empty -}                   { [] }
 
+atypes1        :: { [RdrNameHsType] }
+       : atype                         { [$1] }
+       | atype atypes1                 { $1 : $2 }
+
+tv_bndrs :: { [RdrNameHsTyVar] }
+        : tv_bndr tv_bndrs             { $1 : $2 }
+        | {- empty -}                  { [] }
+
+tv_bndr :: { RdrNameHsTyVar }
+       : tyvar                         { UserTyVar $1 }
+       | '(' tyvar '::' kind ')'       { IfaceTyVar $2 $4 }
+
 fds :: { [([RdrName], [RdrName])] }
        : {- empty -}                   { [] }
        | '|' fds1                      { reverse $2 }
@@ -728,6 +747,18 @@ varids0    :: { [RdrName] }
        | varids0 tyvar                 { $2 : $1 }
 
 -----------------------------------------------------------------------------
+-- Kinds
+
+kind   :: { Kind }
+       : akind                 { $1 }
+       | akind '->' kind       { mkArrowKind $1 $3 }
+
+akind  :: { Kind }
+       : '*'                   { liftedTypeKind }
+       | '(' kind ')'          { $2 }
+
+
+-----------------------------------------------------------------------------
 -- Datatype declarations
 
 newconstr :: { RdrNameConDecl }
@@ -750,7 +781,7 @@ constr :: { RdrNameConDecl }
                { mkConDecl (fst $3) $2 [] (snd $3) $1 }
 
 forall :: { [RdrNameHsTyVar] }
-       : 'forall' tyvars '.'           { $2 }
+       : 'forall' tv_bndrs '.'         { $2 }
        | {- empty -}                   { [] }
 
 constr_stuff :: { (RdrName, RdrNameConDetails) }
@@ -878,7 +909,7 @@ fexp        :: { RdrNameHsExpr }
        | aexp                                  { $1 }
 
 aexps0         :: { [RdrNameHsExpr] }
-       : aexps                                 { (reverse $1) }
+       : aexps                                 { reverse $1 }
 
 aexps  :: { [RdrNameHsExpr] }
        : aexps aexp                            { $2 : $1 }
@@ -1006,7 +1037,7 @@ alt       :: { RdrNameMatch }
 
 ralt :: { [RdrNameGRHS] }
        : '->' srcloc exp               { [GRHS [ResultStmt $3 $2] $2] }
-       | gdpats                        { (reverse $1) }
+       | gdpats                        { reverse $1 }
 
 gdpats :: { [RdrNameGRHS] }
        : gdpats gdpat                  { $2 : $1 }
@@ -1093,9 +1124,7 @@ deprec_var : var                  { $1 }
           | tycon                      { $1 }
 
 gtycon         :: { RdrName }
-       : tycon                         { $1 }
-       | qtycon                        { $1 }
-       | '(' tyconop ')'               { $2 }
+       : qtycon                        { $1 }
        | '(' qtyconop ')'              { $2 }
        | '(' ')'                       { unitTyCon_RDR }
        | '(' '->' ')'                  { funTyCon_RDR }
@@ -1103,7 +1132,7 @@ gtycon    :: { RdrName }
        | '[:' ':]'                     { parrTyCon_RDR }
        | '(' commas ')'                { tupleTyCon_RDR $2 }
 
-gcon   :: { RdrName }
+gcon   :: { RdrName }  -- Data constructor namespace
        : '(' ')'               { unitCon_RDR }
        | '[' ']'               { nilCon_RDR }
        | '(' commas ')'        { tupleCon_RDR $2 }
@@ -1247,6 +1276,7 @@ varsym_no_minus :: { RdrName } -- varsym not including '-'
 special_sym :: { UserFS }
 special_sym : '!'      { SLIT("!") }
            | '.'       { SLIT(".") }
+           | '*'       { SLIT("*") }
 
 -----------------------------------------------------------------------------
 -- Literals
@@ -1290,11 +1320,13 @@ tycon   :: { RdrName }
 tyconop        :: { RdrName }
        : CONSYM                { mkUnqual tcClsName $1 }
 
-qtycon :: { RdrName }  -- Just the qualified kind
+qtycon :: { RdrName }  -- Qualified or unqualified
        : QCONID                { mkQual tcClsName $1 }
+       | tycon                 { $1 }
 
-qtyconop :: { RdrName }        -- Just the qualified kind
+qtyconop :: { RdrName }        -- Qualified or unqualified
          : QCONSYM             { mkQual tcClsName $1 }
+         | tyconop             { $1 }
 
 commas :: { Int }
        : commas ','                    { $1 + 1 }

diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs
index c9bf3ad..c482844 100644 (file)
--- a/ghc/compiler/parser/RdrHsSyn.lhs
+++ b/ghc/compiler/parser/RdrHsSyn.lhs
@@ -148,11 +148,11 @@ extract_ty (HsTupleTy _ tys)          acc = foldr extract_ty acc tys
 extract_ty (HsFunTy ty1 ty2)          acc = extract_ty ty1 (extract_ty ty2 acc)
 extract_ty (HsPredTy p)                      acc = extract_pred p acc
 extract_ty (HsTyVar tv)               acc = tv : acc
-extract_ty (HsForAllTy Nothing ctxt ty) acc = extract_ctxt ctxt (extract_ty ty acc)
+extract_ty (HsForAllTy Nothing cx ty) acc = extract_ctxt cx (extract_ty ty acc)
 -- Generics
-extract_ty (HsOpTy ty1 nam ty2)         acc = extract_ty ty1 (extract_ty ty2 acc)
+extract_ty (HsOpTy ty1 nam ty2)       acc = extract_ty ty1 (extract_ty ty2 acc)
 extract_ty (HsNumTy num)              acc = acc
--- Generics
+extract_ty (HsKindSig ty k)          acc = extract_ty ty acc
 extract_ty (HsForAllTy (Just tvs) ctxt ty) 
                                 acc = acc ++
                                       (filter (`notElem` locals) $

diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y
index 0ec54bc..ce9526c 100644 (file)
--- a/ghc/compiler/rename/ParseIface.y
+++ b/ghc/compiler/rename/ParseIface.y
@@ -144,6 +144,7 @@ import FastString   ( tailFS )
  '=>'          { ITdarrow }
  '-'           { ITminus }
  '!'           { ITbang }
+ '*'           { ITstar }
 
  '{'           { ITocurly }                    -- special symbols
  '}'           { ITccurly }
@@ -682,9 +683,8 @@ kind                :: { Kind }
                | akind '->' kind       { mkArrowKind $1 $3 }
 
 akind          :: { Kind }
-               : VARSYM                { if $1 == SLIT("*") then
-                                               liftedTypeKind
-                                         else if $1 == SLIT("?") then
+                : '*'                   { liftedTypeKind }
+               | VARSYM                { if $1 == SLIT("?") then
                                                openTypeKind
                                          else if $1 == SLIT("\36") then
                                                 usageTypeKind  -- dollar

diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs
index 539a81e..43364ae 100644 (file)
--- a/ghc/compiler/rename/RnHsSyn.lhs
+++ b/ghc/compiler/rename/RnHsSyn.lhs
@@ -84,6 +84,7 @@ extractHsTyNames ty
                                 unitNameSet tycon
     get (HsNumTy n)            = emptyNameSet
     get (HsTyVar tv)          = unitNameSet tv
+    get (HsKindSig ty k)       = get ty
     get (HsForAllTy (Just tvs) 
                    ctxt ty)   = (extractHsCtxtTyNames ctxt `unionNameSets` get ty)
                                            `minusNameSet`

diff --git a/ghc/compiler/rename/RnTypes.lhs b/ghc/compiler/rename/RnTypes.lhs
index 2d544f5..4ef0582 100644 (file)
--- a/ghc/compiler/rename/RnTypes.lhs
+++ b/ghc/compiler/rename/RnTypes.lhs
@@ -115,6 +115,10 @@ rnHsType doc (HsListTy ty)
   = rnHsType doc ty                            `thenRn` \ ty' ->
     returnRn (HsListTy ty')
 
+rnHsType doc (HsKindSig ty k)
+  = rnHsType doc ty                            `thenRn` \ ty' ->
+    returnRn (HsKindSig ty' k)
+
 rnHsType doc (HsPArrTy ty)
   = rnHsType doc ty                            `thenRn` \ ty' ->
     returnRn (HsPArrTy ty')

diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs
index 1d33e94..3a03d97 100644 (file)
--- a/ghc/compiler/typecheck/TcMonoType.lhs
+++ b/ghc/compiler/typecheck/TcMonoType.lhs
@@ -263,6 +263,11 @@ kcHsLiftedSigType = kcLiftedType
 kcHsType :: RenamedHsType -> TcM TcKind
 kcHsType (HsTyVar name)              = kcTyVar name
 
+kcHsType (HsKindSig ty k)
+  = kcHsType ty                        `thenTc` \ k' ->
+    unifyKind k k'             `thenTc_`
+    returnTc k
+
 kcHsType (HsListTy ty)
   = kcLiftedType ty            `thenTc` \ tau_ty ->
     returnTc liftedTypeKind
@@ -400,6 +405,9 @@ tc_type :: RenamedHsType -> TcM Type
 tc_type ty@(HsTyVar name)
   = tc_app ty []
 
+tc_type (HsKindSig ty k)
+  = tc_type ty -- Kind checking done already
+
 tc_type (HsListTy ty)
   = tc_type ty `thenTc` \ tau_ty ->
     returnTc (mkListTy tau_ty)