X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FParser.y;h=d5c3f278cd981893a23941080220353eb37a98f5;hb=197a5ee77b09028ce768a8c3d1eb42fda670e161;hp=d82fe3f28521b82490198d00ef2a030696c6393b;hpb=99073d876ea762016683fb0b22b9d343ff864eb4;p=ghc-hetmet.git

diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y
index d82fe3f..d5c3f27 100644
--- a/ghc/compiler/parser/Parser.y
+++ b/ghc/compiler/parser/Parser.y
@@ -1,6 +1,6 @@
 {-
 -----------------------------------------------------------------------------
-$Id: Parser.y,v 1.43 2000/10/24 08:40:10 simonpj Exp $
+$Id: Parser.y,v 1.56 2001/04/05 11:54:37 simonpj Exp $
 
 Haskell grammar.
 
@@ -9,19 +9,19 @@ Author(s): Simon Marlow, Sven Panne 1997, 1998, 1999
 -}
 
 {
-module Parser ( parse ) where
+module Parser ( parseModule, parseStmt ) where
 
 import HsSyn
-import HsPragmas
 import HsTypes		( mkHsTupCon )
-import HsPat            ( InPat(..) )
 
 import RdrHsSyn
 import Lex
 import ParseUtil
 import RdrName
-import PrelInfo		( mAIN_Name )
-import OccName		( UserFS, varName, ipName, tcName, dataName, tcClsName, tvName )
+import PrelNames	( mAIN_Name, unitTyCon_RDR, funTyCon_RDR, listTyCon_RDR,
+			  tupleTyCon_RDR, unitCon_RDR, nilCon_RDR, tupleCon_RDR
+			)
+import OccName		( UserFS, varName, tcName, dataName, tcClsName, tvName )
 import SrcLoc		( SrcLoc )
 import Module
 import CallConv
@@ -90,7 +90,7 @@ Conflicts: 14 shift/reduce
  'then' 	{ ITthen }
  'type' 	{ ITtype }
  'where' 	{ ITwhere }
- '_scc_'	{ ITscc }
+ '_scc_'	{ ITscc }	      -- ToDo: remove
 
  'forall'	{ ITforall }			-- GHC extension keywords
  'foreign'	{ ITforeign }
@@ -111,6 +111,7 @@ Conflicts: 14 shift/reduce
  '{-# INLINE'      { ITinline_prag }
  '{-# NOINLINE'    { ITnoinline_prag }
  '{-# RULES'	   { ITrules_prag }
+ '{-# SCC'	   { ITscc_prag }
  '{-# DEPRECATED'  { ITdeprecated_prag }
  '#-}'		   { ITclose_prag }
 
@@ -198,7 +199,8 @@ Conflicts: 14 shift/reduce
 
 %monad { P } { thenP } { returnP }
 %lexer { lexer } { ITeof }
-%name parse
+%name parseModule module
+%name parseStmt   maybe_stmt
 %tokentype { Token }
 %%
 
@@ -278,7 +280,7 @@ importdecls :: { [RdrNameImportDecl] }
 
 importdecl :: { RdrNameImportDecl }
 	: 'import' srcloc maybe_src optqualified CONID maybeas maybeimpspec 
-		{ ImportDecl (mkSrcModuleFS $5) $3 $4 $6 $7 $2 }
+		{ ImportDecl (mkModuleNameFS $5) $3 $4 $6 $7 $2 }
 
 maybe_src :: { WhereFrom }
 	: '{-# SOURCE' '#-}'			{ ImportByUserSource }
@@ -326,7 +328,11 @@ topdecls :: { [RdrBinding] }
 	| topdecl			{ [$1] }
 
 topdecl :: { RdrBinding }
-	: srcloc 'type' simpletype '=' sigtype	
+	: srcloc 'type' simpletype '=' ctype	
+		-- Note ctype, not sigtype.
+		-- We allow an explicit for-all but we don't insert one
+		-- in 	type Foo a = (b,b)
+		-- Instead we just say b is out of scope
 		{ RdrHsDecl (TyClD (TySynonym (fst $3) (snd $3) $5 $1)) }
 
 	| srcloc 'data' ctype '=' constrs deriving
@@ -345,7 +351,7 @@ topdecl :: { RdrBinding }
 			(binds,sigs) = cvMonoBindsAndSigs cvClassOpSig (groupBindings $5) 
 		   in
 	 	   returnP (RdrHsDecl (TyClD
-		      (mkClassDecl cs c ts $4 sigs binds $1))) }
+		      (mkClassDecl cs c ts $4 sigs (Just binds) $1))) }
 
 	| srcloc 'instance' inst_type where
 		{ let (binds,sigs) 
@@ -535,7 +541,7 @@ inst_type :: { RdrNameHsType }
 	: ctype				{% checkInstType $1 }
 
 types0  :: { [RdrNameHsType] }
-	: types				{ $1 }
+	: types				{ reverse $1 }
 	| {- empty -}			{ [] }
 
 types	:: { [RdrNameHsType] }
@@ -691,19 +697,23 @@ exp10 :: { RdrNameHsExpr }
 	| 'if' srcloc exp 'then' exp 'else' exp { HsIf $3 $5 $7 $2 }
    	| 'case' srcloc exp 'of' altslist	{ HsCase $3 $5 $2 }
 	| '-' fexp				{ mkHsNegApp $2 }
-  	| srcloc 'do' stmtlist			{ HsDo DoStmt $3 $1 }
+  	| srcloc 'do' stmtlist			{ HsDo DoExpr $3 $1 }
 
 	| '_ccall_'    ccallid aexps0		{ HsCCall $2 $3 False False cbot }
 	| '_ccall_GC_' ccallid aexps0		{ HsCCall $2 $3 True  False cbot }
 	| '_casm_'     CLITLIT aexps0		{ HsCCall $2 $3 False True  cbot }
 	| '_casm_GC_'  CLITLIT aexps0		{ HsCCall $2 $3 True  True  cbot }
 
-        | '_scc_' STRING exp    		{ if opt_SccProfilingOn
-							then HsSCC $2 $3
-							else HsPar $3 }
+        | scc_annot exp		    		{ if opt_SccProfilingOn
+							then HsSCC $1 $2
+							else HsPar $2 }
 
 	| fexp					{ $1 }
 
+scc_annot :: { FAST_STRING }
+	: '_scc_' STRING			{ $2 }
+	| '{-# SCC' STRING '#-}'		{ $2 }
+
 ccallid :: { FAST_STRING }
 	:  VARID				{ $1 }
 	|  CONID				{ $1 }
@@ -733,8 +743,8 @@ aexp1	:: { RdrNameHsExpr }
 	: ipvar				{ HsIPVar $1 }
 	| var_or_con			{ $1 }
 	| literal			{ HsLit $1 }
-	| INTEGER			{ HsOverLit (mkHsIntegralLit $1) }
-	| RATIONAL			{ HsOverLit (mkHsFractionalLit $1) }
+	| INTEGER			{ HsOverLit (HsIntegral   $1) }
+	| RATIONAL			{ HsOverLit (HsFractional $1) }
 	| '(' exp ')'			{ HsPar $2 }
 	| '(' exp ',' texps ')'		{ ExplicitTuple ($2 : reverse $4) Boxed}
 	| '(#' texps '#)'		{ ExplicitTuple (reverse $2)      Unboxed }
@@ -763,8 +773,14 @@ list :: { RdrNameHsExpr }
 	| exp ',' exp '..' 		{ ArithSeqIn (FromThen $1 $3) }
 	| exp '..' exp	 		{ ArithSeqIn (FromTo $1 $3) }
 	| exp ',' exp '..' exp		{ ArithSeqIn (FromThenTo $1 $3 $5) }
-	| exp srcloc '|' quals			{ HsDo ListComp (reverse 
-						(ReturnStmt $1 : $4)) $2 }
+	| exp srcloc pquals		{% let { body [qs] = qs;
+					         body  qss = [ParStmt (map reverse qss)] }
+					   in
+					   returnP ( HsDo ListComp
+							   (reverse (ExprStmt $1 $2 : body $3))
+							   $2
+						  )
+					}
 
 lexps :: { [RdrNameHsExpr] }
 	: lexps ',' exp 		{ $3 : $1 }
@@ -773,15 +789,13 @@ lexps :: { [RdrNameHsExpr] }
 -----------------------------------------------------------------------------
 -- List Comprehensions
 
-quals :: { [RdrNameStmt] }
-	: quals ',' qual		{ $3 : $1 }
-	| qual				{ [$1] }
+pquals :: { [[RdrNameStmt]] }
+	: pquals '|' quals		{ $3 : $1 }
+	| '|' quals			{ [$2] }
 
-qual  :: { RdrNameStmt }
-	: srcloc infixexp '<-' exp	{% checkPattern $2 `thenP` \p ->
-					   returnP (BindStmt p $4 $1) }
-	| srcloc exp			{ GuardStmt $2 $1 }
-  	| srcloc 'let' declbinds	{ LetStmt $3 }
+quals :: { [RdrNameStmt] }
+	: quals ',' stmt		{ $3 : $1 }
+	| stmt				{ [$1] }
 
 -----------------------------------------------------------------------------
 -- Case alternatives
@@ -836,6 +850,12 @@ stmts1 :: { [RdrNameStmt] }
 	| stmts1 ';'			{ $1 }
 	| stmt 				{ [$1] }
 
+-- for typing stmts at the GHCi prompt, where the input may consist of
+-- just comments.
+maybe_stmt :: { Maybe RdrNameStmt }
+	: stmt				{ Just $1 }
+	| {- nothing -}			{ Nothing }
+
 stmt  :: { RdrNameStmt }
 	: srcloc infixexp '<-' exp	{% checkPattern $2 `thenP` \p ->
 					   returnP (BindStmt p $4 $1) }
@@ -875,7 +895,7 @@ dbind	: ipvar '=' exp			{ ($1, $3) }
 
 depreclist :: { [RdrName] }
 depreclist : deprec_var			{ [$1] }
-	   | deprec_var ',' depreclist	{ $1 : $2 }
+	   | deprec_var ',' depreclist	{ $1 : $3 }
 
 deprec_var :: { RdrName }
 deprec_var : var			{ $1 }
@@ -908,7 +928,7 @@ qvar 	:: { RdrName }
 -- *after* we see the close paren.
 
 ipvar	:: { RdrName }
-	: IPVARID		{ (mkUnqual ipName (tailFS $1)) }
+	: IPVARID		{ (mkUnqual varName (tailFS $1)) }
 
 qcon	:: { RdrName }
 	: qconid		{ $1 }
@@ -1061,7 +1081,7 @@ layout_on_for_do  :: { () }	: {% layoutOn False }
 -- Miscellaneous (mostly renamings)
 
 modid 	:: { ModuleName }
-	: CONID			{ mkSrcModuleFS $1 }
+	: CONID			{ mkModuleNameFS $1 }
 
 tycon 	:: { RdrName }
 	: CONID			{ mkUnqual tcClsName $1 }