Add several new record features

[ghc-hetmet.git] / compiler / parser / Parser.y.pp

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index abfc258..82f6474 100644 (file)
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -361,10 +361,10 @@ module    :: { Located (HsModule RdrName) }
                {% fileSrcSpan >>= \ loc -> case $1 of { (opt, info, doc) -> 
                   return (L loc (HsModule (Just $3) $5 (fst $7) (snd $7) $4 
                           opt info doc) )}}
-       | missing_module_keyword top close
+        | body2
                {% fileSrcSpan >>= \ loc ->
                   return (L loc (HsModule Nothing Nothing 
-                          (fst $2) (snd $2) Nothing Nothing emptyHaddockModInfo 
+                          (fst $1) (snd $1) Nothing Nothing emptyHaddockModInfo 
                           Nothing)) }
 
 optdoc :: { (Maybe String, HaddockModInfo RdrName, Maybe (HsDoc RdrName)) }                             
@@ -385,6 +385,10 @@ body       :: { ([LImportDecl RdrName], [LHsDecl RdrName]) }
        :  '{'            top '}'               { $2 }
        |      vocurly    top close             { $2 }
 
+body2  :: { ([LImportDecl RdrName], [LHsDecl RdrName]) }
+       :  '{' top '}'                          { $2 }
+       |  missing_module_keyword top close     { $2 }
+
 top    :: { ([LImportDecl RdrName], [LHsDecl RdrName]) }
        : importdecls                           { (reverse $1,[]) }
        | importdecls ';' cvtopdecls            { (reverse $1,$3) }
@@ -614,7 +618,7 @@ ty_decl :: { LTyClDecl RdrName }
                              (unLoc $3) (reverse (unLoc $5)) (unLoc $6)) } }
 
           -- data/newtype family
-        | data_or_newtype 'family' tycl_hdr opt_kind_sig
+        | 'data' 'family' tycl_hdr opt_kind_sig
                {% do { let {(ctxt, tc, tvs, tparms) = unLoc $3}
                       ; checkTyVars tparms            -- no type pattern
                      ; unless (null (unLoc ctxt)) $  -- and no context
@@ -622,8 +626,7 @@ ty_decl :: { LTyClDecl RdrName }
                            "A family declaration cannot have a context"
                      ; return $
                          L (comb3 $1 $2 $4)
-                           (TyFamily (DataFamily (unLoc $1)) tc tvs 
-                                     (unLoc $4)) } }
+                           (TyFamily DataFamily tc tvs (unLoc $4)) } }
 
           -- data/newtype instance declaration
        | data_or_newtype 'instance' tycl_hdr constrs deriving
@@ -678,7 +681,7 @@ at_decl_cls :: { LTyClDecl RdrName }
                       } }
 
           -- data/newtype family declaration
-        | data_or_newtype tycl_hdr opt_kind_sig
+        | 'data' tycl_hdr opt_kind_sig
                {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
                       ; checkTyVars tparms            -- no type pattern
                      ; unless (null (unLoc ctxt)) $  -- and no context
@@ -686,8 +689,7 @@ at_decl_cls :: { LTyClDecl RdrName }
                            "A family declaration cannot have a context"
                      ; return $
                          L (comb3 $1 $2 $3)
-                           (TyFamily (DataFamily (unLoc $1)) tc tvs
-                                     (unLoc $3)) 
+                           (TyFamily DataFamily tc tvs (unLoc $3)) 
                       } }
 
 -- Associate type instances
@@ -1134,7 +1136,7 @@ forall :: { Located [LHsTyVarBndr RdrName] }
        : 'forall' tv_bndrs '.'         { LL $2 }
        | {- empty -}                   { noLoc [] }
 
-constr_stuff :: { Located (Located RdrName, HsConDetails RdrName (LBangType RdrName)) }
+constr_stuff :: { Located (Located RdrName, HsConDeclDetails RdrName) }
 -- We parse the constructor declaration 
 --     C t1 t2
 -- as a btype (treating C as a type constructor) and then convert C to be
@@ -1147,7 +1149,7 @@ constr_stuff :: { Located (Located RdrName, HsConDetails RdrName (LBangType RdrN
        | oqtycon '{' fielddecls '}'    {% mkRecCon $1 $3 >>= return.LL }
        | btype conop btype             { LL ($2, InfixCon $1 $3) }
 
-constr_stuff_record :: { Located (Located RdrName, HsConDetails RdrName (LBangType RdrName)) }
+constr_stuff_record :: { Located (Located RdrName, HsConDeclDetails RdrName) }
        : oqtycon '{' '}'               {% mkRecCon $1 [] >>= return.sL (comb2 $1 $>) }
        | oqtycon '{' fielddecls '}'    {% mkRecCon $1 $3 >>= return.sL (comb2 $1 $>) }
 
@@ -1268,7 +1270,7 @@ exp10 :: { LHsExpr RdrName }
        | 'let' binds 'in' exp                  { LL $ HsLet (unLoc $2) $4 }
        | 'if' exp 'then' exp 'else' exp        { LL $ HsIf $2 $4 $6 }
        | 'case' exp 'of' altslist              { LL $ HsCase $2 (mkMatchGroup (unLoc $4)) }
-       | '-' fexp                              { LL $ mkHsNegApp $2 }
+       | '-' fexp                              { LL $ NegApp $2 noSyntaxExpr }
 
        | 'do' stmtlist                 {% let loc = comb2 $1 $2 in
                                           checkDo loc (unLoc $2)  >>= \ (stmts,body) ->
@@ -1319,9 +1321,8 @@ aexp      :: { LHsExpr RdrName }
        | aexp1                         { $1 }
 
 aexp1  :: { LHsExpr RdrName }
-        : aexp1 '{' fbinds '}'         {% do { r <- mkRecConstrOrUpdate $1 (comb2 $2 $4) 
-                                                       $3;
-                                       return (LL r) }}
+        : aexp1 '{' fbinds '}'         {% do { r <- mkRecConstrOrUpdate $1 (comb2 $2 $4) $3
+                                     ; return (LL r) }}
        | aexp2                 { $1 }
 
 -- Here was the syntax for type applications that I was planning
@@ -1546,16 +1547,21 @@ qual  :: { LStmt RdrName }
 -----------------------------------------------------------------------------
 -- Record Field Update/Construction
 
-fbinds         :: { HsRecordBinds RdrName }
-       : fbinds1                       { HsRecordBinds (reverse $1) }
-       | {- empty -}                   { HsRecordBinds [] }
+fbinds         :: { ([HsRecField RdrName (LHsExpr RdrName)], Bool) }
+       : fbinds1                       { $1 }
+       | {- empty -}                   { ([], False) }
 
-fbinds1        :: { [(Located id, LHsExpr id)] }
-       : fbinds1 ',' fbind             { $3 : $1 }
-       | fbind                         { [$1] }
+fbinds1        :: { ([HsRecField RdrName (LHsExpr RdrName)], Bool) }
+       : fbind ',' fbinds1             { case $3 of (flds, dd) -> ($1 : flds, dd) } 
+       | fbind                         { ([$1], False) }
+       | '..'                          { ([],   True) }
   
-fbind  :: { (Located RdrName, LHsExpr RdrName) }
-       : qvar '=' exp                  { ($1,$3) }
+fbind  :: { HsRecField RdrName (LHsExpr RdrName) }
+       : qvar '=' exp  { HsRecField $1 $3 False }
+       | qvar          { HsRecField $1 (L (getLoc $1) (HsVar (unLoc $1))) True }
+                       -- Here's where we say that plain 'x'
+                       -- means exactly 'x = x'.  The pun-flag boolean is
+                       -- there so we can still print it right
 
 -----------------------------------------------------------------------------
 -- Implicit Parameter Bindings