[project @ 2001-05-03 16:32:55 by simonmar]

[ghc-hetmet.git] / ghc / compiler / parser / Parser.y

diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y
index a3b437d..61a3275 100644 (file)
--- 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 }