[project @ 2000-03-02 22:51:30 by lewie]

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

diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y
index 759c2dc..bfb3257 100644 (file)
--- a/ghc/compiler/parser/Parser.y
+++ b/ghc/compiler/parser/Parser.y
@@ -1,6 +1,6 @@
 {-
 -----------------------------------------------------------------------------
-$Id: Parser.y,v 1.19 2000/01/28 20:52:39 lewie Exp $
+$Id: Parser.y,v 1.27 2000/03/02 22:51:30 lewie Exp $
 
 Haskell grammar.
 
@@ -28,6 +28,7 @@ import BasicTypes     ( Fixity(..), FixityDirection(..), NewOrData(..) )
 import Panic
 
 import GlaExts
+import FastString      ( tailFS )
 
 #include "HsVersions.h"
 }
@@ -35,6 +36,7 @@ import GlaExts
 {-
 -----------------------------------------------------------------------------
 Conflicts: 14 shift/reduce
+       (note: it's currently 21 -- JRL, 31/1/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)
@@ -85,7 +87,6 @@ Conflicts: 14 shift/reduce
  'then'        { ITthen }
  'type'        { ITtype }
  'where'       { ITwhere }
- 'with'        { ITwith }
  '_scc_'       { ITscc }
 
  'forall'      { ITforall }                    -- GHC extension keywords
@@ -94,6 +95,7 @@ Conflicts: 14 shift/reduce
  'label'       { ITlabel } 
  'dynamic'     { ITdynamic }
  'unsafe'      { ITunsafe }
+ 'with'        { ITwith }
  'stdcall'      { ITstdcallconv }
  'ccall'        { ITccallconv }
  '_ccall_'     { ITccall (False, False, False) }
@@ -106,6 +108,7 @@ Conflicts: 14 shift/reduce
  '{-# INLINE'      { ITinline_prag }
  '{-# NOINLINE'    { ITnoinline_prag }
  '{-# RULES'      { ITrules_prag }
+ '{-# DEPRECATED'  { ITdeprecated_prag }
  '#-}'            { ITclose_prag }
 
 {-
@@ -174,7 +177,8 @@ Conflicts: 14 shift/reduce
  QCONID        { ITqconid   $$ }
  QVARSYM       { ITqvarsym  $$ }
  QCONSYM       { ITqconsym  $$ }
- IPVARID       { ITipvarid  $$ }
+
+ IPVARID       { ITipvarid  $$ }               -- GHC extension
 
  PRAGMA                { ITpragma   $$ }
 
@@ -187,7 +191,7 @@ Conflicts: 14 shift/reduce
  PRIMSTRING    { ITprimstring $$ }
  PRIMINTEGER   { ITprimint    $$ }
  PRIMFLOAT     { ITprimfloat  $$ }
- PRIMDOUBLE    { ITprimdouble  $$ }
+ PRIMDOUBLE    { ITprimdouble $$ }
  CLITLIT       { ITlitlit     $$ }
 
  UNKNOWN       { ITunknown  $$ }
@@ -201,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 DeprecTxt }
+       : '{-# DEPRECATED' STRING '#-}'         { Just $2 }
+       |  {- empty -}                          { Nothing }
 
 body   :: { ([RdrNameImportDecl], [RdrNameHsDecl]) }
        :  '{'            top '}'               { $2 }
@@ -377,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) }
@@ -456,6 +472,20 @@ rule_var :: { RdrNameRuleBndr }
                | '(' varid '::' ctype ')'              { RuleBndrSig $2 $4 }
 
 -----------------------------------------------------------------------------
+-- Deprecations
+
+deprecations :: { RdrBinding }
+       : deprecations ';' deprecation          { $1 `RdrAndBindings` $3 }
+       | deprecations ';'                      { $1 }
+       | deprecation                           { $1 }
+       | {- empty -}                           { RdrNullBind }
+
+-- SUP: TEMPORARY HACK, not checking for `module Foo'
+deprecation :: { RdrBinding }
+       : srcloc exportlist STRING
+               { foldr1 RdrAndBindings [ RdrSig (DeprecSig (Deprecation n $3) $1) | n <- $2 ] }
+
+-----------------------------------------------------------------------------
 -- Foreign import/export
 
 callconv :: { Int }
@@ -485,6 +515,7 @@ ctype       :: { RdrNameHsType }
 
 type :: { RdrNameHsType }
        : btype '->' type               { MonoFunTy $1 $3 }
+       | ipvar '::' type               { MonoIParamTy $1 $3 }
        | btype                         { $1 }
 
 btype :: { RdrNameHsType }
@@ -686,7 +717,7 @@ aexp        :: { RdrNameHsExpr }
 
 aexp1  :: { RdrNameHsExpr }
        : qvar                          { HsVar $1 }
-       | IPVARID                       { HsIPVar (mkSrcUnqual ipName $1) }
+       | ipvar                         { HsIPVar $1 }
        | gcon                          { HsVar $1 }
        | literal                       { HsLit $1 }
        | '(' exp ')'                   { HsPar $2 }
@@ -833,7 +864,7 @@ dbinds      :: { [(RdrName, RdrNameHsExpr)] }
        | {- empty -}                   { [] }
 
 dbind  :: { (RdrName, RdrNameHsExpr) }
-dbind  : IPVARID '=' exp               { (mkSrcUnqual ipName $1, $3) }
+dbind  : ipvar '=' exp                 { ($1, $3) }
 
 -----------------------------------------------------------------------------
 -- Variables, Constructors and Operators.
@@ -852,6 +883,9 @@ qvar        :: { RdrName }
        : qvarid                { $1 }
        | '(' qvarsym ')'       { $2 }
 
+ipvar  :: { RdrName }
+       : IPVARID               { (mkSrcUnqual ipName (tailFS $1)) }
+
 con    :: { RdrName }
        : conid                 { $1 }
        | '(' consym ')'        { $2 }