X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FParser.y;h=61a3275c645ab02e2361455a2a772b4d919f3f55;hb=26e23c6a3cba33b4e8846bf92e406974ab87a81a;hp=a3b437d3cd780fd8f27ea647155adbd2cc2b1062;hpb=536a6e2a2f4acfda2ab94231c8071e146c53ecc3;p=ghc-hetmet.git

diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y
index a3b437d..61a3275 100644
--- a/ghc/compiler/parser/Parser.y
+++ b/ghc/compiler/parser/Parser.y
@@ -1,6 +1,6 @@
 {-
 -----------------------------------------------------------------------------
-$Id: Parser.y,v 1.50 2001/01/17 16:54:04 simonmar Exp $
+$Id: Parser.y,v 1.59 2001/05/03 08:08:44 simonpj Exp $
 
 Haskell grammar.
 
@@ -9,18 +9,19 @@ Author(s): Simon Marlow, Sven Panne 1997, 1998, 1999
 -}
 
 {
-module Parser ( parseModule, parseExpr ) where
+module Parser ( parseModule, parseStmt ) where
 
 import HsSyn
 import HsTypes		( mkHsTupCon )
-import HsPat            ( InPat(..) )
 
 import RdrHsSyn
 import Lex
 import ParseUtil
 import RdrName
-import PrelNames
-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
@@ -89,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 }
@@ -110,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 +200,7 @@ Conflicts: 14 shift/reduce
 %monad { P } { thenP } { returnP }
 %lexer { lexer } { ITeof }
 %name parseModule module
-%name parseExpr   exp
+%name parseStmt   maybe_stmt
 %tokentype { Token }
 %%
 
@@ -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
@@ -380,8 +386,8 @@ decls 	:: { [RdrBinding] }
 decl 	:: { RdrBinding }
 	: fixdecl			{ $1 }
 	| valdef			{ $1 }
-	| '{-# INLINE'   srcloc opt_phase qvar '#-}'	{ RdrSig (InlineSig $4 $3 $2) }
-	| '{-# NOINLINE' srcloc opt_phase qvar '#-}'	{ RdrSig (NoInlineSig $4 $3 $2) }
+	| '{-# INLINE'   srcloc opt_phase qvar '#-}'	 { RdrSig (InlineSig $4 $3 $2) }
+	| '{-# NOINLINE' srcloc opt_phase qvar '#-}'	 { RdrSig (NoInlineSig $4 $3 $2) }
 	| '{-# SPECIALISE' srcloc qvar '::' sigtypes '#-}'
 	 	{ foldr1 RdrAndBindings 
 		    (map (\t -> RdrSig (SpecSig $3 t $2)) $5) }
@@ -422,7 +428,7 @@ rules	:: { RdrBinding }
 	|  {- empty -}				{ RdrNullBind }
 
 rule  	:: { RdrBinding }
-	: STRING rule_forall fexp '=' srcloc exp
+	: STRING rule_forall infixexp '=' srcloc exp
 	     { RdrHsDecl (RuleD (HsRule $1 [] $2 $3 $6 $5)) }
 
 rule_forall :: { [RdrNameRuleBndr] }
@@ -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 (HsIntegral   $1 fromInteger_RDR) }
-	| RATIONAL			{ HsOverLit (HsFractional $1 fromRational_RDR) }
+	| INTEGER			{ HsOverLit (HsIntegral   $1) }
+	| RATIONAL			{ HsOverLit (HsFractional $1) }
 	| '(' exp ')'			{ HsPar $2 }
 	| '(' exp ',' texps ')'		{ ExplicitTuple ($2 : reverse $4) Boxed}
 	| '(#' texps '#)'		{ ExplicitTuple (reverse $2)      Unboxed }
@@ -767,7 +777,7 @@ list :: { RdrNameHsExpr }
 					         body  qss = [ParStmt (map reverse qss)] }
 					   in
 					   returnP ( HsDo ListComp
-							   (reverse (ReturnStmt $1 : body $3))
+							   (reverse (ExprStmt $1 $2 : body $3))
 							   $2
 						  )
 					}
@@ -784,14 +794,8 @@ pquals :: { [[RdrNameStmt]] }
 	| '|' quals			{ [$2] }
 
 quals :: { [RdrNameStmt] }
-	: quals ',' qual		{ $3 : $1 }
-	| qual				{ [$1] }
-
-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 ',' stmt		{ $3 : $1 }
+	| stmt				{ [$1] }
 
 -----------------------------------------------------------------------------
 -- Case alternatives
@@ -846,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) }
@@ -918,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 }