X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FParser.y;h=12a9e6ef049f9849e2d803dbef56f144f7e7e893;hb=c5535e01e9d2808da9a38a6bc1e6af48140398c8;hp=811607ac8bc5c04f69445dfe7b3fffc78e12460b;hpb=e1e1d0204ff754def1b3675f539372fd4691d78d;p=ghc-hetmet.git

diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y
index 811607a..12a9e6e 100644
--- 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.25 2000/02/28 09:17:54 simonmar 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 DeprecTxt }
+	: '{-# DEPRECATED' STRING '#-}' 	{ Just $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,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 }
@@ -483,6 +515,7 @@ ctype	:: { RdrNameHsType }
 
 type :: { RdrNameHsType }
 	: btype '->' type		{ MonoFunTy $1 $3 }
+	| IPVARID '::' type		{ MonoIParamTy (mkSrcUnqual ipName $1) $3 }
 	| btype				{ $1 }
 
 btype :: { RdrNameHsType }
@@ -633,6 +666,7 @@ gdrh :: { RdrNameGRHS }
 
 exp   :: { RdrNameHsExpr }
 	: infixexp '::' sigtype		{ ExprWithTySig $1 $3 }
+	| infixexp 'with' dbinding	{ HsWith $1 $3 }
 	| infixexp			{ $1 }
 
 infixexp :: { RdrNameHsExpr }
@@ -683,6 +717,7 @@ aexp	:: { RdrNameHsExpr }
 
 aexp1	:: { RdrNameHsExpr }
 	: qvar				{ HsVar $1 }
+	| IPVARID			{ HsIPVar (mkSrcUnqual ipName $1) }
 	| gcon				{ HsVar $1 }
   	| literal			{ HsLit $1 }
 	| '(' exp ')'			{ HsPar $2 }
@@ -743,12 +778,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 +851,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 }