[project @ 2000-02-20 17:51:30 by panne]

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

diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y
index 811607a..2f907b0 100644 (file)
--- a/ghc/compiler/parser/Parser.y
+++ b/ghc/compiler/parser/Parser.y
@@ -1,6 +1,6 @@
 {-
 -----------------------------------------------------------------------------
-$Id: Parser.y,v 1.17 1999/11/30 16:10:11 lewie Exp $
+$Id: Parser.y,v 1.23 2000/02/20 17:51:45 panne Exp $
 
 Haskell grammar.
 
@@ -19,7 +19,7 @@ import Lex
 import ParseUtil
 import RdrName
 import PrelMods                ( mAIN_Name )
-import OccName         ( varName, dataName, tcClsName, tvName )
+import OccName         ( varName, ipName, dataName, tcClsName, tvName )
 import SrcLoc          ( SrcLoc )
 import Module
 import CallConv
@@ -35,6 +35,8 @@ import GlaExts
 {-
 -----------------------------------------------------------------------------
 Conflicts: 14 shift/reduce
+       (note: it's currently 21 -- JRL, 31/1/2000)
+        (note2: it's currently 36, but not because of me -- SUP, 15/2/2000 :-)
 
 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)
@@ -93,6 +95,7 @@ Conflicts: 14 shift/reduce
  'label'       { ITlabel } 
  'dynamic'     { ITdynamic }
  'unsafe'      { ITunsafe }
+ 'with'        { ITwith }
  'stdcall'      { ITstdcallconv }
  'ccall'        { ITccallconv }
  '_ccall_'     { ITccall (False, False, False) }
@@ -105,6 +108,7 @@ Conflicts: 14 shift/reduce
  '{-# INLINE'      { ITinline_prag }
  '{-# NOINLINE'    { ITnoinline_prag }
  '{-# RULES'      { ITrules_prag }
+ '{-# DEPRECATED'  { ITdeprecated_prag }
  '#-}'            { ITclose_prag }
 
 {-
@@ -174,6 +178,8 @@ Conflicts: 14 shift/reduce
  QVARSYM       { ITqvarsym  $$ }
  QCONSYM       { ITqconsym  $$ }
 
+ IPVARID       { ITipvarid  $$ }               -- GHC extension
+
  PRAGMA                { ITpragma   $$ }
 
  CHAR          { ITchar     $$ }
@@ -185,7 +191,7 @@ Conflicts: 14 shift/reduce
  PRIMSTRING    { ITprimstring $$ }
  PRIMINTEGER   { ITprimint    $$ }
  PRIMFLOAT     { ITprimfloat  $$ }
- PRIMDOUBLE    { ITprimdouble  $$ }
+ PRIMDOUBLE    { ITprimdouble $$ }
  CLITLIT       { ITlitlit     $$ }
 
  UNKNOWN       { ITunknown  $$ }
@@ -199,11 +205,22 @@ Conflicts: 14 shift/reduce
 -----------------------------------------------------------------------------
 -- Module Header
 
+-- The place for module deprecation is really too restrictive, but if it
+-- was allowed at its natural place just before 'module', we get an ugly
+-- s/r conflict with the second alternative. Another solution would be the
+-- introduction of a new pragma DEPRECATED_MODULE, but this is not very nice,
+-- either, and DEPRECATED is only expected to be used by people who really
+-- know what they are doing. :-)
+
 module         :: { RdrNameHsModule }
-       : srcloc 'module' modid maybeexports 'where' body 
-               { HsModule $3 Nothing $4 (fst $6) (snd $6) $1 }
-       | srcloc body   
-               { HsModule mAIN_Name Nothing Nothing (fst $2) (snd $2) $1 }
+       : srcloc 'module' modid maybemoddeprec maybeexports 'where' body 
+               { HsModule $3 Nothing $5 (fst $7) (snd $7) $4 $1 }
+       | srcloc body
+               { HsModule mAIN_Name Nothing Nothing (fst $2) (snd $2) Nothing $1 }
+
+maybemoddeprec :: { Maybe (Deprecation RdrName) }
+       : '{-# DEPRECATED' STRING '#-}'         { Just (DeprecMod $2) }
+       |  {- empty -}                          { Nothing }
 
 body   :: { ([RdrNameImportDecl], [RdrNameHsDecl]) }
        :  '{'            top '}'               { $2 }
@@ -375,6 +392,7 @@ decl        :: { RdrBinding }
        | '{-# SPECIALISE' srcloc 'instance' inst_type '#-}'
                { RdrSig (SpecInstSig $4 $2) }
        | '{-# RULES' rules '#-}'       { $2 }
+       | '{-# DEPRECATED' deprecations '#-}'   { $2 }
 
 opt_phase :: { Maybe Int }
           : INTEGER                     { Just (fromInteger $1) }
@@ -454,6 +472,27 @@ rule_var :: { RdrNameRuleBndr }
                | '(' varid '::' ctype ')'              { RuleBndrSig $2 $4 }
 
 -----------------------------------------------------------------------------
+-- Deprecations
+
+deprecations :: { RdrBinding }
+       : deprecations ';' deprecation          { $1 `RdrAndBindings` $3 }
+       | deprecations ';'                      { $1 }
+       | deprecation                           { $1 }
+       | {- empty -}                           { RdrNullBind }
+
+deprecation :: { RdrBinding }
+       : deprecated_names STRING
+               { foldr1 RdrAndBindings [ RdrSig (DeprecSig (DeprecName n $2) l) | (l,n) <- $1 ] }
+
+deprecated_names :: { [(SrcLoc,RdrName)] }
+       : deprecated_names ',' deprecated_name  { $3 : $1 }
+       | deprecated_name                       { [$1] }
+
+deprecated_name :: { (SrcLoc,RdrName) }
+       : srcloc var                            { ($1, $2) }
+       | srcloc tycon                          { ($1, $2) }
+
+-----------------------------------------------------------------------------
 -- Foreign import/export
 
 callconv :: { Int }
@@ -487,6 +526,7 @@ type :: { RdrNameHsType }
 
 btype :: { RdrNameHsType }
        : btype atype                   { MonoTyApp $1 $2 }
+       | IPVARID '::' type             { MonoIParamTy (mkSrcUnqual ipName $1) $3 }
        | atype                         { $1 }
 
 atype :: { RdrNameHsType }
@@ -633,6 +673,7 @@ gdrh :: { RdrNameGRHS }
 
 exp   :: { RdrNameHsExpr }
        : infixexp '::' sigtype         { ExprWithTySig $1 $3 }
+       | infixexp 'with' dbinding      { HsWith $1 $3 }
        | infixexp                      { $1 }
 
 infixexp :: { RdrNameHsExpr }
@@ -683,6 +724,7 @@ aexp        :: { RdrNameHsExpr }
 
 aexp1  :: { RdrNameHsExpr }
        : qvar                          { HsVar $1 }
+       | IPVARID                       { HsIPVar (mkSrcUnqual ipName $1) }
        | gcon                          { HsVar $1 }
        | literal                       { HsLit $1 }
        | '(' exp ')'                   { HsPar $2 }
@@ -743,12 +785,14 @@ altslist :: { [RdrNameMatch] }
        : '{'            alts '}'       { reverse $2 }
        |     layout_on  alts  close    { reverse $2 }
 
+alts    :: { [RdrNameMatch] }
+        : alts1                                { $1 }
+       | ';' alts                      { $2 }
 
-alts   :: { [RdrNameMatch] }
-       : alts ';' alt                  { $3 : $1 }
-       | alts ';'                      { $1 }
+alts1  :: { [RdrNameMatch] }
+       : alts1 ';' alt                 { $3 : $1 }
+       | alts1 ';'                     { $1 }
        | alt                           { [$1] }
-       | {- empty -}                   { [] }
 
 alt    :: { RdrNameMatch }
        : infixexp opt_sig ralt wherebinds
@@ -814,6 +858,22 @@ fbind      :: { (RdrName, RdrNameHsExpr, Bool) }
        : qvar '=' exp                  { ($1,$3,False) }
 
 -----------------------------------------------------------------------------
+-- Implicit Parameter Bindings
+
+dbinding :: { [(RdrName, RdrNameHsExpr)] }
+       : '{' dbinds '}'                { $2 }
+       | layout_on dbinds close        { $2 }
+
+dbinds         :: { [(RdrName, RdrNameHsExpr)] }
+       : dbinds ';' dbind              { $3 : $1 }
+       | dbinds ';'                    { $1 }
+       | dbind                         { [$1] }
+       | {- empty -}                   { [] }
+
+dbind  :: { (RdrName, RdrNameHsExpr) }
+dbind  : IPVARID '=' exp               { (mkSrcUnqual ipName $1, $3) }
+
+-----------------------------------------------------------------------------
 -- Variables, Constructors and Operators.
 
 gcon   :: { RdrName }