Commit 8e3f00dd authored by Sylvain Henry's avatar Sylvain Henry
Browse files

Make the parser module less dependent on DynFlags

Bump haddock submodule
parent 4365d77a
......@@ -303,6 +303,7 @@ import GHCi.RemoteTypes
import GHC.Core.Ppr.TyThing ( pprFamInst )
import GHC.Driver.Backend
import GHC.Driver.Config
import GHC.Driver.Main
import GHC.Driver.Make
import GHC.Driver.Hooks
......@@ -1426,9 +1427,9 @@ getModuleSourceAndFlags mod = do
-- Throws a 'GHC.Driver.Types.SourceError' on parse error.
getTokenStream :: GhcMonad m => Module -> m [Located Token]
getTokenStream mod = do
(sourceFile, source, flags) <- getModuleSourceAndFlags mod
(sourceFile, source, dflags) <- getModuleSourceAndFlags mod
let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
case lexTokenStream source startLoc flags of
case lexTokenStream (initParserOpts dflags) source startLoc of
POk _ ts -> return ts
PFailed pst ->
do dflags <- getDynFlags
......@@ -1439,9 +1440,9 @@ getTokenStream mod = do
-- 'showRichTokenStream'.
getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)]
getRichTokenStream mod = do
(sourceFile, source, flags) <- getModuleSourceAndFlags mod
(sourceFile, source, dflags) <- getModuleSourceAndFlags mod
let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
case lexTokenStream source startLoc flags of
case lexTokenStream (initParserOpts dflags) source startLoc of
POk _ ts -> return $ addSourceToTokens startLoc source ts
PFailed pst ->
do dflags <- getDynFlags
......@@ -1616,7 +1617,7 @@ parser str dflags filename =
loc = mkRealSrcLoc (mkFastString filename) 1 1
buf = stringToStringBuffer str
in
case unP Parser.parseModule (mkPState dflags buf loc) of
case unP Parser.parseModule (initParserState (initParserOpts dflags) buf loc) of
PFailed pst ->
let (warns,errs) = getMessages pst dflags in
......
......@@ -249,6 +249,7 @@ import GHC.Types.Unique.FM
import GHC.Types.SrcLoc
import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Driver.Config
import GHC.Utils.Error
import GHC.Data.StringBuffer
import GHC.Data.FastString
......@@ -1432,7 +1433,8 @@ parseCmmFile dflags filename = withTiming dflags (text "ParseCmm"<+>brackets (te
buf <- hGetStringBuffer filename
let
init_loc = mkRealSrcLoc (mkFastString filename) 1 1
init_state = (mkPState dflags buf init_loc) { lex_state = [0] }
opts = initParserOpts dflags
init_state = (initParserState opts buf init_loc) { lex_state = [0] }
-- reset the lex_state: the Lexer monad leaves some stuff
-- in there we don't want.
case unPD cmmParse dflags init_state of
......
......@@ -27,6 +27,7 @@ import GHC.Parser.Annotation
import GHC hiding (Failed, Succeeded)
import GHC.Parser
import GHC.Parser.Lexer
import GHC.Driver.Config
import GHC.Driver.Monad
import GHC.Driver.Session
import GHC.Driver.Ppr
......@@ -83,7 +84,7 @@ doBackpack [src_filename] = do
buf <- liftIO $ hGetStringBuffer src_filename
let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great
case unP parseBackpack (mkPState dflags buf loc) of
case unP parseBackpack (initParserState (initParserOpts dflags) buf loc) of
PFailed pst -> throwErrors (getErrorMessages pst dflags)
POk _ pkgname_bkp -> do
-- OK, so we have an LHsUnit PackageName, but we want an
......
......@@ -2,6 +2,7 @@
module GHC.Driver.Config
( initOptCoercionOpts
, initSimpleOpts
, initParserOpts
)
where
......@@ -10,6 +11,7 @@ import GHC.Prelude
import GHC.Driver.Session
import GHC.Core.SimpleOpt
import GHC.Core.Coercion.Opt
import GHC.Parser.Lexer
-- | Initialise coercion optimiser configuration from DynFlags
initOptCoercionOpts :: DynFlags -> OptCoercionOpts
......@@ -23,3 +25,15 @@ initSimpleOpts dflags = SimpleOpts
{ so_uf_opts = unfoldingOpts dflags
, so_co_opts = initOptCoercionOpts dflags
}
-- | Extracts the flag information needed for parsing
initParserOpts :: DynFlags -> ParserOpts
initParserOpts =
mkParserOpts
<$> warningFlags
<*> extensionFlags
<*> homeUnitId_
<*> safeImportsOn
<*> gopt Opt_Haddock
<*> gopt Opt_KeepRawTokenStream
<*> const True
......@@ -138,6 +138,7 @@ import GHC.Cmm.Info.Build
import GHC.Cmm.Pipeline
import GHC.Cmm.Info
import GHC.Driver.CodeOutput
import GHC.Driver.Config
import GHC.Core.InstEnv
import GHC.Core.FamInstEnv
import GHC.Utils.Fingerprint ( Fingerprint )
......@@ -353,7 +354,7 @@ hscParse' mod_summary
= parseSignature
| otherwise = parseModule
case unP parseMod (mkPState dflags buf loc) of
case unP parseMod (initParserState (initParserOpts dflags) buf loc) of
PFailed pst ->
handleWarningsThrowErrors (getMessages pst dflags)
POk pst rdr_module -> do
......@@ -1875,7 +1876,7 @@ hscParseThingWithLocation source linenumber parser str
let buf = stringToStringBuffer str
loc = mkRealSrcLoc (fsLit source) linenumber 1
case unP parser (mkPState dflags buf loc) of
case unP parser (initParserState (initParserOpts dflags) buf loc) of
PFailed pst -> do
handleWarningsThrowErrors (getMessages pst dflags)
......
......@@ -21,13 +21,13 @@
-- and then parse that string:
--
-- @
-- runParser :: DynFlags -> String -> P a -> ParseResult a
-- runParser flags str parser = unP parser parseState
-- runParser :: ParserOpts -> String -> P a -> ParseResult a
-- runParser opts str parser = unP parser parseState
-- where
-- filename = "\<interactive\>"
-- location = mkRealSrcLoc (mkFastString filename) 1 1
-- buffer = stringToStringBuffer str
-- parseState = mkPState flags buffer location
-- parseState = initParserState opts buffer location
-- @
module GHC.Parser
( parseModule, parseSignature, parseImport, parseStatement, parseBackpack
......
......@@ -37,6 +37,7 @@ import GHC.Builtin.Names
import GHC.Data.StringBuffer
import GHC.Types.SrcLoc
import GHC.Driver.Session
import GHC.Driver.Config
import GHC.Utils.Error
import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
......@@ -73,7 +74,7 @@ getImports :: DynFlags
-- names from -XPackageImports), and the module name.
getImports dflags buf filename source_filename = do
let loc = mkRealSrcLoc (mkFastString filename) 1 1
case unP parseHeader (mkPState dflags buf loc) of
case unP parseHeader (initParserState (initParserOpts dflags) buf loc) of
PFailed pst ->
-- assuming we're not logging warnings here as per below
return $ Left $ getErrorMessages pst dflags
......@@ -178,7 +179,8 @@ blockSize = 1024
lazyGetToks :: DynFlags -> FilePath -> Handle -> IO [Located Token]
lazyGetToks dflags filename handle = do
buf <- hGetStringBufferBlock handle blockSize
unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False blockSize
let prag_state = initPragState (initParserOpts dflags) buf loc
unsafeInterleaveIO $ lazyLexBuf handle prag_state False blockSize
where
loc = mkRealSrcLoc (mkFastString filename) 1 1
......@@ -214,8 +216,9 @@ lazyGetToks dflags filename handle = do
getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token]
getToks dflags filename buf = lexAll (pragState dflags buf loc)
getToks dflags filename buf = lexAll pstate
where
pstate = initPragState (initParserOpts dflags) buf loc
loc = mkRealSrcLoc (mkFastString filename) 1 1
lexAll state = case unP (lexer False return) state of
......
......@@ -49,8 +49,10 @@
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Parser.Lexer (
Token(..), lexer, lexerDbg, pragState, mkPState, mkPStatePure, PState(..),
P(..), ParseResult(..), mkParserFlags, mkParserFlags', ParserFlags(..),
Token(..), lexer, lexerDbg,
ParserOpts(..), mkParserOpts,
PState (..), initParserState, initPragState,
P(..), ParseResult(..),
appendWarning,
appendError,
allocateComments,
......@@ -62,7 +64,7 @@ module GHC.Parser.Lexer (
activeContext, nextIsEOF,
getLexState, popLexState, pushLexState,
ExtBits(..),
xtest,
xtest, xunset, xset,
lexTokenStream,
AddAnn(..),mkParensApiAnn,
addAnnsAt,
......@@ -2207,12 +2209,13 @@ data ParseResult a
-- a non-empty bag of errors.
-- | Test whether a 'WarningFlag' is set
warnopt :: WarningFlag -> ParserFlags -> Bool
warnopt :: WarningFlag -> ParserOpts -> Bool
warnopt f options = f `EnumSet.member` pWarningFlags options
-- | The subset of the 'DynFlags' used by the parser.
-- See 'mkParserFlags' or 'mkParserFlags'' for ways to construct this.
data ParserFlags = ParserFlags {
-- | Parser options.
--
-- See 'mkParserOpts' to construct this.
data ParserOpts = ParserOpts {
pWarningFlags :: EnumSet WarningFlag
, pHomeUnitId :: UnitId -- ^ id of the unit currently being compiled
-- (only used in Cmm parser)
......@@ -2230,7 +2233,7 @@ data HdkComment
data PState = PState {
buffer :: StringBuffer,
options :: ParserFlags,
options :: ParserOpts,
-- This needs to take DynFlags as an argument until
-- we have a fix for #10143
messages :: DynFlags -> Messages,
......@@ -2570,6 +2573,12 @@ xbit = bit . fromEnum
xtest :: ExtBits -> ExtsBitmap -> Bool
xtest ext xmap = testBit xmap (fromEnum ext)
xset :: ExtBits -> ExtsBitmap -> ExtsBitmap
xset ext xmap = setBit xmap (fromEnum ext)
xunset :: ExtBits -> ExtsBitmap -> ExtsBitmap
xunset ext xmap = clearBit xmap (fromEnum ext)
-- | Various boolean flags, mostly language extensions, that impact lexing and
-- parsing. Note that a handful of these can change during lexing/parsing.
data ExtBits
......@@ -2630,19 +2639,8 @@ data ExtBits
-- tokens of their own.
deriving Enum
-- PState for parsing options pragmas
--
pragState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState
pragState dynflags buf loc = (mkPState dynflags buf loc) {
lex_state = [bol, option_prags, 0]
}
{-# INLINE mkParserFlags' #-}
mkParserFlags'
{-# INLINE mkParserOpts #-}
mkParserOpts
:: EnumSet WarningFlag -- ^ warnings flags enabled
-> EnumSet LangExt.Extension -- ^ permitted language extensions enabled
-> UnitId -- ^ id of the unit currently being compiled
......@@ -2656,11 +2654,11 @@ mkParserFlags'
-- the internal position kept by the parser. Otherwise, those pragmas are
-- lexed as 'ITline_prag' and 'ITcolumn_prag' tokens.
-> ParserFlags
-- ^ Given exactly the information needed, set up the 'ParserFlags'
mkParserFlags' warningFlags extensionFlags homeUnitId
-> ParserOpts
-- ^ Given exactly the information needed, set up the 'ParserOpts'
mkParserOpts warningFlags extensionFlags homeUnitId
safeImports isHaddock rawTokStream usePosPrags =
ParserFlags {
ParserOpts {
pWarningFlags = warningFlags
, pHomeUnitId = homeUnitId
, pExtsBitmap = safeHaskellBit .|. langExtBits .|. optBits
......@@ -2722,25 +2720,15 @@ mkParserFlags' warningFlags extensionFlags homeUnitId
b `setBitIf` cond | cond = xbit b
| otherwise = 0
-- | Extracts the flag information needed for parsing
mkParserFlags :: DynFlags -> ParserFlags
mkParserFlags =
mkParserFlags'
<$> DynFlags.warningFlags
<*> DynFlags.extensionFlags
<*> DynFlags.homeUnitId_
<*> safeImportsOn
<*> gopt Opt_Haddock
<*> gopt Opt_KeepRawTokenStream
<*> const True
-- | Creates a parse state from a 'DynFlags' value
mkPState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState
mkPState flags = mkPStatePure (mkParserFlags flags)
-- | Creates a parse state from a 'ParserFlags' value
mkPStatePure :: ParserFlags -> StringBuffer -> RealSrcLoc -> PState
mkPStatePure options buf loc =
-- | Set parser options for parsing OPTIONS pragmas
initPragState :: ParserOpts -> StringBuffer -> RealSrcLoc -> PState
initPragState options buf loc = (initParserState options buf loc)
{ lex_state = [bol, option_prags, 0]
}
-- | Creates a parse state from a 'ParserOpts' value
initParserState :: ParserOpts -> StringBuffer -> RealSrcLoc -> PState
initParserState options buf loc =
PState {
buffer = buf,
options = options,
......@@ -2818,7 +2806,7 @@ appendError srcspan msg m =
in (ws, es')
appendWarning
:: ParserFlags
:: ParserOpts
-> WarningFlag
-> SrcSpan
-> SDoc
......@@ -2928,7 +2916,7 @@ getOffside = P $ \s@PState{last_loc=loc, context=stk} ->
-- Construct a parse error
srcParseErr
:: ParserFlags
:: ParserOpts
-> StringBuffer -- current buffer (placed just after the last token)
-> Int -- length of the previous token
-> MsgDoc
......@@ -3248,16 +3236,20 @@ reportLexError loc1 loc2 buf str
then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)")
else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c)
lexTokenStream :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token]
lexTokenStream buf loc dflags = unP go initState{ options = opts' }
where dflags' = gopt_set (gopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream
initState@PState{ options = opts } = mkPState dflags' buf loc
opts' = opts{ pExtsBitmap = complement (xbit UsePosPragsBit) .&. pExtsBitmap opts }
go = do
ltok <- lexer False return
case ltok of
L _ ITeof -> return []
_ -> liftM (ltok:) go
lexTokenStream :: ParserOpts -> StringBuffer -> RealSrcLoc -> ParseResult [Located Token]
lexTokenStream opts buf loc = unP go initState{ options = opts' }
where
new_exts = xunset HaddockBit -- disable Haddock
$ xunset UsePosPragsBit -- parse LINE/COLUMN pragmas as tokens
$ xset RawTokenStreamBit -- include comments
$ pExtsBitmap opts
opts' = opts { pExtsBitmap = new_exts }
initState = initParserState opts' buf loc
go = do
ltok <- lexer False return
case ltok of
L _ ITeof -> return []
_ -> liftM (ltok:) go
linePrags = Map.singleton "line" linePrag
......
......@@ -2660,7 +2660,7 @@ failOpFewArgs (L loc op) =
data PV_Context =
PV_Context
{ pv_options :: ParserFlags
{ pv_options :: ParserOpts
, pv_hint :: SDoc -- See Note [Parser-Validator Hint]
}
......
......@@ -96,8 +96,8 @@ import GHC.Utils.Outputable
import GHC.Data.FastString
import GHC.Data.Bag
import GHC.Utils.Misc
import qualified GHC.Parser.Lexer as Lexer (P (..), ParseResult(..), unP, mkPStatePure)
import GHC.Parser.Lexer (ParserFlags)
import qualified GHC.Parser.Lexer as Lexer (P (..), ParseResult(..), unP, initParserState)
import GHC.Parser.Lexer (ParserOpts)
import qualified GHC.Parser as Parser (parseStmt, parseModule, parseDeclaration, parseImport)
import System.Directory
......@@ -877,14 +877,14 @@ parseName str = withSession $ \hsc_env -> liftIO $
; hscTcRnLookupRdrName hsc_env lrdr_name }
-- | Returns @True@ if passed string is a statement.
isStmt :: ParserFlags -> String -> Bool
isStmt :: ParserOpts -> String -> Bool
isStmt pflags stmt =
case parseThing Parser.parseStmt pflags stmt of
Lexer.POk _ _ -> True
Lexer.PFailed _ -> False
-- | Returns @True@ if passed string has an import declaration.
hasImport :: ParserFlags -> String -> Bool
hasImport :: ParserOpts -> String -> Bool
hasImport pflags stmt =
case parseThing Parser.parseModule pflags stmt of
Lexer.POk _ thing -> hasImports thing
......@@ -893,14 +893,14 @@ hasImport pflags stmt =
hasImports = not . null . hsmodImports . unLoc
-- | Returns @True@ if passed string is an import declaration.
isImport :: ParserFlags -> String -> Bool
isImport :: ParserOpts -> String -> Bool
isImport pflags stmt =
case parseThing Parser.parseImport pflags stmt of
Lexer.POk _ _ -> True
Lexer.PFailed _ -> False
-- | Returns @True@ if passed string is a declaration but __/not a splice/__.
isDecl :: ParserFlags -> String -> Bool
isDecl :: ParserOpts -> String -> Bool
isDecl pflags stmt = do
case parseThing Parser.parseDeclaration pflags stmt of
Lexer.POk _ thing ->
......@@ -909,12 +909,12 @@ isDecl pflags stmt = do
_ -> True
Lexer.PFailed _ -> False
parseThing :: Lexer.P thing -> ParserFlags -> String -> Lexer.ParseResult thing
parseThing parser pflags stmt = do
parseThing :: Lexer.P thing -> ParserOpts -> String -> Lexer.ParseResult thing
parseThing parser opts stmt = do
let buf = stringToStringBuffer stmt
loc = mkRealSrcLoc (fsLit "<interactive>") 1 1
Lexer.unP parser (Lexer.mkPStatePure pflags buf loc)
Lexer.unP parser (Lexer.initParserState opts buf loc)
getDocs :: GhcMonad m
=> Name
......
......@@ -50,6 +50,7 @@ import GHC.Driver.Ppr hiding (printForUser)
import GHC.Utils.Error hiding (traceCmd)
import GHC.Driver.Finder as Finder
import GHC.Driver.Monad ( modifySession )
import GHC.Driver.Config
import qualified GHC
import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..),
TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc,
......@@ -1133,7 +1134,7 @@ checkInputForLayout stmt getStmt = do
st0 <- getGHCiState
let buf' = stringToStringBuffer stmt
loc = mkRealSrcLoc (fsLit (progname st0)) (line_number st0) 1
pstate = Lexer.mkPState dflags buf' loc
pstate = Lexer.initParserState (initParserOpts dflags) buf' loc
case Lexer.unP goToEnd pstate of
(Lexer.POk _ False) -> return $ Just stmt
_other -> do
......@@ -1175,7 +1176,7 @@ enqueueCommands cmds = do
-- The return value True indicates success, as in `runOneCommand`.
runStmt :: GhciMonad m => String -> SingleStep -> m (Maybe GHC.ExecResult)
runStmt input step = do
pflags <- Lexer.mkParserFlags <$> GHC.getInteractiveDynFlags
pflags <- initParserOpts <$> GHC.getInteractiveDynFlags
-- In GHCi, we disable `-fdefer-type-errors`, as well as `-fdefer-type-holes`
-- and `-fdefer-out-of-scope-variables` for **naked expressions**. The
-- declarations and statements are not affected.
......
import System.Environment
import GHC.Driver.Session
import GHC.Driver.Config
import GHC.Data.FastString
import GHC
import GHC.Data.StringBuffer
......@@ -16,7 +17,8 @@ main = do
hdk_comments <- runGhc (Just libdir) $ do
dflags <- getSessionDynFlags
let pstate = mkPState (dflags `gopt_set` Opt_Haddock) stringBuffer loc
let opts = initParserOpts (dflags `gopt_set` Opt_Haddock)
pstate = initParserState opts stringBuffer loc
case unP (lexer False return) pstate of
POk s (L _ ITeof) -> return (map unLoc (toList (hdk_comments s)))
_ -> error "No token"
......
......@@ -3,7 +3,7 @@ module Main where
import GHC
import GHC.Driver.Session
import GHC.Driver.Monad
import GHC.Parser.Lexer (mkParserFlags)
import GHC.Driver.Config
import System.Environment
testStrings = [
......@@ -53,7 +53,7 @@ main = do
where
testWithParser parser = do
dflags <- getSessionDynFlags
let pflags = mkParserFlags dflags
let pflags = initParserOpts dflags
liftIO . putStrLn . unlines $ map (testExpr (parser pflags)) testStrings
testExpr parser expr = do
......
......@@ -28,9 +28,12 @@ main = do
[libdir] <- getArgs
modules <- parserDeps libdir
let num = sizeUniqSet modules
-- print num
-- print (map moduleNameString $ nonDetEltsUniqSet modules)
unless (num <= 201) $ exitWith (ExitFailure num)
max_num = 201
min_num = max_num - 10 -- so that we don't forget to change the number
-- when the number of dependencies decreases
-- putStrLn $ "Found " ++ show num ++ " parser module dependencies"
-- forM_ (map moduleNameString $ nonDetEltsUniqSet modules) putStrLn
unless (num <= max_num && num >= min_num) $ exitWith (ExitFailure num)
parserDeps :: FilePath -> IO (UniqSet ModuleName)
parserDeps libdir =
......
Subproject commit 37c47822d390b553ce24fe256c9700d5fd83bf9f
Subproject commit a18c3af7f983f3b6d3cd84093c9079031da58468
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment