Kind sigs in associated data/newtype family decls may be omitted

* This is only a slight generalisation of the parser, so that family
  declarations on the toplevel and in classes are uniform.
* I didn't allow that right away as it is a bit tricky to avoid reduce/reduce
  conflicts.

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index c0d3f4e..59a9cfe 100644 (file)
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -52,6 +52,17 @@ import Control.Monad    ( mplus )
 
 {-
 -----------------------------------------------------------------------------
 
 {-
 -----------------------------------------------------------------------------

+6 December 2006
+
+Conflicts: 32 shift/reduce
+           1 reduce/reduce
+
+The reduce/reduce conflict is weird.  It's between tyconsym and consym, and I
+would think the two should never occur in the same context.
+
+  -=chak
+
+-----------------------------------------------------------------------------

 26 July 2006
 
 Conflicts: 37 shift/reduce
 26 July 2006
 
 Conflicts: 37 shift/reduce

@@ -491,9 +502,10 @@ topdecls :: { OrdList (LHsDecl RdrName) }
 topdecl :: { OrdList (LHsDecl RdrName) }
        : cl_decl                       { unitOL (L1 (TyClD (unLoc $1))) }
        | ty_decl                       { unitOL (L1 (TyClD (unLoc $1))) }
 topdecl :: { OrdList (LHsDecl RdrName) }
        : cl_decl                       { unitOL (L1 (TyClD (unLoc $1))) }
        | ty_decl                       { unitOL (L1 (TyClD (unLoc $1))) }

-         | 'instance' inst_type where
-               { let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc $3)
-                 in unitOL (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs ats))) }
+       | 'instance' inst_type where_inst
+           { let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc $3)
+             in 
+             unitOL (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs ats)))}

         | stand_alone_deriving                  { unitOL (LL (DerivD (unLoc $1))) }
        | 'default' '(' comma_types0 ')'        { unitOL (LL $ DefD (DefaultDecl $3)) }
        | 'foreign' fdecl                       { unitOL (LL (unLoc $2)) }
         | stand_alone_deriving                  { unitOL (LL (DerivD (unLoc $1))) }
        | 'default' '(' comma_types0 ')'        { unitOL (LL $ DefD (DefaultDecl $3)) }
        | 'foreign' fdecl                       { unitOL (LL (unLoc $2)) }

@@ -510,7 +522,7 @@ topdecl :: { OrdList (LHsDecl RdrName) }
 -- Type classes
 --
 cl_decl :: { LTyClDecl RdrName }
 -- Type classes
 --
 cl_decl :: { LTyClDecl RdrName }

-       : 'class' tycl_hdr fds where
+       : 'class' tycl_hdr fds where_cls

                {% do { let { (binds, sigs, ats, docs)           = 
                                cvBindsAndSigs (unLoc $4)
                            ; (ctxt, tc, tvs, tparms) = unLoc $2}
                {% do { let { (binds, sigs, ats, docs)           = 
                                cvBindsAndSigs (unLoc $4)
                            ; (ctxt, tc, tvs, tparms) = unLoc $2}

@@ -616,9 +628,16 @@ ty_decl :: { LTyClDecl RdrName }
                            (mkTyData (unLoc $1) (ctxt, tc, tvs, Just tparms) 
                               (unLoc $4) (reverse (unLoc $6)) (unLoc $7)) } }
 
                            (mkTyData (unLoc $1) (ctxt, tc, tvs, Just tparms) 
                               (unLoc $4) (reverse (unLoc $6)) (unLoc $7)) } }
 

--- Associate type declarations
+-- Associate type family declarations
+--
+-- * They have a different syntax than on the toplevel (no family special
+--   identifier).
+--
+-- * They also need to be separate from instances; otherwise, data family
+--   declarations without a kind signature cause parsing conflicts with empty
+--   data declarations. 

 --
 --

-at_decl :: { LTyClDecl RdrName }
+at_decl_cls :: { LTyClDecl RdrName }

            -- type family declarations
         : 'type' type opt_kind_sig
                -- Note the use of type for the head; this allows
            -- type family declarations
         : 'type' type opt_kind_sig
                -- Note the use of type for the head; this allows

@@ -632,7 +651,7 @@ at_decl :: { LTyClDecl RdrName }
                                  (TyFunction tc tvs False kind))
                      } }
 
                                  (TyFunction tc tvs False kind))
                      } }
 

-           -- type instance declarations
+           -- default type instance

         | 'type' type '=' ctype
                -- Note the use of type for the head; this allows
                -- infix type constructors and type patterns
         | 'type' type '=' ctype
                -- Note the use of type for the head; this allows
                -- infix type constructors and type patterns

@@ -642,14 +661,30 @@ at_decl :: { LTyClDecl RdrName }
                                  (TySynonym tc tvs (Just typats) $4)) 
                       } }
 
                                  (TySynonym tc tvs (Just typats) $4)) 
                       } }
 

-          -- data/newtype family
-        | data_or_newtype tycl_hdr '::' kind
+          -- data/newtype family declaration
+        | data_or_newtype tycl_hdr opt_kind_sig

                {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
                       ; checkTyVars tparms    -- no type pattern
                {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
                       ; checkTyVars tparms    -- no type pattern

+                     ; let kind = case unLoc $3 of
+                                    Nothing -> liftedTypeKind
+                                    Just ki -> ki

                      ; return $
                      ; return $

-                         L (comb3 $1 $2 $4)
+                         L (comb3 $1 $2 $3)

                            (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) 
                            (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) 

-                             (Just (unLoc $4)) [] Nothing) } }
+                             (Just kind) [] Nothing) } }
+
+-- Associate type instances
+--
+at_decl_inst :: { LTyClDecl RdrName }
+           -- type instance declarations
+        : 'type' type '=' ctype
+               -- Note the use of type for the head; this allows
+               -- infix type constructors and type patterns
+               --
+               {% do { (tc, tvs, typats) <- checkSynHdr $2 True
+                     ; return (L (comb2 $1 $4) 
+                                 (TySynonym tc tvs (Just typats) $4)) 
+                      } }

 
         -- data/newtype instance declaration
        | data_or_newtype tycl_hdr constrs deriving
 
         -- data/newtype instance declaration
        | data_or_newtype tycl_hdr constrs deriving

@@ -712,32 +747,59 @@ stand_alone_deriving :: { LDerivDecl RdrName }
 -----------------------------------------------------------------------------
 -- Nested declarations
 
 -----------------------------------------------------------------------------
 -- Nested declarations
 

--- Type declaration or value declaration
+-- Declaration in class bodies

 --
 --

-tydecl  :: { Located (OrdList (LHsDecl RdrName)) }
-tydecl  : at_decl                      { LL (unitOL (L1 (TyClD (unLoc $1)))) }
-       | decl                          { $1 }
-
-tydecls        :: { Located (OrdList (LHsDecl RdrName)) }      -- Reversed
-       : tydecls ';' tydecl            { LL (unLoc $1 `appOL` unLoc $3) }
-       | tydecls ';'                   { LL (unLoc $1) }
-       | tydecl                        { $1 }
-       | {- empty -}                   { noLoc nilOL }
+decl_cls  :: { Located (OrdList (LHsDecl RdrName)) }
+decl_cls  : at_decl_cls                        { LL (unitOL (L1 (TyClD (unLoc $1)))) }
+         | decl                        { $1 }
+
+decls_cls :: { Located (OrdList (LHsDecl RdrName)) }   -- Reversed
+         : decls_cls ';' decl_cls      { LL (unLoc $1 `appOL` unLoc $3) }
+         | decls_cls ';'               { LL (unLoc $1) }
+         | decl_cls                    { $1 }
+         | {- empty -}                 { noLoc nilOL }

 
 
 
 

-tydecllist 
+decllist_cls

         :: { Located (OrdList (LHsDecl RdrName)) }     -- Reversed
         :: { Located (OrdList (LHsDecl RdrName)) }     -- Reversed

-       : '{'            tydecls '}'    { LL (unLoc $2) }
-       |     vocurly    tydecls close  { $2 }
+       : '{'         decls_cls '}'     { LL (unLoc $2) }
+       |     vocurly decls_cls close   { $2 }

 
 

--- Form of the body of class and instance declarations
+-- Class body

 --
 --

-where  :: { Located (OrdList (LHsDecl RdrName)) }      -- Reversed
+where_cls :: { Located (OrdList (LHsDecl RdrName)) }   -- Reversed

                                -- No implicit parameters
                                -- May have type declarations
                                -- No implicit parameters
                                -- May have type declarations

-       : 'where' tydecllist            { LL (unLoc $2) }
+       : 'where' decllist_cls          { LL (unLoc $2) }
+       | {- empty -}                   { noLoc nilOL }
+
+-- Declarations in instance bodies
+--
+decl_inst  :: { Located (OrdList (LHsDecl RdrName)) }
+decl_inst  : at_decl_inst              { LL (unitOL (L1 (TyClD (unLoc $1)))) }
+          | decl                       { $1 }
+
+decls_inst :: { Located (OrdList (LHsDecl RdrName)) }  -- Reversed
+          : decls_inst ';' decl_inst   { LL (unLoc $1 `appOL` unLoc $3) }
+          | decls_inst ';'             { LL (unLoc $1) }
+          | decl_inst                  { $1 }
+          | {- empty -}                { noLoc nilOL }
+
+decllist_inst 
+        :: { Located (OrdList (LHsDecl RdrName)) }     -- Reversed
+       : '{'         decls_inst '}'    { LL (unLoc $2) }
+       |     vocurly decls_inst close  { $2 }
+
+-- Instance body
+--
+where_inst :: { Located (OrdList (LHsDecl RdrName)) }  -- Reversed
+                               -- No implicit parameters
+                               -- May have type declarations
+       : 'where' decllist_inst         { LL (unLoc $2) }

        | {- empty -}                   { noLoc nilOL }
 
        | {- empty -}                   { noLoc nilOL }
 

+-- Declarations in binding groups other than classes and instances
+--

 decls  :: { Located (OrdList (LHsDecl RdrName)) }      
        : decls ';' decl                { LL (unLoc $1 `appOL` unLoc $3) }
        | decls ';'                     { LL (unLoc $1) }
 decls  :: { Located (OrdList (LHsDecl RdrName)) }      
        : decls ';' decl                { LL (unLoc $1 `appOL` unLoc $3) }
        | decls ';'                     { LL (unLoc $1) }