X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FParser.y.pp;h=6f1b2e449f418636bf87676b712de866aba0afb4;hp=c56b0c10018d3a1c86cee526828810d821b904e8;hb=e3d0f33551f53f8f78739faf168a6bb94f676c0d;hpb=6f8ff0bbad3b9fa389c960ad1b5a267a1ae502f1

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index c56b0c1..6f1b2e4 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -697,9 +697,9 @@ opt_kind_sig :: { Located (Maybe Kind) }
 --	(Eq a, Ord b) => T a b
 --      T Int [a]			-- for associated types
 -- Rather a lot of inlining here, else we get reduce/reduce errors
-tycl_hdr :: { Located (LHsContext RdrName, LHsType RdrName) }
-	: context '=>' type		{ LL ($1, $3) }
-	| type                          { L1 (noLoc [], $1) }
+tycl_hdr :: { Located (Maybe (LHsContext RdrName), LHsType RdrName) }
+	: context '=>' type		{ LL (Just $1, $3) }
+	| type                          { L1 (Nothing, $1) }
 
 -----------------------------------------------------------------------------
 -- Stand-alone deriving
@@ -936,7 +936,7 @@ infixtype :: { LHsType RdrName }
 
 strict_mark :: { Located HsBang }
 	: '!'				{ L1 HsStrict }
-	| '{-# UNPACK' '#-}' '!'	{ LL HsUnbox }
+	| '{-# UNPACK' '#-}' '!'	{ LL HsUnpack }
 
 -- A ctype is a for-all type
 ctype	:: { LHsType RdrName }
@@ -1014,11 +1014,9 @@ atype :: { LHsType RdrName }
 	| '(' ctype ')'		        { LL $ HsParTy   $2 }
 	| '(' ctype '::' kind ')'	{ LL $ HsKindSig $2 (unLoc $4) }
 	| quasiquote       	        { L1 (HsQuasiQuoteTy (unLoc $1)) }
-	| '$(' exp ')'	      		{ LL $ HsSpliceTy (mkHsSplice $2 ) }
-	| TH_ID_SPLICE	      		{ LL $ HsSpliceTy (mkHsSplice 
-					         (L1 $ HsVar (mkUnqual varName 
-							        (getTH_ID_SPLICE $1)))) } -- $x
-
+	| '$(' exp ')'	      		{ LL $ mkHsSpliceTy $2 }
+	| TH_ID_SPLICE	      		{ LL $ mkHsSpliceTy $ L1 $ HsVar $ 
+					  mkUnqual varName (getTH_ID_SPLICE $1) }
 -- Generics
         | INTEGER                       { L1 (HsNumTy (getINTEGER $1)) }
 
@@ -1046,7 +1044,7 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] }
 	 | {- empty -}			{ [] }
 
 tv_bndr :: { LHsTyVarBndr RdrName }
-	: tyvar				{ L1 (UserTyVar (unLoc $1)) }
+	: tyvar				{ L1 (UserTyVar (unLoc $1) placeHolderKind) }
 	| '(' tyvar '::' kind ')'	{ LL (KindedTyVar (unLoc $2) 
 							  (unLoc $4)) }
 
@@ -1271,7 +1269,9 @@ exp10 :: { LHsExpr RdrName }
 							   	(unguardedGRHSs $6)
 							    ]) }
   	| 'let' binds 'in' exp			{ LL $ HsLet (unLoc $2) $4 }
-	| 'if' exp 'then' exp 'else' exp	{ LL $ HsIf $2 $4 $6 }
+	| 'if' exp optSemi 'then' exp optSemi 'else' exp
+                                        {% checkDoAndIfThenElse $2 $3 $5 $6 $8 >>
+                                           return (LL $ HsIf $2 $5 $8) }
    	| 'case' exp 'of' altslist		{ LL $ HsCase $2 (mkMatchGroup (unLoc $4)) }
 	| '-' fexp				{ LL $ NegApp $2 noSyntaxExpr }
 
@@ -1298,6 +1298,10 @@ exp10 :: { LHsExpr RdrName }
 						    -- hdaume: core annotation
 	| fexp					{ $1 }
 
+optSemi :: { Bool }
+	: ';'         { True }
+	| {- empty -} { False }
+
 scc_annot :: { Located FastString }
 	: '_scc_' STRING			{% (addWarning Opt_WarnWarningsDeprecations (getLoc $1) (text "_scc_ is deprecated; use an SCC pragma instead")) >>= \_ ->
                                    ( do scc <- getSCC $2; return $ LL scc ) }
@@ -1364,8 +1368,8 @@ aexp2	:: { LHsExpr RdrName }
 	-- Template Haskell Extension
 	| TH_ID_SPLICE          { L1 $ HsSpliceE (mkHsSplice 
 					(L1 $ HsVar (mkUnqual varName 
-							(getTH_ID_SPLICE $1)))) } -- $x
-	| '$(' exp ')'   	{ LL $ HsSpliceE (mkHsSplice $2) }               -- $( exp )
+							(getTH_ID_SPLICE $1)))) } 
+	| '$(' exp ')'   	{ LL $ HsSpliceE (mkHsSplice $2) }               
 
 
 	| TH_VAR_QUOTE qvar 	{ LL $ HsBracket (VarBr (unLoc $2)) }
@@ -1635,11 +1639,10 @@ fbinds1	:: { ([HsRecField RdrName (LHsExpr RdrName)], Bool) }
 	| '..'				{ ([],   True) }
   
 fbind	:: { HsRecField RdrName (LHsExpr RdrName) }
-	: qvar '=' exp	{ HsRecField $1 $3 False }
-        | qvar          { HsRecField $1 (L (getLoc $1) placeHolderPunRhs) 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
+	: qvar '=' exp	{ HsRecField $1 $3                False }
+        | qvar          { HsRecField $1 placeHolderPunRhs True }
+			-- In the punning case, use a place-holder
+                        -- The renamer fills in the final value
 
 -----------------------------------------------------------------------------
 -- Implicit Parameter Bindings