[project @ 2002-02-11 09:27:21 by simonpj]

------------------------------
		Towards kinded data type decls
		------------------------------

Move towards being able to have 'kinded' data type decls.
The burden of this commit, though, is to tidy up the parsing
of data type decls.  Previously we had

	data ctype '=' constrs

where the 'ctype' is a completetely general polymorphic type.
	forall a. (Eq a) => T a

Then a separate function checked that it was of a suitably restricted
form.  The reason for this is the usual thing --- it's hard to tell
when looking at

	data Eq a => T a = ...

whether you are reading the data type or the context when you have
only got as far as 'Eq a'.

However, the 'ctype' trick doesn't work if we want to allow

	data T (a :: * -> *) = ...

So we have to parse the data type decl in a more serious way.
That's what this commit does, and it makes the grammar look much nicer.
The main new producion is tycl_hdr.

diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs
index 73f31fa..2ee9664 100644 (file)
--- a/ghc/compiler/parser/ParseUtil.lhs
+++ b/ghc/compiler/parser/ParseUtil.lhs
@@ -24,8 +24,9 @@ module ParseUtil (
                              
        , checkPrec           -- String -> P String
        , checkContext        -- HsType -> P HsContext
+       , checkPred           -- HsType -> P HsPred
+       , checkTyVars         -- [HsTyVar] -> P [HsType]
        , checkInstType       -- HsType -> P HsType
-       , checkDataHeader     -- HsQualType -> P (HsContext,HsName,[HsName])
        , checkPattern        -- HsExp -> P HsPat
        , checkPatterns       -- SrcLoc -> [HsExp] -> P [HsPat]
        , checkDo             -- [Stmt] -> P [Stmt]
@@ -112,24 +113,32 @@ checkInstType t
        ty ->   checkDictTy ty [] `thenP` \ dict_ty->
                returnP (HsForAllTy Nothing [] dict_ty)
 
+checkTyVars :: [RdrNameHsTyVar] -> P [RdrNameHsType]
+checkTyVars tvs = mapP chk tvs
+               where
+                 chk (UserTyVar tv) = returnP (HsTyVar tv)
+                 chk other          = parseError "Illegal kinded type variable"
+
 checkContext :: RdrNameHsType -> P RdrNameContext
 checkContext (HsTupleTy _ ts)  -- (Eq a, Ord b) shows up as a tuple type
-  = mapP (\t -> checkPred t []) ts `thenP` \ps ->
-    returnP ps
+  = mapP checkPred ts
 
 checkContext (HsTyVar t)       -- Empty context shows up as a unit type ()
   | t == unitTyCon_RDR = returnP []
 
 checkContext t 
-  = checkPred t [] `thenP` \p ->
+  = checkPred t `thenP` \p ->
     returnP [p]
 
-checkPred :: RdrNameHsType -> [RdrNameHsType] -> P (HsPred RdrName)
-checkPred (HsTyVar t) args | not (isRdrTyVar t) 
-       = returnP (HsClassP t args)
-checkPred (HsAppTy l r) args = checkPred l (r:args)
-checkPred (HsPredTy (HsIParam n ty)) [] = returnP (HsIParam n ty)
-checkPred _ _ = parseError "Illegal class assertion"
+checkPred :: RdrNameHsType -> P (HsPred RdrName)
+checkPred (HsPredTy (HsIParam n ty)) = returnP (HsIParam n ty)
+checkPred (HsAppTy l r)
+  = go l [r]
+  where
+    go (HsTyVar t) args   | not (isRdrTyVar t) 
+                         = returnP (HsClassP t args)
+    go (HsAppTy l r) args = go l (r:args)
+    go _            _    = parseError "Illegal class assertion"
 
 checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType
 checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t) 
@@ -137,32 +146,6 @@ checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
 checkDictTy (HsAppTy l r) args = checkDictTy l (r:args)
 checkDictTy _ _ = parseError "Malformed context in instance header"
 
--- Put more comments!
--- Checks that the lhs of a datatype declaration
--- is of the form Context => T a b ... z
-checkDataHeader :: String      -- data/newtype/class
-               -> RdrNameHsType 
-               -> P (RdrNameContext, RdrName, [RdrNameHsTyVar])
-
-checkDataHeader s (HsForAllTy Nothing cs t) =
-   checkSimple s t []       `thenP` \(c,ts) ->
-   returnP (cs,c,map UserTyVar ts)
-checkDataHeader s t =
-   checkSimple s t []       `thenP` \(c,ts) ->
-   returnP ([],c,map UserTyVar ts)
-
--- Checks the type part of the lhs of 
--- a data/newtype/class declaration
-checkSimple :: String -> RdrNameHsType -> [RdrName] -> P ((RdrName,[RdrName]))
-checkSimple s (HsAppTy l (HsTyVar a)) xs | isRdrTyVar a 
-   = checkSimple s l (a:xs)
-checkSimple s (HsTyVar tycon) xs | not (isRdrTyVar tycon) = returnP (tycon,xs)
-
-checkSimple s (HsOpTy (HsTyVar t1) tycon (HsTyVar t2)) [] 
-  | not (isRdrTyVar tycon) && isRdrTyVar t1 && isRdrTyVar t2
-  = returnP (tycon,[t1,t2])
-
-checkSimple s t _ = parseError ("Malformed " ++ s ++ " declaration")
 
 ---------------------------------------------------------------------------
 -- Checking statements in a do-expression

diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y
index ec7af29..c9e2042 100644 (file)
--- a/ghc/compiler/parser/Parser.y
+++ b/ghc/compiler/parser/Parser.y
@@ -1,6 +1,6 @@
 {-                                                             -*-haskell-*-
 -----------------------------------------------------------------------------
-$Id: Parser.y,v 1.84 2002/02/11 08:20:44 chak Exp $
+$Id: Parser.y,v 1.85 2002/02/11 09:27:22 simonpj Exp $
 
 Haskell grammar.
 
@@ -348,23 +348,20 @@ topdecl :: { RdrBinding }
                -- Instead we just say b is out of scope
                { RdrHsDecl (TyClD (TySynonym (fst $3) (snd $3) $5 $1)) }
 
-       | srcloc 'data' ctype constrs deriving
-               {% checkDataHeader "data" $3 `thenP` \(cs,c,ts) ->
-                  returnP (RdrHsDecl (TyClD
-                     (mkTyData DataType cs c ts (reverse $4) (length $4) $5 $1))) }
+       | srcloc 'data' tycl_hdr constrs deriving
+               {% returnP (RdrHsDecl (TyClD
+                     (mkTyData DataType $3 (reverse $4) (length $4) $5 $1))) }
 
-       | srcloc 'newtype' ctype '=' newconstr deriving
-               {% checkDataHeader "newtype" $3 `thenP` \(cs,c,ts) ->
-                  returnP (RdrHsDecl (TyClD
-                     (mkTyData NewType cs c ts [$5] 1 $6 $1))) }
+       | srcloc 'newtype' tycl_hdr '=' newconstr deriving
+               {% returnP (RdrHsDecl (TyClD
+                     (mkTyData NewType $3 [$5] 1 $6 $1))) }
 
-       | srcloc 'class' ctype fds where
-               {% checkDataHeader "class" $3 `thenP` \(cs,c,ts) ->
-                  let 
+       | srcloc 'class' tycl_hdr fds where
+               {% let 
                        (binds,sigs) = cvMonoBindsAndSigs cvClassOpSig (groupBindings $5) 
                   in
                   returnP (RdrHsDecl (TyClD
-                     (mkClassDecl cs c ts $4 sigs (Just binds) $1))) }
+                     (mkClassDecl $3 $4 sigs (Just binds) $1))) }
 
        | srcloc 'instance' inst_type where
                { let (binds,sigs) 
@@ -378,6 +375,114 @@ topdecl :: { RdrBinding }
        | '{-# RULES' rules '#-}'                       { $2 }
        | decl                                          { $1 }
 
+-- tycl_hdr parses the header of a type or class decl,
+-- which takes the form
+--     T a b
+--     Eq a => T a
+--     (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) }
+
+decls  :: { [RdrBinding] }
+       : decls ';' decl                { $3 : $1 }
+       | decls ';'                     { $1 }
+       | decl                          { [$1] }
+       | {- empty -}                   { [] }
+
+decl   :: { RdrBinding }
+       : fixdecl                       { $1 }
+       | valdef                        { $1 }
+       | '{-# INLINE'   srcloc activation qvar '#-}'         { RdrSig (InlineSig True  $4 $3 $2) }
+       | '{-# NOINLINE' srcloc inverse_activation qvar '#-}' { RdrSig (InlineSig False $4 $3 $2) }
+       | '{-# SPECIALISE' srcloc qvar '::' sigtypes '#-}'
+               { foldr1 RdrAndBindings 
+                   (map (\t -> RdrSig (SpecSig $3 t $2)) $5) }
+       | '{-# SPECIALISE' srcloc 'instance' inst_type '#-}'
+               { RdrSig (SpecInstSig $4 $2) }
+
+wherebinds :: { RdrNameHsBinds }
+       : where                 { cvBinds cvValSig (groupBindings $1) }
+
+where  :: { [RdrBinding] }
+       : 'where' decllist              { $2 }
+       | {- empty -}                   { [] }
+
+declbinds :: { RdrNameHsBinds }
+       : decllist                      { cvBinds cvValSig (groupBindings $1) }
+
+decllist :: { [RdrBinding] }
+       : '{'            decls '}'      { $2 }
+       |     layout_on  decls close    { $2 }
+
+fixdecl :: { RdrBinding }
+       : srcloc infix prec ops         { foldr1 RdrAndBindings
+                                           [ RdrSig (FixSig (FixitySig n 
+                                                           (Fixity $3 $2) $1))
+                                           | n <- $4 ] }
+
+-----------------------------------------------------------------------------
+-- Transformation Rules
+
+rules  :: { RdrBinding }
+       :  rules ';' rule                       { $1 `RdrAndBindings` $3 }
+        |  rules ';'                           { $1 }
+        |  rule                                        { $1 }
+       |  {- empty -}                          { RdrNullBind }
+
+rule   :: { RdrBinding }
+       : STRING activation rule_forall infixexp '=' srcloc exp
+            { RdrHsDecl (RuleD (HsRule $1 $2 $3 $4 $7 $6)) }
+
+activation :: { Activation }           -- Omitted means AlwaysActive
+        : {- empty -}                           { AlwaysActive }
+        | explicit_activation                   { $1 }
+
+inverse_activation :: { Activation }   -- Omitted means NeverActive
+        : {- empty -}                           { NeverActive }
+        | explicit_activation                   { $1 }
+
+explicit_activation :: { Activation }  -- In brackets
+        : '[' INTEGER ']'                       { ActiveAfter  (fromInteger $2) }
+        | '[' '~' INTEGER ']'                   { ActiveBefore (fromInteger $3) }
+
+rule_forall :: { [RdrNameRuleBndr] }
+       : 'forall' rule_var_list '.'            { $2 }
+        | {- empty -}                          { [] }
+
+rule_var_list :: { [RdrNameRuleBndr] }
+        : rule_var                             { [$1] }
+        | rule_var rule_var_list               { $1 : $2 }
+
+rule_var :: { RdrNameRuleBndr }
+       : varid                                 { RuleBndr $1 }
+               | '(' varid '::' ctype ')'              { RuleBndrSig $2 $4 }
+
+-----------------------------------------------------------------------------
+-- Deprecations
+
+deprecations :: { RdrBinding }
+       : deprecations ';' deprecation          { $1 `RdrAndBindings` $3 }
+       | deprecations ';'                      { $1 }
+       | deprecation                           { $1 }
+       | {- empty -}                           { RdrNullBind }
+
+-- SUP: TEMPORARY HACK, not checking for `module Foo'
+deprecation :: { RdrBinding }
+       : srcloc depreclist STRING
+               { foldr RdrAndBindings RdrNullBind 
+                       [ RdrHsDecl (DeprecD (Deprecation n $3 $1)) | n <- $2 ] }
+
+
+-----------------------------------------------------------------------------
+-- Foreign import and export declarations
+
 -- for the time being, the following accepts foreign declarations conforming
 -- to the FFI Addendum, Version 1.0 as well as pre-standard declarations
 --
@@ -491,97 +596,6 @@ fdecl2DEPRECATED
     -- left this one unchanged for the moment as type imports are not
     -- covered currently by the FFI standard -=chak
 
-decls  :: { [RdrBinding] }
-       : decls ';' decl                { $3 : $1 }
-       | decls ';'                     { $1 }
-       | decl                          { [$1] }
-       | {- empty -}                   { [] }
-
-decl   :: { RdrBinding }
-       : fixdecl                       { $1 }
-       | valdef                        { $1 }
-       | '{-# INLINE'   srcloc activation qvar '#-}'         { RdrSig (InlineSig True  $4 $3 $2) }
-       | '{-# NOINLINE' srcloc inverse_activation qvar '#-}' { RdrSig (InlineSig False $4 $3 $2) }
-       | '{-# SPECIALISE' srcloc qvar '::' sigtypes '#-}'
-               { foldr1 RdrAndBindings 
-                   (map (\t -> RdrSig (SpecSig $3 t $2)) $5) }
-       | '{-# SPECIALISE' srcloc 'instance' inst_type '#-}'
-               { RdrSig (SpecInstSig $4 $2) }
-
-wherebinds :: { RdrNameHsBinds }
-       : where                 { cvBinds cvValSig (groupBindings $1) }
-
-where  :: { [RdrBinding] }
-       : 'where' decllist              { $2 }
-       | {- empty -}                   { [] }
-
-declbinds :: { RdrNameHsBinds }
-       : decllist                      { cvBinds cvValSig (groupBindings $1) }
-
-decllist :: { [RdrBinding] }
-       : '{'            decls '}'      { $2 }
-       |     layout_on  decls close    { $2 }
-
-fixdecl :: { RdrBinding }
-       : srcloc infix prec ops         { foldr1 RdrAndBindings
-                                           [ RdrSig (FixSig (FixitySig n 
-                                                           (Fixity $3 $2) $1))
-                                           | n <- $4 ] }
-
------------------------------------------------------------------------------
--- Transformation Rules
-
-rules  :: { RdrBinding }
-       :  rules ';' rule                       { $1 `RdrAndBindings` $3 }
-        |  rules ';'                           { $1 }
-        |  rule                                        { $1 }
-       |  {- empty -}                          { RdrNullBind }
-
-rule   :: { RdrBinding }
-       : STRING activation rule_forall infixexp '=' srcloc exp
-            { RdrHsDecl (RuleD (HsRule $1 $2 $3 $4 $7 $6)) }
-
-activation :: { Activation }           -- Omitted means AlwaysActive
-        : {- empty -}                           { AlwaysActive }
-        | explicit_activation                   { $1 }
-
-inverse_activation :: { Activation }   -- Omitted means NeverActive
-        : {- empty -}                           { NeverActive }
-        | explicit_activation                   { $1 }
-
-explicit_activation :: { Activation }  -- In brackets
-        : '[' INTEGER ']'                       { ActiveAfter  (fromInteger $2) }
-        | '[' '~' INTEGER ']'                   { ActiveBefore (fromInteger $3) }
-
-rule_forall :: { [RdrNameRuleBndr] }
-       : 'forall' rule_var_list '.'            { $2 }
-        | {- empty -}                          { [] }
-
-rule_var_list :: { [RdrNameRuleBndr] }
-        : rule_var                             { [$1] }
-        | rule_var rule_var_list               { $1 : $2 }
-
-rule_var :: { RdrNameRuleBndr }
-       : varid                                 { RuleBndr $1 }
-               | '(' varid '::' ctype ')'              { RuleBndrSig $2 $4 }
-
------------------------------------------------------------------------------
--- Deprecations
-
-deprecations :: { RdrBinding }
-       : deprecations ';' deprecation          { $1 `RdrAndBindings` $3 }
-       | deprecations ';'                      { $1 }
-       | deprecation                           { $1 }
-       | {- empty -}                           { RdrNullBind }
-
--- SUP: TEMPORARY HACK, not checking for `module Foo'
-deprecation :: { RdrBinding }
-       : srcloc depreclist STRING
-               { foldr RdrAndBindings RdrNullBind 
-                       [ RdrHsDecl (DeprecD (Deprecation n $3 $1)) | n <- $2 ] }
-
------------------------------------------------------------------------------
--- Foreign declarations
 
 callconv :: { CallConv }
          : 'stdcall'                   { CCall  StdCallConv }
@@ -644,6 +658,13 @@ ctype      :: { RdrNameHsType }
        -- A type of form (context => type) is an *implicit* HsForAllTy
        | type                          { $1 }
 
+-- We parse a context as a btype so that we don't get reduce/reduce
+-- errors in ctype.  The basic problem is that
+--     (Eq a, Ord a)
+-- looks so much like a tuple type.  We can't tell until we find the =>
+context :: { RdrNameContext }
+       : btype                         {% checkContext $1 }
+
 type :: { RdrNameHsType }
        : gentype '->' type             { HsFunTy $1 $3 }
        | ipvar '::' type               { mkHsIParamTy $1 $3 }
@@ -688,7 +709,7 @@ simpletype :: { (RdrName, [RdrNameHsTyVar]) }
        : tycon tyvars                  { ($1, reverse $2) }
 
 tyvars :: { [RdrNameHsTyVar] }
-       : tyvars tyvar                  { UserTyVar $2 : $1 }
+       : tyvar tyvars                  { UserTyVar $1 : $2 }
        | {- empty -}                   { [] }
 
 fds :: { [([RdrName], [RdrName])] }
@@ -732,9 +753,6 @@ forall :: { [RdrNameHsTyVar] }
        : 'forall' tyvars '.'           { $2 }
        | {- empty -}                   { [] }
 
-context :: { RdrNameContext }
-       : btype                         {% checkContext $1 }
-
 constr_stuff :: { (RdrName, RdrNameConDetails) }
        : btype                         {% mkVanillaCon $1 []               }
        | btype '!' atype satypes       {% mkVanillaCon $1 (BangType MarkedUserStrict $3 : $4) }
@@ -1075,7 +1093,9 @@ deprec_var : var                  { $1 }
           | tycon                      { $1 }
 
 gtycon         :: { RdrName }
-       : qtycon                        { $1 }
+       : tycon                         { $1 }
+       | qtycon                        { $1 }
+       | '(' tyconop ')'               { $2 }
        | '(' qtyconop ')'              { $2 }
        | '(' ')'                       { unitTyCon_RDR }
        | '(' '->' ')'                  { funTyCon_RDR }
@@ -1183,7 +1203,7 @@ special_id
 -----------------------------------------------------------------------------
 -- ConIds
 
-qconid :: { RdrName }
+qconid :: { RdrName }  -- Qualified or unqualifiedb
        : conid                 { $1 }
        | QCONID                { mkQual dataName $1 }
 
@@ -1193,7 +1213,7 @@ conid     :: { RdrName }
 -----------------------------------------------------------------------------
 -- ConSyms
 
-qconsym :: { RdrName }
+qconsym :: { RdrName } -- Qualified or unqualifiedb
        : consym                { $1 }
        | QCONSYM               { mkQual dataName $1 }
 
@@ -1270,13 +1290,11 @@ tycon   :: { RdrName }
 tyconop        :: { RdrName }
        : CONSYM                { mkUnqual tcClsName $1 }
 
-qtycon :: { RdrName }
-       : tycon                 { $1 }
-       | QCONID                { mkQual tcClsName $1 }
+qtycon :: { RdrName }  -- Just the qualified kind
+       : QCONID                { mkQual tcClsName $1 }
 
-qtyconop :: { RdrName }
-         : tyconop             { $1 }
-         | QCONSYM             { mkQual tcClsName $1 }
+qtyconop :: { RdrName }        -- Just the qualified kind
+         : QCONSYM             { mkQual tcClsName $1 }
 
 commas :: { Int }
        : commas ','                    { $1 + 1 }

diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs
index 5df53ae..c9bf3ad 100644 (file)
--- a/ghc/compiler/parser/RdrHsSyn.lhs
+++ b/ghc/compiler/parser/RdrHsSyn.lhs
@@ -192,7 +192,7 @@ Similarly for mkConDecl, mkClassOpSig and default-method names.
        *** See "THE NAMING STORY" in HsDecls ****
   
 \begin{code}
-mkClassDecl cxt cname tyvars fds sigs mbinds loc
+mkClassDecl (cxt, cname, tyvars) fds sigs mbinds loc
   = ClassDecl { tcdCtxt = cxt, tcdName = cname, tcdTyVars = tyvars,
                tcdFDs = fds,  tcdSigs = sigs,  tcdMeths = mbinds,
                tcdSysNames = new_names, tcdLoc = loc }
@@ -213,12 +213,12 @@ mkClassDecl cxt cname tyvars fds sigs mbinds loc
       --  superclasses both called C!)
     new_names = mkClassDeclSysNames (tname, dname, dwname, sc_sel_names)
 
-mkTyData new_or_data context tname list_var list_con i maybe src
+mkTyData new_or_data (context, tname, tyvars) list_con i maybe src
   = let t_occ  = rdrNameOcc tname
         name1 = mkRdrUnqual (mkGenOcc1 t_occ) 
        name2 = mkRdrUnqual (mkGenOcc2 t_occ) 
     in TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname,
-               tcdTyVars = list_var, tcdCons = list_con, tcdNCons = i,
+               tcdTyVars = tyvars, tcdCons = list_con, tcdNCons = i,
                tcdDerivs = maybe, tcdLoc = src, tcdSysNames = [name1, name2] }
 
 mkClassOpSigDM op ty loc