X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fparser%2FParser.y.pp;h=d9df620de9b15dca3eebe1baa600c6e8f9c53722;hb=0345a8378429e10e0c4feb7a6be2f9f132699b81;hp=4552fe24b779be49d949f2c6a0489c470d75065b;hpb=15a63009a30ce0d1614b36803185f548db838805;p=ghc-hetmet.git diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 4552fe2..d9df620 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -28,7 +28,7 @@ module Parser ( parseModule, parseStmt, parseIdentifier, parseType, import HsSyn import RdrHsSyn -import HscTypes ( IsBootInterface, DeprecTxt ) +import HscTypes ( IsBootInterface, WarningTxt(..) ) import Lexer import RdrName import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon, @@ -262,7 +262,9 @@ incorrect. '{-# SCC' { L _ ITscc_prag } '{-# GENERATED' { L _ ITgenerated_prag } '{-# DEPRECATED' { L _ ITdeprecated_prag } + '{-# WARNING' { L _ ITwarning_prag } '{-# UNPACK' { L _ ITunpack_prag } + '{-# ANN' { L _ ITann_prag } '#-}' { L _ ITclose_prag } '..' { L _ ITdotdot } -- reserved symbols @@ -313,6 +315,8 @@ incorrect. QCONID { L _ (ITqconid _) } QVARSYM { L _ (ITqvarsym _) } QCONSYM { L _ (ITqconsym _) } + PREFIXQVARSYM { L _ (ITprefixqvarsym _) } + PREFIXQCONSYM { L _ (ITprefixqconsym _) } IPDUPVARID { L _ (ITdupipvarid _) } -- GHC extension @@ -375,7 +379,7 @@ identifier :: { Located RdrName } -- know what they are doing. :-) module :: { Located (HsModule RdrName) } - : maybedocheader 'module' modid maybemoddeprec maybeexports 'where' body + : maybedocheader 'module' modid maybemodwarning maybeexports 'where' body {% fileSrcSpan >>= \ loc -> case $1 of { (info, doc) -> return (L loc (HsModule (Just $3) $5 (fst $7) (snd $7) $4 info doc) )}} @@ -392,9 +396,10 @@ maybedocheader :: { (HaddockModInfo RdrName, Maybe (HsDoc RdrName)) } missing_module_keyword :: { () } : {- empty -} {% pushCurrentContext } -maybemoddeprec :: { Maybe DeprecTxt } - : '{-# DEPRECATED' STRING '#-}' { Just (getSTRING $2) } - | {- empty -} { Nothing } +maybemodwarning :: { Maybe WarningTxt } + : '{-# DEPRECATED' STRING '#-}' { Just (DeprecatedTxt (getSTRING $2)) } + | '{-# WARNING' STRING '#-}' { Just (WarningTxt (getSTRING $2)) } + | {- empty -} { Nothing } body :: { ([LImportDecl RdrName], [LHsDecl RdrName]) } : '{' top '}' { $2 } @@ -416,7 +421,7 @@ cvtopdecls :: { [LHsDecl RdrName] } -- Module declaration & imports only header :: { Located (HsModule RdrName) } - : maybedocheader 'module' modid maybemoddeprec maybeexports 'where' header_body + : maybedocheader 'module' modid maybemodwarning maybeexports 'where' header_body {% fileSrcSpan >>= \ loc -> case $1 of { (info, doc) -> return (L loc (HsModule (Just $3) $5 $7 [] $4 info doc))}} @@ -493,13 +498,17 @@ importdecls :: { [LImportDecl RdrName] } | {- empty -} { [] } importdecl :: { LImportDecl RdrName } - : 'import' maybe_src optqualified modid maybeas maybeimpspec - { L (comb4 $1 $4 $5 $6) (ImportDecl $4 $2 $3 (unLoc $5) (unLoc $6)) } + : 'import' maybe_src optqualified maybe_pkg modid maybeas maybeimpspec + { L (comb4 $1 $5 $6 $7) (ImportDecl $5 $4 $2 $3 (unLoc $6) (unLoc $7)) } maybe_src :: { IsBootInterface } : '{-# SOURCE' '#-}' { True } | {- empty -} { False } +maybe_pkg :: { Maybe FastString } + : STRING { Just (getSTRING $1) } + | {- empty -} { Nothing } + optqualified :: { Bool } : 'qualified' { True } | {- empty -} { False } @@ -550,8 +559,10 @@ topdecl :: { OrdList (LHsDecl RdrName) } | stand_alone_deriving { unitOL (LL (DerivD (unLoc $1))) } | 'default' '(' comma_types0 ')' { unitOL (LL $ DefD (DefaultDecl $3)) } | 'foreign' fdecl { unitOL (LL (unLoc $2)) } - | '{-# DEPRECATED' deprecations '#-}' { $2 } + | '{-# DEPRECATED' deprecations '#-}' { $2 } + | '{-# WARNING' warnings '#-}' { $2 } | '{-# RULES' rules '#-}' { $2 } + | annotation { unitOL $1 } | decl { unLoc $1 } -- Template Haskell Extension @@ -891,7 +902,19 @@ rule_var :: { RuleBndr RdrName } | '(' varid '::' ctype ')' { RuleBndrSig $2 $4 } ----------------------------------------------------------------------------- --- Deprecations (c.f. rules) +-- Warnings and deprecations (c.f. rules) + +warnings :: { OrdList (LHsDecl RdrName) } + : warnings ';' warning { $1 `appOL` $3 } + | warnings ';' { $1 } + | warning { $1 } + | {- empty -} { nilOL } + +-- SUP: TEMPORARY HACK, not checking for `module Foo' +warning :: { OrdList (LHsDecl RdrName) } + : namelist STRING + { toOL [ LL $ WarningD (Warning n (WarningTxt (getSTRING $2))) + | n <- unLoc $1 ] } deprecations :: { OrdList (LHsDecl RdrName) } : deprecations ';' deprecation { $1 `appOL` $3 } @@ -901,10 +924,17 @@ deprecations :: { OrdList (LHsDecl RdrName) } -- SUP: TEMPORARY HACK, not checking for `module Foo' deprecation :: { OrdList (LHsDecl RdrName) } - : depreclist STRING - { toOL [ LL $ DeprecD (Deprecation n (getSTRING $2)) + : namelist STRING + { toOL [ LL $ WarningD (Warning n (DeprecatedTxt (getSTRING $2))) | n <- unLoc $1 ] } +----------------------------------------------------------------------------- +-- Annotations +annotation :: { LHsDecl RdrName } + : '{-# ANN' name_var aexp '#-}' { LL (AnnD $ HsAnnotation (ValueAnnProvenance (unLoc $2)) $3) } + | '{-# ANN' 'type' tycon aexp '#-}' { LL (AnnD $ HsAnnotation (TypeAnnProvenance (unLoc $3)) $4) } + | '{-# ANN' 'module' aexp '#-}' { LL (AnnD $ HsAnnotation ModuleAnnProvenance $3) } + ----------------------------------------------------------------------------- -- Foreign import and export declarations @@ -1316,7 +1346,7 @@ exp10 :: { LHsExpr RdrName } | fexp { $1 } scc_annot :: { Located FastString } - : '_scc_' STRING {% (addWarning Opt_WarnDeprecations (getLoc $1) (text "_scc_ is deprecated; use an SCC pragma instead")) >>= \_ -> + : '_scc_' STRING {% (addWarning Opt_WarnWarningsDeprecations (getLoc $1) (text "_scc_ is deprecated; use an SCC pragma instead")) >>= \_ -> ( do scc <- getSCC $2; return $ LL scc ) } | '{-# SCC' STRING '#-}' {% do scc <- getSCC $2; return $ LL scc } @@ -1414,16 +1444,27 @@ cvtopdecls0 :: { [LHsDecl RdrName] } : {- empty -} { [] } | cvtopdecls { $1 } --- tuple expressions: things that can appear unparenthesized as long as they're +-- "texp" is short for tuple expressions: +-- things that can appear unparenthesized as long as they're -- inside parens or delimitted by commas texp :: { LHsExpr RdrName } : exp { $1 } - -- Technically, this should only be used for bang patterns, - -- but we can be a little more liberal here and avoid parens - -- inside tuples - | infixexp qop { LL $ SectionL $1 $2 } + + -- Note [Parsing sections] + -- ~~~~~~~~~~~~~~~~~~~~~~~ + -- We include left and right sections here, which isn't + -- technically right according to Haskell 98. For example + -- (3 +, True) isn't legal + -- However, we want to parse bang patterns like + -- (!x, !y) + -- and it's convenient to do so here as a section + -- Then when converting expr to pattern we unravel it again + -- Meanwhile, the renamer checks that real sections appear + -- inside parens. + | infixexp qop { LL $ SectionL $1 $2 } | qopm infixexp { LL $ SectionR $1 $2 } - -- view patterns get parenthesized above + + -- View patterns get parenthesized above | exp '->' exp { LL $ EViewPat $1 $3 } texps :: { [LHsExpr RdrName] } @@ -1648,15 +1689,15 @@ ipvar :: { Located (IPName RdrName) } : IPDUPVARID { L1 (IPName (mkUnqual varName (getIPDUPVARID $1))) } ----------------------------------------------------------------------------- --- Deprecations +-- Warnings and deprecations -depreclist :: { Located [RdrName] } -depreclist : deprec_var { L1 [unLoc $1] } - | deprec_var ',' depreclist { LL (unLoc $1 : unLoc $3) } +namelist :: { Located [RdrName] } +namelist : name_var { L1 [unLoc $1] } + | name_var ',' namelist { LL (unLoc $1 : unLoc $3) } -deprec_var :: { Located RdrName } -deprec_var : var { $1 } - | con { $1 } +name_var :: { Located RdrName } +name_var : var { $1 } + | con { $1 } ----------------------------------------- -- Data constructors @@ -1709,6 +1750,7 @@ qtyconop :: { Located RdrName } -- Qualified or unqualified qtycon :: { Located RdrName } -- Qualified or unqualified : QCONID { L1 $! mkQual tcClsName (getQCONID $1) } + | PREFIXQCONSYM { L1 $! mkQual tcClsName (getPREFIXQCONSYM $1) } | tycon { $1 } tycon :: { Located RdrName } -- Unqualified @@ -1789,17 +1831,15 @@ qvar :: { Located RdrName } qvarid :: { Located RdrName } : varid { $1 } - | QVARID { L1 $ mkQual varName (getQVARID $1) } + | QVARID { L1 $! mkQual varName (getQVARID $1) } + | PREFIXQVARSYM { L1 $! mkQual varName (getPREFIXQVARSYM $1) } varid :: { Located RdrName } - : varid_no_unsafe { $1 } + : VARID { L1 $! mkUnqual varName (getVARID $1) } + | special_id { L1 $! mkUnqual varName (unLoc $1) } | 'unsafe' { L1 $! mkUnqual varName (fsLit "unsafe") } | 'safe' { L1 $! mkUnqual varName (fsLit "safe") } | 'threadsafe' { L1 $! mkUnqual varName (fsLit "threadsafe") } - -varid_no_unsafe :: { Located RdrName } - : VARID { L1 $! mkUnqual varName (getVARID $1) } - | special_id { L1 $! mkUnqual varName (unLoc $1) } | 'forall' { L1 $! mkUnqual varName (fsLit "forall") } | 'family' { L1 $! mkUnqual varName (fsLit "family") } @@ -1848,7 +1888,8 @@ special_sym : '!' { L1 (fsLit "!") } qconid :: { Located RdrName } -- Qualified or unqualified : conid { $1 } - | QCONID { L1 $ mkQual dataName (getQCONID $1) } + | QCONID { L1 $! mkQual dataName (getQCONID $1) } + | PREFIXQCONSYM { L1 $! mkQual dataName (getPREFIXQCONSYM $1) } conid :: { Located RdrName } : CONID { L1 $ mkUnqual dataName (getCONID $1) } @@ -1957,6 +1998,8 @@ getQVARID (L _ (ITqvarid x)) = x getQCONID (L _ (ITqconid x)) = x getQVARSYM (L _ (ITqvarsym x)) = x getQCONSYM (L _ (ITqconsym x)) = x +getPREFIXQVARSYM (L _ (ITprefixqvarsym x)) = x +getPREFIXQCONSYM (L _ (ITprefixqconsym x)) = x getIPDUPVARID (L _ (ITdupipvarid x)) = x getCHAR (L _ (ITchar x)) = x getSTRING (L _ (ITstring x)) = x