[project @ 1999-07-27 07:31:16 by simonpj]

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

diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y
index 2e7eac9..066bc1c 100644 (file)
--- a/ghc/compiler/parser/Parser.y
+++ b/ghc/compiler/parser/Parser.y
@@ -1,6 +1,6 @@
 {-
 -----------------------------------------------------------------------------
-$Id: Parser.y,v 1.3 1999/06/02 15:50:25 simonmar Exp $
+$Id: Parser.y,v 1.12 1999/07/27 07:31:18 simonpj Exp $
 
 Haskell grammar.
 
@@ -34,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)
@@ -52,6 +52,10 @@ 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.
+
 -----------------------------------------------------------------------------
 -}
 
@@ -399,9 +403,7 @@ signdecl :: { RdrBinding }
                                              [ RdrSig (Sig n $4 $2) | n <- $1 ] }
 
 sigtype :: { RdrNameHsType }
-       : ctype                 { case $1 of
-                                   HsForAllTy _ _ _ -> $1
-                                   other            -> HsForAllTy Nothing [] $1 }
+       : ctype                 { mkHsForAllTy Nothing [] $1 }
 
 {-
   ATTENTION: Dirty Hackery Ahead! If the second alternative of vars is var
@@ -497,12 +499,11 @@ inst_type :: { RdrNameHsType }
        : ctype                         {% checkInstType $1 }
 
 ctype  :: { RdrNameHsType }
-       : 'forall' tyvars '.' btype '=>' type
-                                       {% checkContext $4 `thenP` \c ->
-                                          returnP (HsForAllTy (Just $2) c $6) }
-       | 'forall' tyvars '.' type      { HsForAllTy (Just $2) [] $4 }
-       | btype '=>' type               {% checkContext $1 `thenP` \c ->
-                                          returnP (HsForAllTy Nothing c $3) }
+       : 'forall' tyvars '.' context type
+                                       { mkHsForAllTy (Just $2) $4 $5 }
+       | 'forall' tyvars '.' type      { mkHsForAllTy (Just $2) [] $4 }
+       | context type                  { mkHsForAllTy Nothing   $1 $2 }
+               -- A type of form (context => type) is an *implicit* HsForAllTy
        | type                          { $1 }
 
 types0  :: { [RdrNameHsType] }
@@ -527,15 +528,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 }
@@ -629,7 +638,7 @@ exp10 :: { RdrNameHsExpr }
 
         | '_scc_' STRING exp                   { if opt_SccProfilingOn
                                                        then HsSCC $2 $3
-                                                       else $3 }
+                                                       else HsPar $3 }
 
        | fexp                                  { $1 }
 
@@ -662,7 +671,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 }
 
@@ -750,14 +759,20 @@ gdpat     :: { RdrNameGRHS }
 -- Statement sequences
 
 stmtlist :: { [RdrNameStmt] }
-       : '{'            stmts '}'      { reverse $2 }
-       |     layout_on  stmts close    { reverse $2 }
+       : '{'                   stmts '}'       { $2 }
+       |     layout_on_for_do  stmts close     { $2 }
 
+-- Stmt list must end in an expression
+-- thought the H98 report doesn't currently say so in the syntax
 stmts :: { [RdrNameStmt] }
-       : stmts ';' stmt                { $3 : $1 }
-       | stmts ';'                     { $1 }
-       | stmt                          { [$1] }
-       | {- empty -}                   { [] }
+       : stmts1 srcloc exp             { reverse (ExprStmt $3 $2 : $1) }
+
+-- A list of zero or more stmts, ending in semicolon
+-- Returned in *reverse* order
+stmts1 :: { [RdrNameStmt] }
+       : stmts1 stmt ';'               { $2 : $1 }
+       | stmts1 ';'                    { $1 }
+       |                               { [] }
 
 stmt  :: { RdrNameStmt }
        : srcloc infixexp '<-' exp      {% checkPattern $2 `thenP` \p ->
@@ -936,7 +951,8 @@ close :: { () }
        : vccurly               { () } -- context popped in lexer.
        | error                 {% popContext }
 
-layout_on  :: { () }   :       {% layoutOn  }
+layout_on        :: { () }     : {% layoutOn True{-strict-} }
+layout_on_for_do  :: { () }    : {% layoutOn False }
 
 -----------------------------------------------------------------------------
 -- Miscellaneous (mostly renamings)