X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Fparser%2FParser.y.pp;h=86ce98c0dd7f67e7ec9bcb14fe17de5a1c1cd93c;hb=cae75f82226638691cfa1e85fc168f4b65ddce4d;hp=bfcc856e6edcce83b91a490a25634b2913965d6f;hpb=6821c8a47c0fc61a2d989d368f926cc0ded776e9;p=ghc-hetmet.git diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index bfcc856..86ce98c 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -15,12 +15,20 @@ -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details +{-# OPTIONS_GHC -O0 -fno-ignore-interface-pragmas #-} +{- +Careful optimisation of the parser: we don't want to throw everything +at it, because that takes too long and doesn't buy much, but we do want +to inline certain key external functions, so we instruct GHC not to +throw away inlinings as it would normally do in -O0 mode. +-} + module Parser ( parseModule, parseStmt, parseIdentifier, parseType, parseHeader ) where import HsSyn import RdrHsSyn -import HscTypes ( IsBootInterface, DeprecTxt ) +import HscTypes ( IsBootInterface, WarningTxt(..) ) import Lexer import RdrName import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon, @@ -254,6 +262,7 @@ incorrect. '{-# SCC' { L _ ITscc_prag } '{-# GENERATED' { L _ ITgenerated_prag } '{-# DEPRECATED' { L _ ITdeprecated_prag } + '{-# WARNING' { L _ ITwarning_prag } '{-# UNPACK' { L _ ITunpack_prag } '#-}' { L _ ITclose_prag } @@ -367,7 +376,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) )}} @@ -378,15 +387,16 @@ module :: { Located (HsModule RdrName) } Nothing)) } maybedocheader :: { (HaddockModInfo RdrName, Maybe (HsDoc RdrName)) } - : moduleheader { (fst $1, snd $1) } + : moduleheader { $1 } | {- empty -} { (emptyHaddockModInfo, Nothing) } 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 } @@ -408,7 +418,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))}} @@ -542,7 +552,8 @@ 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 } | decl { unLoc $1 } @@ -606,8 +617,8 @@ ty_decl :: { LTyClDecl RdrName } | data_or_newtype tycl_hdr constrs deriving {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2} ; checkTyVars tparms -- no type pattern - ; return $ - L (comb4 $1 $2 $3 $4) + ; return $! + sL (comb4 $1 $2 $3 $4) -- We need the location on tycl_hdr in case -- constrs and deriving are both empty (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) @@ -619,8 +630,8 @@ ty_decl :: { LTyClDecl RdrName } deriving {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2} ; checkTyVars tparms -- can have type pats - ; return $ - L (comb4 $1 $2 $4 $5) + ; return $! + sL (comb4 $1 $2 $4 $5) (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) (unLoc $3) (reverse (unLoc $5)) (unLoc $6)) } } @@ -883,7 +894,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 } @@ -893,8 +916,8 @@ 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 ] } @@ -1308,9 +1331,9 @@ 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")) >>= \_ -> - (return $ LL $ getSTRING $2) } - | '{-# SCC' STRING '#-}' { LL $ getSTRING $2 } + : '_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 } hpc_annot :: { Located (FastString,(Int,Int),(Int,Int)) } : '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' @@ -1640,15 +1663,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 @@ -1969,6 +1992,14 @@ getDOCPREV (L _ (ITdocCommentPrev x)) = x getDOCNAMED (L _ (ITdocCommentNamed x)) = x getDOCSECTION (L _ (ITdocSection n x)) = (n, x) +getSCC :: Located Token -> P FastString +getSCC lt = do let s = getSTRING lt + err = "Spaces are not allowed in SCCs" + -- We probably actually want to be more restrictive than this + if ' ' `elem` unpackFS s + then failSpanMsgP (getLoc lt) (text err) + else return s + -- Utilities for combining source spans comb2 :: Located a -> Located b -> SrcSpan comb2 a b = a `seq` b `seq` combineLocs a b