-- 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
-#define INCLUDE #include
-INCLUDE "HsVersions.h"
-
import HsSyn
import RdrHsSyn
-import HscTypes ( IsBootInterface, DeprecTxt )
+import HscTypes ( IsBootInterface, WarningTxt(..) )
import Lexer
import RdrName
import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon,
'{-# SCC' { L _ ITscc_prag }
'{-# GENERATED' { L _ ITgenerated_prag }
'{-# DEPRECATED' { L _ ITdeprecated_prag }
+ '{-# WARNING' { L _ ITwarning_prag }
'{-# UNPACK' { L _ ITunpack_prag }
'#-}' { L _ ITclose_prag }
PRIMCHAR { L _ (ITprimchar _) }
PRIMSTRING { L _ (ITprimstring _) }
PRIMINTEGER { L _ (ITprimint _) }
+ PRIMWORD { L _ (ITprimword _) }
PRIMFLOAT { L _ (ITprimfloat _) }
PRIMDOUBLE { L _ (ITprimdouble _) }
-- 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) )}}
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 }
-- 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))}}
| 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 }
| 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)
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)) } }
-- Declarations in binding groups other than classes and instances
--
decls :: { Located (OrdList (LHsDecl RdrName)) }
- : decls ';' decl { LL (unLoc $1 `appOL` unLoc $3) }
+ : decls ';' decl { let { this = unLoc $3;
+ rest = unLoc $1;
+ these = rest `appOL` this }
+ in rest `seq` this `seq` these `seq`
+ LL these }
| decls ';' { LL (unLoc $1) }
| decl { $1 }
| {- empty -} { noLoc nilOL }
| '(' 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 }
-- 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 ] }
| docdecl { LL $ unitOL $1 }
rhs :: { Located (GRHSs RdrName) }
- : '=' exp wherebinds { L (comb3 $1 $2 $3) $ GRHSs (unguardedRHS $2) (unLoc $3) }
+ : '=' exp wherebinds { sL (comb3 $1 $2 $3) $ GRHSs (unguardedRHS $2) (unLoc $3) }
| gdrhs wherebinds { LL $ GRHSs (reverse (unLoc $1)) (unLoc $2) }
gdrhs :: { Located [LGRHS 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 '#-}'
| texp '|' flattenedpquals { sL (comb2 $1 $>) $ mkHsDo ListComp (unLoc $3) $1 }
lexps :: { Located [LHsExpr RdrName] }
- : lexps ',' texp { LL ($3 : unLoc $1) }
+ : lexps ',' texp { LL (((:) $! $3) $! unLoc $1) }
| texp ',' texp { LL [$3,$1] }
-----------------------------------------------------------------------------
-- Implicit Parameter Bindings
dbinds :: { Located [LIPBind RdrName] }
- : dbinds ';' dbind { LL ($3 : unLoc $1) }
+ : dbinds ';' dbind { let { this = $3; rest = unLoc $1 }
+ in rest `seq` this `seq` LL (this : rest) }
| dbinds ';' { LL (unLoc $1) }
- | dbind { L1 [$1] }
+ | dbind { let this = $1 in this `seq` L1 [this] }
-- | {- empty -} { [] }
dbind :: { LIPBind 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
tyvarid :: { Located RdrName }
: VARID { L1 $! mkUnqual tvName (getVARID $1) }
| special_id { L1 $! mkUnqual tvName (unLoc $1) }
- | 'unsafe' { L1 $! mkUnqual tvName FSLIT("unsafe") }
- | 'safe' { L1 $! mkUnqual tvName FSLIT("safe") }
- | 'threadsafe' { L1 $! mkUnqual tvName FSLIT("threadsafe") }
+ | 'unsafe' { L1 $! mkUnqual tvName (fsLit "unsafe") }
+ | 'safe' { L1 $! mkUnqual tvName (fsLit "safe") }
+ | 'threadsafe' { L1 $! mkUnqual tvName (fsLit "threadsafe") }
tyvarsym :: { Located RdrName }
-- Does not include "!", because that is used for strictness marks
varid :: { Located RdrName }
: varid_no_unsafe { $1 }
- | 'unsafe' { L1 $! mkUnqual varName FSLIT("unsafe") }
- | 'safe' { L1 $! mkUnqual varName FSLIT("safe") }
- | 'threadsafe' { L1 $! mkUnqual varName FSLIT("threadsafe") }
+ | '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") }
+ | 'forall' { L1 $! mkUnqual varName (fsLit "forall") }
+ | 'family' { L1 $! mkUnqual varName (fsLit "family") }
qvarsym :: { Located RdrName }
: varsym { $1 }
varsym :: { Located RdrName }
: varsym_no_minus { $1 }
- | '-' { L1 $ mkUnqual varName FSLIT("-") }
+ | '-' { L1 $ mkUnqual varName (fsLit "-") }
varsym_no_minus :: { Located RdrName } -- varsym not including '-'
: VARSYM { L1 $ mkUnqual varName (getVARSYM $1) }
-- depending on context
special_id :: { Located FastString }
special_id
- : 'as' { L1 FSLIT("as") }
- | 'qualified' { L1 FSLIT("qualified") }
- | 'hiding' { L1 FSLIT("hiding") }
- | 'export' { L1 FSLIT("export") }
- | 'label' { L1 FSLIT("label") }
- | 'dynamic' { L1 FSLIT("dynamic") }
- | 'stdcall' { L1 FSLIT("stdcall") }
- | 'ccall' { L1 FSLIT("ccall") }
+ : 'as' { L1 (fsLit "as") }
+ | 'qualified' { L1 (fsLit "qualified") }
+ | 'hiding' { L1 (fsLit "hiding") }
+ | 'export' { L1 (fsLit "export") }
+ | 'label' { L1 (fsLit "label") }
+ | 'dynamic' { L1 (fsLit "dynamic") }
+ | 'stdcall' { L1 (fsLit "stdcall") }
+ | 'ccall' { L1 (fsLit "ccall") }
special_sym :: { Located FastString }
-special_sym : '!' { L1 FSLIT("!") }
- | '.' { L1 FSLIT(".") }
- | '*' { L1 FSLIT("*") }
+special_sym : '!' { L1 (fsLit "!") }
+ | '.' { L1 (fsLit ".") }
+ | '*' { L1 (fsLit "*") }
-----------------------------------------------------------------------------
-- Data constructors
: CHAR { L1 $ HsChar $ getCHAR $1 }
| STRING { L1 $ HsString $ getSTRING $1 }
| PRIMINTEGER { L1 $ HsIntPrim $ getPRIMINTEGER $1 }
+ | PRIMWORD { L1 $ HsWordPrim $ getPRIMWORD $1 }
| PRIMCHAR { L1 $ HsCharPrim $ getPRIMCHAR $1 }
| PRIMSTRING { L1 $ HsStringPrim $ getPRIMSTRING $1 }
| PRIMFLOAT { L1 $ HsFloatPrim $ getPRIMFLOAT $1 }
getPRIMCHAR (L _ (ITprimchar x)) = x
getPRIMSTRING (L _ (ITprimstring x)) = x
getPRIMINTEGER (L _ (ITprimint x)) = x
+getPRIMWORD (L _ (ITprimword x)) = x
getPRIMFLOAT (L _ (ITprimfloat x)) = x
getPRIMDOUBLE (L _ (ITprimdouble x)) = x
getTH_ID_SPLICE (L _ (ITidEscape 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 = combineLocs
+comb2 a b = a `seq` b `seq` combineLocs a b
comb3 :: Located a -> Located b -> Located c -> SrcSpan
-comb3 a b c = combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c))
+comb3 a b c = a `seq` b `seq` c `seq`
+ combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c))
comb4 :: Located a -> Located b -> Located c -> Located d -> SrcSpan
-comb4 a b c d = combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $
- combineSrcSpans (getLoc c) (getLoc d)
+comb4 a b c d = a `seq` b `seq` c `seq` d `seq`
+ (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $
+ combineSrcSpans (getLoc c) (getLoc d))
-- strict constructor version:
{-# INLINE sL #-}
projects / ghc-hetmet.git / blobdiff