X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fparser%2FParser.y.pp;h=b31e0250852368133f4f0655eb21c38a4625ef21;hb=bb511e2deeb63e4b1a92b033283cd63de3e5a27c;hp=9ad951881984b95b0046bc7b0a2bdd6bb26827a4;hpb=c7addbef67840954ad788434c28b0a3476ee0ad7;p=ghc-hetmet.git

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 9ad9518..b31e025 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -618,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
@@ -626,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
@@ -682,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
@@ -690,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
@@ -1138,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
@@ -1151,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 $>) }
 
@@ -1272,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) ->
@@ -1323,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
@@ -1497,7 +1494,7 @@ gdpat	:: { LGRHS RdrName }
 -- Bangs inside are parsed as infix operator applications, so that
 -- we parse them right when bang-patterns are off
 pat     :: { LPat RdrName }
-pat 	: infixexp		{% checkPattern $1 }
+pat 	:  exp		 	{% checkPattern $1 }
 	| '!' aexp		{% checkPattern (LL (SectionR (L1 (HsVar bang_RDR)) $2)) }
 
 apat   :: { LPat RdrName }	
@@ -1550,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