[project @ 2003-07-16 15:27:36 by sof]

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

diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y
index 5ca2359..1802117 100644 (file)
--- a/ghc/compiler/parser/Parser.y
+++ b/ghc/compiler/parser/Parser.y
@@ -1,6 +1,6 @@
 {-                                                             -*-haskell-*-
 -----------------------------------------------------------------------------
-$Id: Parser.y,v 1.118 2003/05/19 15:10:40 simonpj Exp $
+$Id: Parser.y,v 1.121 2003/07/16 08:49:05 ross Exp $
 
 Haskell grammar.
 
@@ -130,6 +130,8 @@ Conflicts: 29 shift/reduce, [SDM 19/9/2002]
  'stdcall'      { ITstdcallconv }
  'ccall'        { ITccallconv }
  'dotnet'       { ITdotnet }
+ 'proc'                { ITproc }              -- for arrow notation extension
+ 'rec'         { ITrec }               -- for arrow notation extension
  '_ccall_'     { ITccall (False, False, PlayRisky) }
  '_ccall_GC_'  { ITccall (False, False, PlaySafe False) }
  '_casm_'      { ITccall (False, True,  PlayRisky) }
@@ -189,6 +191,10 @@ Conflicts: 29 shift/reduce, [SDM 19/9/2002]
  '-'           { ITminus }
  '!'           { ITbang }
  '*'           { ITstar }
+ '-<'          { ITlarrowtail }                -- for arrow notation
+ '>-'          { ITrarrowtail }                -- for arrow notation
+ '-<<'         { ITLarrowtail }                -- for arrow notation
+ '>>-'         { ITRarrowtail }                -- for arrow notation
  '.'           { ITdot }
 
  '{'           { ITocurly }                    -- special symbols
@@ -204,6 +210,8 @@ Conflicts: 29 shift/reduce, [SDM 19/9/2002]
  ')'           { ITcparen }
  '(#'          { IToubxparen }
  '#)'          { ITcubxparen }
+ '(|'          { IToparenbar }
+ '|)'          { ITcparenbar }
  ';'           { ITsemi }
  ','           { ITcomma }
  '`'           { ITbackquote }
@@ -265,19 +273,9 @@ REIFY_FIXITY       { ITreifyFixity }
 
 module         :: { RdrNameHsModule }
        : srcloc 'module' modid maybemoddeprec maybeexports 'where' body 
-               { HsModule (mkHomeModule $3) Nothing $5 (fst $7) (snd $7) $4 $1 }
+               { HsModule (Just (mkHomeModule $3)) $5 (fst $7) (snd $7) $4 $1 }
        | srcloc body
-               {       -- Behave as if we'd said 
-                       --      module Main( main ) where ...
-                 let
-                       main_RDR_Unqual = mkUnqual varName FSLIT("main")
-                       -- We definitely don't want an Orig RdrName, because
-                       -- main might, in principle, be imported into module Main
-                 in
-                 HsModule (mkHomeModule mAIN_Name) 
-                          Nothing 
-                          (Just [IEVar main_RDR_Unqual])
-                          (fst $2) (snd $2) Nothing $1 }
+               { HsModule Nothing Nothing (fst $2) (snd $2) Nothing $1 }
 
 maybemoddeprec :: { Maybe DeprecTxt }
        : '{-# DEPRECATED' STRING '#-}'         { Just $2 }
@@ -937,6 +935,10 @@ sigdecl :: { RdrBinding }
 exp   :: { RdrNameHsExpr }
        : infixexp '::' sigtype         { ExprWithTySig $1 $3 }
        | infixexp 'with' dbinding      { HsLet (IPBinds $3 True{-not a let-}) $1 }
+       | fexp srcloc '-<' exp          { HsArrApp $1 $4 placeHolderType HsFirstOrderApp True $2 }
+       | fexp srcloc '>-' exp          { HsArrApp $4 $1 placeHolderType HsFirstOrderApp False $2 }
+       | fexp srcloc '-<<' exp         { HsArrApp $1 $4 placeHolderType HsHigherOrderApp True $2 }
+       | fexp srcloc '>>-' exp         { HsArrApp $4 $1 placeHolderType HsHigherOrderApp False $2 }
        | infixexp                      { $1 }
 
 infixexp :: { RdrNameHsExpr }
@@ -968,6 +970,10 @@ exp10 :: { RdrNameHsExpr }
                                                        then HsSCC $1 $2
                                                        else HsPar $2 }
 
+       | 'proc' srcloc aexp '->' srcloc exp    
+                       {% checkPattern $2 $3 `thenP` \ p -> 
+                          returnP (HsProc p (HsCmdTop $6 [] placeHolderType undefined) $5) }
+
         | '{-# CORE' STRING '#-}' exp           { HsCoreAnn $2 $4 }    -- hdaume: core annotation
 
        | reifyexp                              { HsReify $1 }
@@ -1036,6 +1042,17 @@ aexp2    :: { RdrNameHsExpr }
                                           returnP (HsBracket (PatBr p) $1) }
        | srcloc '[d|' cvtopbody '|]'   { HsBracket (DecBr (mkGroup $3)) $1 }
 
+       -- arrow notation extension
+       | srcloc '(|' aexp2 cmdargs '|)'
+                                       { HsArrForm $3 Nothing (reverse $4) $1 }
+
+cmdargs        :: { [RdrNameHsCmdTop] }
+       : cmdargs acmd                  { $2 : $1 }
+       | {- empty -}                   { [] }
+
+acmd   :: { RdrNameHsCmdTop }
+       : aexp2                         { HsCmdTop $1 [] placeHolderType undefined }
+
 cvtopbody :: { [RdrNameHsDecl] }
        :  '{'            cvtopdecls '}'                { $2 }
        |      layout_on  cvtopdecls close              { $2 }
@@ -1058,13 +1075,9 @@ list :: { RdrNameHsExpr }
        | exp ',' exp '..'              { ArithSeqIn (FromThen $1 $3) }
        | exp '..' exp                  { ArithSeqIn (FromTo $1 $3) }
        | exp ',' exp '..' exp          { ArithSeqIn (FromThenTo $1 $3 $5) }
-       | exp srcloc pquals             {% let { body [qs] = qs;
-                                                body  qss = [ParStmt (map reverse qss)] }
-                                          in
-                                          returnP ( mkHsDo ListComp
-                                                           (reverse (ResultStmt $1 $2 : body $3))
-                                                           $2
-                                                 )
+       | exp srcloc pquals             { mkHsDo ListComp
+                                                (reverse (ResultStmt $1 $2 : $3))
+                                                $2
                                        }
 
 lexps :: { [RdrNameHsExpr] }
@@ -1074,13 +1087,22 @@ lexps :: { [RdrNameHsExpr] }
 -----------------------------------------------------------------------------
 -- List Comprehensions
 
-pquals :: { [[RdrNameStmt]] }
-       : pquals '|' quals              { $3 : $1 }
+pquals :: { [RdrNameStmt] }    -- Either a singleton ParStmt, or a reversed list of Stmts
+       : pquals1                       { case $1 of
+                                           [qs] -> qs
+                                           qss  -> [ParStmt stmtss]
+                                                where
+                                                   stmtss = [ (reverse qs, undefined) 
+                                                            | qs <- qss ]
+                                       }
+                       
+pquals1 :: { [[RdrNameStmt]] }
+       : pquals1 '|' quals             { $3 : $1 }
        | '|' quals                     { [$2] }
 
 quals :: { [RdrNameStmt] }
-       : quals ',' stmt                { $3 : $1 }
-       | stmt                          { [$1] }
+       : quals ',' qual                { $3 : $1 }
+       | qual                          { [$1] }
 
 -----------------------------------------------------------------------------
 -- Parallel array expressions
@@ -1097,16 +1119,9 @@ parr :: { RdrNameHsExpr }
                                                       (reverse $1) }
        | exp '..' exp                  { PArrSeqIn (FromTo $1 $3) }
        | exp ',' exp '..' exp          { PArrSeqIn (FromThenTo $1 $3 $5) }
-       | exp srcloc pquals             {% let {
-                                            body [qs] = qs;
-                                            body  qss = [ParStmt 
-                                                          (map reverse qss)]}
-                                          in
-                                          returnP $ 
-                                            mkHsDo PArrComp 
-                                                   (reverse (ResultStmt $1 $2 
-                                                            : body $3))
-                                                   $2
+       | exp srcloc pquals             {  mkHsDo PArrComp 
+                                                 (reverse (ResultStmt $1 $2 : $3))
+                                                 $2
                                        }
 
 -- We are reusing `lexps' and `pquals' from the list case.
@@ -1172,6 +1187,12 @@ maybe_stmt :: { Maybe RdrNameStmt }
        | {- nothing -}                 { Nothing }
 
 stmt  :: { RdrNameStmt }
+       : qual                          { $1 }
+       | srcloc infixexp '->' exp      {% checkPattern $1 $4 `thenP` \p ->
+                                          returnP (BindStmt p $2 $1) }
+       | srcloc 'rec' stmtlist         { RecStmt $3 undefined undefined undefined }
+
+qual  :: { RdrNameStmt }
        : srcloc infixexp '<-' exp      {% checkPattern $1 $2 `thenP` \p ->
                                           returnP (BindStmt p $4 $1) }
        | srcloc exp                    { ExprStmt $2 placeHolderType $1 }