X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FParser.y;h=bfb325789d791618f5afe83b7a2b6c7c1ab0325f;hb=f0a01a1fc19bfa76aa36fa113942e1c57f3733f4;hp=cc76e5de7d47c016f182b8ebb6e4c430bdc88fad;hpb=30b5ebe424ebae69b162ac3fc547eb14d898535f;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index cc76e5d..bfb3257 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.15 1999/11/01 17:10:23 simonpj Exp $ +$Id: Parser.y,v 1.27 2000/03/02 22:51:30 lewie 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 @@ -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) @@ -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 } @@ -324,14 +341,14 @@ topdecl :: { RdrBinding } (TyData NewType cs c ts [$5] $6 NoDataPragmas $1))) } - | srcloc 'class' ctype where + | srcloc 'class' ctype fds where {% checkDataHeader $3 `thenP` \(cs,c,ts) -> let (binds,sigs) = cvMonoBindsAndSigs cvClassOpSig - (groupBindings $4) + (groupBindings $5) in returnP (RdrHsDecl (TyClD - (mkClassDecl cs c ts sigs binds + (mkClassDecl cs c ts $4 sigs binds NoClassPragmas $1))) } | srcloc 'instance' inst_type where @@ -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 } @@ -474,10 +506,16 @@ ext_name :: { Maybe ExtName } ----------------------------------------------------------------------------- -- Types -{- ToDo: forall stuff -} +-- A ctype is a for-all type +ctype :: { RdrNameHsType } + : 'forall' tyvars '.' ctype { mkHsForAllTy (Just $2) [] $4 } + | context type { mkHsForAllTy Nothing $1 $2 } + -- A type of form (context => type) is an *implicit* HsForAllTy + | type { $1 } type :: { RdrNameHsType } : btype '->' type { MonoFunTy $1 $3 } + | ipvar '::' type { MonoIParamTy $1 $3 } | btype { $1 } btype :: { RdrNameHsType } @@ -506,14 +544,6 @@ gtycon :: { RdrName } inst_type :: { RdrNameHsType } : ctype {% checkInstType $1 } -ctype :: { RdrNameHsType } - : '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] } : types { $1 } | {- empty -} { [] } @@ -529,6 +559,21 @@ tyvars :: { [RdrNameHsTyVar] } : tyvars tyvar { UserTyVar $2 : $1 } | {- empty -} { [] } +fds :: { [([RdrName], [RdrName])] } + : {- empty -} { [] } + | '|' fds1 { reverse $2 } + +fds1 :: { [([RdrName], [RdrName])] } + : fds1 ',' fd { $3 : $1 } + | fd { [$1] } + +fd :: { ([RdrName], [RdrName]) } + : varids0 '->' varids0 { (reverse $1, reverse $3) } + +varids0 :: { [RdrName] } + : {- empty -} { [] } + | varids0 tyvar { $2 : $1 } + ----------------------------------------------------------------------------- -- Datatype declarations @@ -583,7 +628,7 @@ fielddecl :: { ([RdrName],RdrNameBangType) } : vars '::' stype { (reverse $1, $3) } stype :: { RdrNameBangType } - : type { Unbanged $1 } + : ctype { Unbanged $1 } | '!' atype { Banged $2 } deriving :: { Maybe [RdrName] } @@ -621,6 +666,7 @@ gdrh :: { RdrNameGRHS } exp :: { RdrNameHsExpr } : infixexp '::' sigtype { ExprWithTySig $1 $3 } + | infixexp 'with' dbinding { HsWith $1 $3 } | infixexp { $1 } infixexp :: { RdrNameHsExpr } @@ -671,6 +717,7 @@ aexp :: { RdrNameHsExpr } aexp1 :: { RdrNameHsExpr } : qvar { HsVar $1 } + | ipvar { HsIPVar $1 } | gcon { HsVar $1 } | literal { HsLit $1 } | '(' exp ')' { HsPar $2 } @@ -731,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 @@ -802,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 : ipvar '=' exp { ($1, $3) } + +----------------------------------------------------------------------------- -- Variables, Constructors and Operators. gcon :: { RdrName } @@ -818,6 +883,9 @@ qvar :: { RdrName } : qvarid { $1 } | '(' qvarsym ')' { $2 } +ipvar :: { RdrName } + : IPVARID { (mkSrcUnqual ipName (tailFS $1)) } + con :: { RdrName } : conid { $1 } | '(' consym ')' { $2 }