[project @ 1999-06-28 15:42:33 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 4a8d726..f97ff96 100644 (file)
--- a/ghc/compiler/parser/Parser.y
+++ b/ghc/compiler/parser/Parser.y
@@ -1,6 +1,6 @@
 {-
 -----------------------------------------------------------------------------
-$Id: Parser.y,v 1.1 1999/06/01 16:40:48 simonmar Exp $
+$Id: Parser.y,v 1.8 1999/06/28 15:42:33 simonmar Exp $
 
 Haskell grammar.
 
@@ -23,6 +23,7 @@ import OccName                ( varName, dataName, tcClsName, tvName )
 import SrcLoc          ( SrcLoc )
 import Module
 import CallConv
+import CmdLineOpts     ( opt_SccProfilingOn )
 import BasicTypes      ( Fixity(..), FixityDirection(..), NewOrData(..) )
 import Panic
 
@@ -33,7 +34,7 @@ import GlaExts
 
 {-
 -----------------------------------------------------------------------------
-Conflicts: 13 shift/reduce
+Conflicts: 14 shift/reduce
 
 8 for abiguity in 'if x then y else z + 1'
        (shift parses as 'if x then y else (z + 1)', as per longest-parse rule)
@@ -51,12 +52,15 @@ Conflicts: 13 shift/reduce
        This saves explicitly defining a grammar for the rule lhs that
        doesn't include 'forall'.
 
+1 for ambiguity in 'x @ Rec{..}'.  
+       Only sensible parse is 'x @ (Rec{..})', which is what resolving
+       to shift gives us.
+
 -----------------------------------------------------------------------------
 -}
 
 %token
  '_'            { ITunderscore }               -- Haskell keywords
- 'as'          { ITas }
  'case'        { ITcase }      
  'class'       { ITclass } 
  'data'        { ITdata } 
@@ -64,7 +68,6 @@ Conflicts: 13 shift/reduce
  'deriving'    { ITderiving }
  'do'          { ITdo }
  'else'        { ITelse }
- 'hiding'      { IThiding }
  'if'          { ITif }
  'import'      { ITimport }
  'in'          { ITin }
@@ -76,10 +79,10 @@ Conflicts: 13 shift/reduce
  'module'      { ITmodule }
  'newtype'     { ITnewtype }
  'of'          { ITof }
- 'qualified'   { ITqualified }
  'then'        { ITthen }
  'type'        { ITtype }
  'where'       { ITwhere }
+ '_scc_'       { ITscc }
 
  'forall'      { ITforall }                    -- GHC extension keywords
  'foreign'     { ITforeign }
@@ -117,7 +120,7 @@ Conflicts: 13 shift/reduce
  '__litlit'    { ITlit_lit }
  '__string'    { ITstring_lit }
  '__ccall'     { ITccall $$ }
- '__scc'       { ITscc }
+ '__scc'       { IT__scc }
  '__sccC'       { ITsccAllCafs }
 
  '__A'         { ITarity }
@@ -429,8 +432,7 @@ rules       :: { RdrBinding }
 
 rule   :: { RdrBinding }
        : STRING rule_forall fexp '=' srcloc exp
-            { RdrHsDecl (RuleD (RuleDecl $1 (error "rule tyvars") 
-                 $2 $3 $6 $5)) }
+            { RdrHsDecl (RuleD (RuleDecl $1 [] $2 $3 $6 $5)) }
 
 rule_forall :: { [RdrNameRuleBndr] }
        : 'forall' rule_var_list '.'            { $2 }
@@ -496,12 +498,10 @@ inst_type :: { RdrNameHsType }
        : ctype                         {% checkInstType $1 }
 
 ctype  :: { RdrNameHsType }
-       : 'forall' tyvars '.' btype '=>' type
-                                       {% checkContext $4 `thenP` \c ->
-                                          returnP (HsForAllTy (Just $2) c $6) }
+       : 'forall' tyvars '.' context type
+                                       { HsForAllTy (Just $2) $4 $5 }
        | 'forall' tyvars '.' type      { HsForAllTy (Just $2) [] $4 }
-       | btype '=>' type               {% checkContext $1 `thenP` \c ->
-                                          returnP (HsForAllTy Nothing c $3) }
+       | context type                  { HsForAllTy Nothing   $1 $2 }
        | type                          { $1 }
 
 types0  :: { [RdrNameHsType] }
@@ -526,15 +526,23 @@ constrs :: { [RdrNameConDecl] }
        : constrs '|' constr            { $3 : $1 }
        | constr                        { [$1] }
 
-{- ToDo: existential stuff -}
-
 constr :: { RdrNameConDecl }
-       : srcloc scontype   
-               { ConDecl (fst $2) [] [] (VanillaCon (snd $2)) $1 }
-       | srcloc sbtype conop sbtype    
-               { ConDecl $3 [] [] (InfixCon $2 $4) $1 }
-       | srcloc con '{' fielddecls '}' 
-               { ConDecl $2 [] [] (RecCon (reverse $4)) $1 }
+       : srcloc forall context constr_stuff
+               { ConDecl (fst $4) $2 $3 (snd $4) $1 }
+       | srcloc forall constr_stuff
+               { ConDecl (fst $3) $2 [] (snd $3) $1 }
+
+forall :: { [RdrNameHsTyVar] }
+       : 'forall' tyvars '.'           { $2 }
+       | {- empty -}                   { [] }
+
+context :: { RdrNameContext }
+       : btype '=>'                    {% checkContext $1 }
+
+constr_stuff :: { (RdrName, RdrNameConDetails) }
+       : scontype                      { (fst $1, VanillaCon (snd $1)) }
+       | sbtype conop sbtype           { ($2, InfixCon $1 $3) }
+       | con '{' fielddecls '}'        { ($1, RecCon (reverse $3)) }
 
 newconstr :: { RdrNameConDecl }
        : srcloc conid atype    { ConDecl $2 [] [] (NewCon $3 Nothing) $1 }
@@ -626,6 +634,10 @@ exp10 :: { RdrNameHsExpr }
        | '_casm_'     CLITLIT aexps0           { CCall $2 $3 False True  cbot }
        | '_casm_GC_'  CLITLIT aexps0           { CCall $2 $3 True  True  cbot }
 
+        | '_scc_' STRING exp                   { if opt_SccProfilingOn
+                                                       then HsSCC $2 $3
+                                                       else HsPar $3 }
+
        | fexp                                  { $1 }
 
 ccallid :: { FAST_STRING }
@@ -657,7 +669,7 @@ aexp1       :: { RdrNameHsExpr }
        | '[' list ']'                  { $2 }
        | '(' infixexp qop ')'          { SectionL $2 $3  }
        | '(' qopm infixexp ')'         { SectionR $2 $3 }
-       | qvar '@' aexp1                { EAsPat $1 $3 }
+       | qvar '@' aexp                 { EAsPat $1 $3 }
        | '_'                           { EWildPat }
        | '~' aexp1                     { ELazyPat $2 }
 
@@ -749,10 +761,13 @@ stmtlist :: { [RdrNameStmt] }
        |     layout_on  stmts close    { reverse $2 }
 
 stmts :: { [RdrNameStmt] }
-       : stmts ';' stmt                { $3 : $1 }
-       | stmts ';'                     { $1 }
+       : ';' stmts1                    { $2 }
+       | stmts1                        { $1 }
+
+stmts1 :: { [RdrNameStmt] }
+       : stmts1 ';' stmt               { $3 : $1 }
+       | stmts1 ';'                    { $1 }
        | stmt                          { [$1] }
-       | {- empty -}                   { [] }
 
 stmt  :: { RdrNameStmt }
        : srcloc infixexp '<-' exp      {% checkPattern $2 `thenP` \p ->
@@ -842,9 +857,6 @@ qvarid :: { RdrName }
 
 varid :: { RdrName }
        : VARID                 { mkSrcUnqual varName $1 }
-       | 'as'                  { as_var_RDR }
-       | 'qualified'           { qualified_var_RDR }
-       | 'hiding'              { hiding_var_RDR }
        | 'forall'              { forall_var_RDR }
        | 'export'              { export_var_RDR }
        | 'label'               { label_var_RDR }
@@ -853,14 +865,16 @@ varid :: { RdrName }
 
 varid_no_unsafe :: { RdrName }
        : VARID                 { mkSrcUnqual varName $1 }
-       | 'as'                  { as_var_RDR }
-       | 'qualified'           { qualified_var_RDR }
-       | 'hiding'              { hiding_var_RDR }
        | 'forall'              { forall_var_RDR }
        | 'export'              { export_var_RDR }
        | 'label'               { label_var_RDR }
        | 'dynamic'             { dynamic_var_RDR }
 
+-- ``special'' Ids
+'as'       :: { () } : VARID   {% checkAs $1 }
+'qualified' :: { () } : VARID  {% checkQualified $1 }
+'hiding'    :: { () } : VARID  {% checkHiding $1 }
+
 -----------------------------------------------------------------------------
 -- ConIds
 
@@ -952,9 +966,6 @@ qtycls      :: { RdrName }
 
 tyvar  :: { RdrName }
        : VARID                 { mkSrcUnqual tvName $1 }
-       | 'as'                  { as_tyvar_RDR }
-       | 'qualified'           { qualified_tyvar_RDR }
-       | 'hiding'              { hiding_tyvar_RDR }
        | 'export'              { export_var_RDR }
        | 'label'               { label_var_RDR }
        | 'dynamic'             { dynamic_var_RDR }