X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FParser.y;h=11dc6dc7a42f93046854971e1e94e0b140f1b957;hb=d28ba8c800901bea01f70c4719278c2a364cf9fc;hp=f5993d1488ebec55b01185c5772e27be95293e2a;hpb=4ef18ea237ee070678970dbdd49714014dd9efbf;p=ghc-hetmet.git

diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y
index f5993d1..11dc6dc 100644
--- a/ghc/compiler/parser/Parser.y
+++ b/ghc/compiler/parser/Parser.y
@@ -1,6 +1,6 @@
 {-								-*-haskell-*-
 -----------------------------------------------------------------------------
-$Id: Parser.y,v 1.113 2002/10/25 15:23:06 simonpj Exp $
+$Id: Parser.y,v 1.119 2003/06/23 10:35:22 simonpj Exp $
 
 Haskell grammar.
 
@@ -21,13 +21,14 @@ import HscTypes		( ParsedIface(..), IsBootInterface, noDependencies )
 import Lex
 import RdrName
 import PrelNames	( mAIN_Name, funTyConName, listTyConName, 
-			  parrTyConName, consDataConName, nilDataConName )
-import TysWiredIn	( unitTyCon, unitDataCon, tupleTyCon, tupleCon )
+			  parrTyConName, consDataConName )
+import TysWiredIn	( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon )
 import ForeignCall	( Safety(..), CExportSpec(..), 
 			  CCallConv(..), CCallTarget(..), defaultCCallConv,
 			)
 import OccName		( UserFS, varName, tcName, dataName, tcClsName, tvName )
 import TyCon		( DataConDetails(..) )
+import DataCon		( DataCon, dataConName )
 import SrcLoc		( SrcLoc )
 import Module
 import CmdLineOpts	( opt_SccProfilingOn, opt_InPackage )
@@ -139,6 +140,7 @@ Conflicts: 29 shift/reduce, [SDM 19/9/2002]
  '{-# INLINE'      { ITinline_prag }
  '{-# NOINLINE'    { ITnoinline_prag }
  '{-# RULES'	   { ITrules_prag }
+ '{-# CORE'        { ITcore_prag }              -- hdaume: annotated core
  '{-# SCC'	   { ITscc_prag }
  '{-# DEPRECATED'  { ITdeprecated_prag }
  '#-}'		   { ITclose_prag }
@@ -263,10 +265,9 @@ REIFY_FIXITY	{ ITreifyFixity }
 
 module 	:: { RdrNameHsModule }
  	: srcloc 'module' modid maybemoddeprec maybeexports 'where' body 
-		{ HsModule (mkHomeModule $3) Nothing $5 (fst $7) (snd $7) $4 $1 }
+		{ HsModule (Just (mkHomeModule $3)) $5 (fst $7) (snd $7) $4 $1 }
 	| srcloc body
-		{ HsModule (mkHomeModule mAIN_Name) Nothing Nothing 
-			   (fst $2) (snd $2) Nothing $1 }
+		{ HsModule Nothing Nothing (fst $2) (snd $2) Nothing $1 }
 
 maybemoddeprec :: { Maybe DeprecTxt }
 	: '{-# DEPRECATED' STRING '#-}' 	{ Just $2 }
@@ -441,7 +442,7 @@ tycl_decl :: { RdrNameTyClDecl }
 		{ let 
 			(binds,sigs) = cvMonoBindsAndSigs $5 
 		  in
-	 	  mkClassDecl $3 $4 (map cvClassOpSig sigs) (Just binds) $1 }
+	 	  mkClassDecl $3 $4 sigs (Just binds) $1 }
 
 syn_hdr :: { (RdrName, [RdrNameHsTyVar]) }	-- We don't retain the syntax of an infix
 						-- type synonym declaration. Oh well.
@@ -957,6 +958,8 @@ exp10 :: { RdrNameHsExpr }
 							then HsSCC $1 $2
 							else HsPar $2 }
 
+        | '{-# CORE' STRING '#-}' exp           { HsCoreAnn $2 $4 }    -- hdaume: core annotation
+
 	| reifyexp				{ HsReify $1 }
 	| fexp					{ $1 }
 
@@ -1021,8 +1024,11 @@ aexp2	:: { RdrNameHsExpr }
 	| srcloc '[t|' ctype '|]'       { HsBracket (TypBr $3) $1 }                       
 	| srcloc '[p|' infixexp '|]'    {% checkPattern $1 $3 `thenP` \p ->
 					   returnP (HsBracket (PatBr p) $1) }
-	| srcloc '[d|' cvtopdecls '|]'	{ HsBracket (DecBr (mkGroup $3)) $1 }
+	| srcloc '[d|' cvtopbody '|]'	{ HsBracket (DecBr (mkGroup $3)) $1 }
 
+cvtopbody :: { [RdrNameHsDecl] }
+	:  '{'            cvtopdecls '}'		{ $2 }
+	|      layout_on  cvtopdecls close		{ $2 }
 
 texps :: { [RdrNameHsExpr] }
 	: texps ',' exp			{ $3 : $1 }
@@ -1206,14 +1212,14 @@ deprec_var : var			{ $1 }
 	   | tycon			{ $1 }
 
 gcon 	:: { RdrName }	-- Data constructor namespace
-	: sysdcon		{ $1 }
+	: sysdcon		{ nameRdrName (dataConName $1) }
  	| qcon			{ $1 }
 -- the case of '[:' ':]' is part of the production `parr'
 
-sysdcon	:: { RdrName }	-- Data constructor namespace
-	: '(' ')'		{ getRdrName unitDataCon }
-	| '(' commas ')'	{ getRdrName (tupleCon Boxed $2) }
-	| '[' ']'		{ nameRdrName nilDataConName }
+sysdcon	:: { DataCon }	-- Wired in data constructors
+	: '(' ')'		{ unitDataCon }
+	| '(' commas ')'	{ tupleCon Boxed $2 }
+	| '[' ']'		{ nilDataCon }
 
 var 	:: { RdrName }
 	: varid			{ $1 }
@@ -1391,8 +1397,10 @@ qconsym :: { RdrName }	-- Qualified or unqualified
 
 consym :: { RdrName }
 	: CONSYM		{ mkUnqual dataName $1 }
-	| ':'			{ nameRdrName consDataConName }
+
 	-- ':' means only list cons
+	| ':'			{ nameRdrName consDataConName }
+				-- NB: SrcName because we are reading source
 
 
 -----------------------------------------------------------------------------