[Git][ghc/ghc][master] 2 commits: haddock: Move the usage of mkParserOpts directly to ppHyperlinkedModuleSource...
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Jun 24 21:23:41 UTC 2024
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
8f4b799d by Hécate Kleidukos at 2024-06-24T17:22:30-04:00
haddock: Move the usage of mkParserOpts directly to ppHyperlinkedModuleSource in order to avoid passing a whole DynFlags
Follow up to !12931
- - - - -
210cf1cd by Hécate Kleidukos at 2024-06-24T17:22:30-04:00
haddock: Remove cabal file linting rule
This will be reintroduced with a properly ignored commit
when the cabal files are themselves formatted for good.
- - - - -
10 changed files:
- utils/haddock/Makefile
- utils/haddock/haddock-api/src/Haddock.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
- utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
- utils/haddock/haddock-api/src/Haddock/Interface.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
- utils/haddock/haddock-api/src/Haddock/Interface/LexParseRn.hs
- utils/haddock/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
- utils/haddock/haddock-api/src/Haddock/Parser.hs
Changes:
=====================================
utils/haddock/Makefile
=====================================
@@ -11,15 +11,12 @@ lint: ## Run the code linter (HLint)
@find driver haddock-api haddock-library -name "*.hs" | xargs -P $(PROCS) -I {} hlint --refactor-options="-i" --refactor {}
style: ## Run the code styler (fourmolu and cabal-fmt)
- @cabal-fmt -i **/*.cabal
@fourmolu -q --mode inplace driver haddock-api haddock-library
style-check: ## Check the code's style (fourmolu and cabal-fmt)
- @cabal-fmt -c **/*.cabal
@fourmolu -q --mode check driver haddock-api haddock-library
style-quick: ## Run the code styler on modified files tracked by git
- @cabal-fmt -i **/*.cabal
@git diff origin --name-only driver haddock-api haddock-library | xargs -P $(PROCS) -I {} fourmolu -q -i {}
tags: ## Generate ctags and etags for the source code (ghc-tags)
=====================================
utils/haddock/haddock-api/src/Haddock.hs
=====================================
@@ -57,6 +57,8 @@ import Data.Maybe
import Data.IORef
import Data.Map.Strict (Map)
import Data.Version (makeVersion)
+import GHC.Parser.Lexer (ParserOpts)
+import qualified GHC.Driver.Config.Parser as Parser
import qualified Data.Map.Strict as Map
import System.IO
import System.Exit
@@ -200,8 +202,14 @@ haddockWithGhc ghc args = handleTopExceptions $ do
hPutStrLn stderr noCheckWarning
ghc flags' $ withDir $ do
- dflags <- getDynFlags
- logger <- getLogger
+ dflags' <- getDynFlags
+ let unicode = Flag_UseUnicode `elem` flags
+ let dflags
+ | unicode = gopt_set dflags' Opt_PrintUnicodeSyntax
+ | otherwise = dflags'
+ logger' <- getLogger
+ let logger = setLogFlags logger' (initLogFlags dflags)
+ let parserOpts = Parser.initParserOpts dflags
!unit_state <- hsc_units <$> getSession
-- If any --show-interface was used, show the given interfaces
@@ -229,7 +237,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
}
-- Render the interfaces.
- liftIO $ renderStep logger dflags unit_state flags sinceQual qual packages ifaces
+ liftIO $ renderStep dflags parserOpts logger unit_state flags sinceQual qual packages ifaces
-- If we were not given any input files, error if documentation was
-- requested
@@ -242,7 +250,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
packages <- liftIO $ readInterfaceFiles name_cache (readIfaceArgs flags) noChecks
-- Render even though there are no input files (usually contents/index).
- liftIO $ renderStep logger dflags unit_state flags sinceQual qual packages []
+ liftIO $ renderStep dflags parserOpts logger unit_state flags sinceQual qual packages []
-- | Run the GHC action using a temporary output directory
withTempOutputDir :: Ghc a -> Ghc a
@@ -294,9 +302,18 @@ readPackagesAndProcessModules flags files = do
return (packages, ifaces, homeLinks)
-renderStep :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption
- -> [(DocPaths, Visibility, FilePath, InterfaceFile)] -> [Interface] -> IO ()
-renderStep logger dflags unit_state flags sinceQual nameQual pkgs interfaces = do
+renderStep
+ :: DynFlags
+ -> ParserOpts
+ -> Logger
+ -> UnitState
+ -> [Flag]
+ -> SinceQual
+ -> QualOption
+ -> [(DocPaths, Visibility, FilePath, InterfaceFile)]
+ -> [Interface]
+ -> IO ()
+renderStep dflags parserOpts logger unit_state flags sinceQual nameQual pkgs interfaces = do
updateHTMLXRefs (map (\(docPath, _ifaceFilePath, _showModules, ifaceFile) ->
( case baseUrl flags of
Nothing -> docPathsHtml docPath
@@ -312,7 +329,7 @@ renderStep logger dflags unit_state flags sinceQual nameQual pkgs interfaces = d
(DocPaths {docPathsSources=Just path}, _, _, ifile) <- pkgs
iface <- ifInstalledIfaces ifile
return (instMod iface, path)
- render logger dflags unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap
+ render dflags parserOpts logger unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap
where
-- get package name from unit-id
packageName :: Unit -> String
@@ -322,10 +339,19 @@ renderStep logger dflags unit_state flags sinceQual nameQual pkgs interfaces = d
Just pkg -> unitPackageNameString pkg
-- | Render the interfaces with whatever backend is specified in the flags.
-render :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption -> [Interface]
- -> [(FilePath, PackageInterfaces)] -> Map Module FilePath -> IO ()
-render log' dflags unit_state flags sinceQual qual ifaces packages extSrcMap = do
-
+render
+ :: DynFlags
+ -> ParserOpts
+ -> Logger
+ -> UnitState
+ -> [Flag]
+ -> SinceQual
+ -> QualOption
+ -> [Interface]
+ -> [(FilePath, PackageInterfaces)]
+ -> Map Module FilePath
+ -> IO ()
+render dflags parserOpts logger unit_state flags sinceQual qual ifaces packages extSrcMap = do
let
packageInfo = PackageInfo { piPackageName = fromMaybe (PackageName mempty)
$ optPackageName flags
@@ -344,10 +370,6 @@ render log' dflags unit_state flags sinceQual qual ifaces packages extSrcMap = d
opt_latex_style = optLaTeXStyle flags
opt_source_css = optSourceCssFile flags
opt_mathjax = optMathjax flags
- dflags'
- | unicode = gopt_set dflags Opt_PrintUnicodeSyntax
- | otherwise = dflags
- logger = setLogFlags log' (initLogFlags dflags')
visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ]
@@ -443,7 +465,7 @@ render log' dflags unit_state flags sinceQual qual ifaces packages extSrcMap = d
_ -> warn' ("Cannot parse reexported module flag '" ++ mod_str ++ "'") >> return [])
libDir <- getHaddockLibDir flags
- !prologue <- force <$> getPrologue dflags' flags
+ !prologue <- force <$> getPrologue parserOpts flags
themes <- getThemes libDir flags >>= either bye return
let withQuickjump = Flag_QuickJumpIndex `elem` flags
@@ -509,7 +531,7 @@ render log' dflags unit_state flags sinceQual qual ifaces packages extSrcMap = d
pkgVer =
fromMaybe (makeVersion []) mpkgVer
- in ppHoogle dflags' unit_state pkgNameStr pkgVer title (fmap _doc prologue)
+ in ppHoogle dflags unit_state pkgNameStr pkgVer title (fmap _doc prologue)
visibleIfaces odir
_ -> putStrLn . unlines $
[ "haddock: Unable to find a package providing module "
@@ -803,15 +825,15 @@ updateHTMLXRefs packages = do
mapping' = [ (moduleName m, html) | (m, html) <- mapping ]
-getPrologue :: DynFlags -> [Flag] -> IO (Maybe (MDoc RdrName))
-getPrologue dflags flags =
+getPrologue :: ParserOpts -> [Flag] -> IO (Maybe (MDoc RdrName))
+getPrologue parserOpts flags =
case [filename | Flag_Prologue filename <- flags ] of
[] -> return Nothing
[filename] -> do
h <- openFile filename ReadMode
hSetEncoding h utf8
str <- hGetContents h -- semi-closes the handle
- return . Just $! second (fmap rdrName) $ parseParas dflags Nothing str
+ return . Just $! second (fmap rdrName) $ parseParas parserOpts Nothing str
_ -> throwE "multiple -p/--prologue options"
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs
=====================================
@@ -23,9 +23,14 @@ import System.FilePath
import Data.Map as M
import GHC.Data.FastString (mkFastString)
+import GHC.Driver.Config.Diagnostic (initDiagOpts)
+import GHC.Driver.DynFlags (DynFlags (extensionFlags, targetPlatform))
import qualified GHC.Driver.DynFlags as DynFlags
+import GHC.Driver.Session (safeImportsOn, supportedLanguagesAndExtensions)
import GHC.Iface.Ext.Binary (hie_file_result, readHieFile)
import GHC.Iface.Ext.Types (HieAST (..), HieASTs (..), HieFile (..), SourcedNodeInfo (..), pattern HiePath)
+import GHC.Parser.Lexer as Lexer
+import GHC.Platform
import GHC.Types.SrcLoc (mkRealSrcLoc, realSrcLocSpan, srcSpanFile)
import GHC.Unit.Module (Module, moduleName)
import qualified GHC.Utils.Outputable as Outputable
@@ -80,7 +85,7 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = do
mast
| M.size asts == 1 = snd <$> M.lookupMin asts
| otherwise = M.lookup (HiePath (mkFastString file)) asts
- tokens' = parse dflags sDocContext file rawSrc
+ tokens' = parse parserOpts sDocContext file rawSrc
ast = fromMaybe (emptyHieAst fileFs) mast
fullAst = recoverFullIfaceTypes sDocContext types ast
@@ -107,7 +112,17 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = do
writeUtf8File path . renderToString pretty . render' fullAst $ tokens
where
dflags = ifaceDynFlags iface
+ arch_os = platformArchOS (dflags.targetPlatform)
sDocContext = DynFlags.initSDocContext dflags Outputable.defaultUserStyle
+ parserOpts =
+ Lexer.mkParserOpts
+ (dflags.extensionFlags)
+ (initDiagOpts dflags)
+ (supportedLanguagesAndExtensions arch_os)
+ (safeImportsOn dflags)
+ False -- lex Haddocks as comment tokens
+ True -- produce comment tokens
+ False -- produce position pragmas tokens
render' = render (Just srcCssFile) (Just highlightScript) srcs
path = srcdir </> hypSrcModuleFile (ifaceMod iface)
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
=====================================
@@ -14,20 +14,17 @@ import qualified Data.ByteString as BS
import GHC.Data.Bag (bagToList)
import GHC.Data.FastString (mkFastString)
import GHC.Data.StringBuffer (StringBuffer, atEnd)
-import GHC.Driver.Config.Diagnostic
-import GHC.Driver.Session
import GHC.Parser.Errors.Ppr ()
import GHC.Parser.Lexer as Lexer
( P (..)
, PState (..)
, ParseResult (..)
+ , ParserOpts
, Token (..)
, getPsErrorMessages
, initParserState
, lexer
- , mkParserOpts
)
-import GHC.Platform
import qualified GHC.Types.Error as E
import GHC.Types.SourceText
import GHC.Types.SrcLoc
@@ -44,15 +41,14 @@ import Haddock.GhcUtils
-- Result should retain original file layout (including comments,
-- whitespace, and CPP).
parse
- :: DynFlags
- -- ^ Flags for this module
+ :: ParserOpts
-> SDocContext
-> FilePath
-- ^ Path to the source of this module
-> BS.ByteString
-- ^ Raw UTF-8 encoded source of this module
-> [T.Token]
-parse dflags sDocContext fpath bs = case unP (go False []) initState of
+parse parserOpts sDocContext fpath bs = case unP (go False []) initState of
POk _ toks -> reverse toks
PFailed pst ->
let err : _ = bagToList (E.getMessages $ getPsErrorMessages pst)
@@ -60,19 +56,9 @@ parse dflags sDocContext fpath bs = case unP (go False []) initState of
Outputable.renderWithContext sDocContext $
text "Hyperlinker parse error:" $$ pprLocMsgEnvelopeDefault err
where
- initState = initParserState pflags buf start
+ initState = initParserState parserOpts buf start
buf = stringBufferFromByteString bs
start = mkRealSrcLoc (mkFastString fpath) 1 1
- arch_os = platformArchOS (targetPlatform dflags)
- pflags =
- mkParserOpts
- (extensionFlags dflags)
- (initDiagOpts dflags)
- (supportedLanguagesAndExtensions arch_os)
- (safeImportsOn dflags)
- False -- lex Haddocks as comment tokens
- True -- produce comment tokens
- False -- produce position pragmas tokens
go
:: Bool
-- \^ are we currently in a pragma?
=====================================
utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
=====================================
@@ -45,7 +45,6 @@ import GHC.Builtin.Types (liftedRepTy)
import GHC.Core.TyCo.Rep (Type (..))
import GHC.Core.Type (binderVar, isRuntimeRepVar)
import GHC.Data.FastString
-import GHC.Driver.Ppr (showPpr)
import GHC.Driver.Session
import GHC.Types.Name
import GHC.Types.SrcLoc (advanceSrcLoc)
@@ -60,7 +59,8 @@ import GHC.Types.Var
import GHC.Types.Var.Env (TyVarEnv, elemVarEnv, emptyVarEnv, extendVarEnv)
import GHC.Types.Var.Set (VarSet, emptyVarSet)
import GHC.Utils.FV as FV
-import GHC.Utils.Outputable (Outputable)
+import GHC.Utils.Outputable (Outputable, SDocContext, ppr)
+import qualified GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic (panic)
import GHC.Data.StringBuffer (StringBuffer)
@@ -131,8 +131,8 @@ isClassD :: HsDecl a -> Bool
isClassD (TyClD _ d) = isClassDecl d
isClassD _ = False
-pretty :: Outputable a => DynFlags -> a -> String
-pretty = showPpr
+pretty :: Outputable a => SDocContext -> a -> String
+pretty sDocContext thing = Outputable.renderWithContext sDocContext (ppr thing)
dataListModule :: Module
dataListModule = mkBaseModule (fsLit "Data.List")
=====================================
utils/haddock/haddock-api/src/Haddock/Interface.hs
=====================================
@@ -62,6 +62,8 @@ import GHC.Driver.Monad
import GHC.Driver.Make
import GHC.Driver.Main
import GHC.Core.InstEnv
+import qualified GHC.Driver.DynFlags as DynFlags
+import qualified GHC.Utils.Outputable as Outputable
import GHC.Driver.Session hiding (verbosity)
import GHC.HsToCore.Docs (getMainDeclBinder)
import GHC.Types.Error (mkUnknownDiagnostic)
@@ -239,6 +241,7 @@ processModule verbosity modSummary flags ifaceMap instIfaceMap = do
hsc_env <- getSession
dflags <- getDynFlags
+ let sDocContext = DynFlags.initSDocContext dflags Outputable.defaultUserStyle
let hmi = case lookupHpt (hsc_HPT hsc_env) (moduleName $ ms_mod modSummary) of
Nothing -> error "processModule: All modules should be loaded into the HPT by this point"
Just x -> x
@@ -294,7 +297,7 @@ processModule verbosity modSummary flags ifaceMap instIfaceMap = do
p :: Outputable a => [a] -> String
p [] = ""
- p (x:_) = let n = pretty dflags x
+ p (x:_) = let n = pretty sDocContext x
ms = modString ++ "."
in if ms `isPrefixOf` n
then drop (length ms) n
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
=====================================
@@ -56,10 +56,12 @@ import GHC.Builtin.Names
import GHC.Builtin.Types.Prim
import GHC.Core.ConLike (ConLike (..))
import GHC.Data.FastString (FastString, bytesFS, unpackFS)
+import qualified GHC.Driver.Config.Parser as Parser
import qualified GHC.Driver.DynFlags as DynFlags
import GHC.Driver.Ppr
import GHC.HsToCore.Docs hiding (mkMaps)
import GHC.Iface.Syntax
+import GHC.Parser.Lexer (ParserOpts)
import GHC.Types.Avail
import GHC.Types.Name
import GHC.Types.Name.Set
@@ -95,6 +97,8 @@ createInterface1 flags unit_state mod_sum mod_iface ifaces inst_ifaces (instance
sDocContext = DynFlags.initSDocContext dflags Outputable.defaultUserStyle
dflags = ms_hspp_opts
+ mLanguage = language dflags
+ parserOpts = Parser.initParserOpts dflags
mdl = mi_module mod_iface
sem_mdl = mi_semantic_module mod_iface
is_sig = isJust (mi_sig_of mod_iface)
@@ -148,29 +152,30 @@ createInterface1 flags unit_state mod_sum mod_iface ifaces inst_ifaces (instance
(!info, header_doc) <-
processModuleHeader
- dflags
+ mLanguage
+ parserOpts
sDocContext
pkg_name
safety
(docs_language mod_iface_docs)
(docs_extensions mod_iface_docs)
(docs_mod_hdr mod_iface_docs)
- mod_warning <- moduleWarning dflags sDocContext warnings
+ mod_warning <- moduleWarning parserOpts sDocContext warnings
(docMap :: DocMap Name) <- do
let docsDecls = Map.fromList $ UniqMap.nonDetUniqMapToList mod_iface_docs.docs_decls
- traverse (processDocStringsParas dflags sDocContext pkg_name) docsDecls
+ traverse (processDocStringsParas parserOpts sDocContext pkg_name) docsDecls
- exportsSinceMap <- mkExportSinceMap dflags sDocContext pkg_name mod_iface_docs
+ exportsSinceMap <- mkExportSinceMap parserOpts sDocContext pkg_name mod_iface_docs
(argMap :: Map Name (Map Int (MDoc Name))) <- do
let docsArgs = Map.fromList $ UniqMap.nonDetUniqMapToList mod_iface_docs.docs_args
(result :: Map Name (IntMap (MDoc Name))) <-
- traverse (traverse (processDocStringParas dflags sDocContext pkg_name)) docsArgs
+ traverse (traverse (processDocStringParas parserOpts sDocContext pkg_name)) docsArgs
let result2 = Map.map (\intMap -> Map.fromList $ IM.assocs intMap) result
pure result2
- warningMap <- mkWarningMap dflags sDocContext warnings exportedNames
+ warningMap <- mkWarningMap parserOpts sDocContext warnings exportedNames
let local_instances =
filter (nameIsLocalOrFrom sem_mdl) $
@@ -204,6 +209,7 @@ createInterface1 flags unit_state mod_sum mod_iface ifaces inst_ifaces (instance
(bonus_ds $ docs_structure mod_iface_docs)
inst_ifaces
dflags
+ parserOpts
sDocContext
def_meths_env
@@ -264,17 +270,17 @@ createInterface1 flags unit_state mod_sum mod_iface ifaces inst_ifaces (instance
mkExportSinceMap
:: forall m
. MonadIO m
- => DynFlags
+ => ParserOpts
-> SDocContext
-> Maybe Package
-> Docs
-> IfM m (Map Name MetaSince)
-mkExportSinceMap dflags sDocContext pkg_name docs = do
+mkExportSinceMap parserOpts sDocContext pkg_name docs = do
Map.unions <$> traverse processExportDoc (UniqMap.nonDetUniqMapToList (docs_exports docs))
where
processExportDoc :: (Name, HsDoc GhcRn) -> IfM m (Map Name MetaSince)
processExportDoc (nm, doc) = do
- mdoc <- processDocStringsParas dflags sDocContext pkg_name [doc]
+ mdoc <- processDocStringsParas parserOpts sDocContext pkg_name [doc]
case _doc mdoc of
DocEmpty -> return ()
_ -> warn "Export docstrings may only contain @since annotations"
@@ -288,12 +294,12 @@ mkExportSinceMap dflags sDocContext pkg_name docs = do
mkWarningMap
:: MonadIO m
- => DynFlags
+ => ParserOpts
-> SDocContext
-> IfaceWarnings
-> [Name]
-> IfM m WarningMap
-mkWarningMap dflags sDocContext warnings exps =
+mkWarningMap parserOpts sDocContext warnings exps =
case warnings of
IfWarnSome ws _ ->
let expsOccEnv = mkOccEnv [(nameOccName n, n) | n <- exps]
@@ -303,25 +309,25 @@ mkWarningMap dflags sDocContext warnings exps =
case lookupOccEnv_WithFields expsOccEnv occ of
(n : _) -> Just (n, w)
[] -> Nothing
- in Map.fromList <$> traverse (traverse (parseWarning dflags sDocContext)) ws'
+ in Map.fromList <$> traverse (traverse (parseWarning parserOpts sDocContext)) ws'
_ -> pure Map.empty
moduleWarning
:: MonadIO m
- => DynFlags
+ => ParserOpts
-> SDocContext
-> IfaceWarnings
-> IfM m (Maybe (Doc Name))
-moduleWarning dflags sDocContext (IfWarnAll w) = Just <$> parseWarning dflags sDocContext w
+moduleWarning parserOpts sDocContext (IfWarnAll w) = Just <$> parseWarning parserOpts sDocContext w
moduleWarning _ _ _ = pure Nothing
parseWarning
:: MonadIO m
- => DynFlags
+ => ParserOpts
-> SDocContext
-> IfaceWarningTxt
-> IfM m (Doc Name)
-parseWarning dflags sDocContext w = case w of
+parseWarning parserOpts sDocContext w = case w of
IfDeprecatedTxt _ msg -> format "Deprecated: " (map dstToDoc msg)
IfWarningTxt _ _ msg -> format "Warning: " (map dstToDoc msg)
where
@@ -333,7 +339,7 @@ parseWarning dflags sDocContext w = case w of
format x bs =
DocWarning . DocParagraph . DocAppend (DocString x)
- <$> foldrM (\doc rest -> docAppend <$> processDocString dflags sDocContext doc <*> pure rest) DocEmpty bs
+ <$> foldrM (\doc rest -> docAppend <$> processDocString parserOpts sDocContext doc <*> pure rest) DocEmpty bs
-------------------------------------------------------------------------------
-- Doc options
@@ -401,6 +407,7 @@ mkExportItems
-> DocStructure
-> InstIfaceMap
-> DynFlags
+ -> ParserOpts
-> SDocContext
-> OccEnv Name
-> IfM m [ExportItem GhcRn]
@@ -418,6 +425,7 @@ mkExportItems
dsItems
instIfaceMap
dflags
+ parserOpts
sDocContext
defMeths =
concat <$> traverse lookupExport dsItems
@@ -425,10 +433,10 @@ mkExportItems
lookupExport :: MonadIO m => DocStructureItem -> IfM m [ExportItem GhcRn]
lookupExport = \case
DsiSectionHeading lev hsDoc' -> do
- doc <- processDocString dflags sDocContext hsDoc'
+ doc <- processDocString parserOpts sDocContext hsDoc'
pure [ExportGroup lev "" doc]
DsiDocChunk hsDoc' -> do
- doc <- processDocStringParas dflags sDocContext pkgName hsDoc'
+ doc <- processDocStringParas parserOpts sDocContext pkgName hsDoc'
pure [ExportDoc doc]
DsiNamedChunkRef ref -> do
case Map.lookup ref namedChunks of
@@ -436,7 +444,7 @@ mkExportItems
warn $ "Cannot find documentation for: $" ++ ref
pure []
Just hsDoc' -> do
- doc <- processDocStringParas dflags sDocContext pkgName hsDoc'
+ doc <- processDocStringParas parserOpts sDocContext pkgName hsDoc'
pure [ExportDoc doc]
DsiExports avails ->
-- TODO: We probably don't need nubAvails here.
@@ -445,7 +453,7 @@ mkExportItems
DsiModExport mod_names avails -> do
-- only consider exporting a module if we are sure we are really
-- exporting the whole module and not some subset.
- (unrestricted_mods, remaining_avails) <- unrestrictedModExports dflags thisMod modMap instIfaceMap avails (NE.toList mod_names)
+ (unrestricted_mods, remaining_avails) <- unrestrictedModExports sDocContext thisMod modMap instIfaceMap avails (NE.toList mod_names)
avail_exps <- concat <$> traverse availExport remaining_avails
pure (map ExportModule unrestricted_mods ++ avail_exps)
@@ -468,7 +476,7 @@ mkExportItems
unrestrictedModExports
:: MonadIO m
- => DynFlags
+ => SDocContext
-> Module
-- ^ Current Module
-> IfaceMap
@@ -483,7 +491,7 @@ unrestrictedModExports
-- , remaining exports not included in any
-- of these modules
-- )
-unrestrictedModExports dflags thisMod ifaceMap instIfaceMap avails mod_names = do
+unrestrictedModExports sDocContext thisMod ifaceMap instIfaceMap avails mod_names = do
mods_and_exports <- fmap catMaybes $ for mod_names $ \mod_name -> do
let m_local = mkModule (moduleUnit thisMod) mod_name
case Map.lookup m_local ifaceMap of
@@ -495,10 +503,10 @@ unrestrictedModExports dflags thisMod ifaceMap instIfaceMap avails mod_names = d
Nothing -> do
warn $
"Warning: "
- ++ pretty dflags thisMod
+ ++ pretty sDocContext thisMod
++ ": Could not find "
++ "documentation for exported module: "
- ++ pretty dflags mod_name
+ ++ pretty sDocContext mod_name
pure Nothing
let unrestricted = filter everythingVisible mods_and_exports
mod_exps = unionNameSets (map snd unrestricted)
@@ -557,7 +565,7 @@ availExportItem
declWith :: AvailInfo -> IfM m [ExportItem GhcRn]
declWith avail = do
let t = availName avail
- mayDecl <- hiDecl dflags sDocContext prr t
+ mayDecl <- hiDecl sDocContext prr t
case mayDecl of
Nothing -> return [ExportNoDecl t []]
Just decl -> do
@@ -580,9 +588,9 @@ availExportItem
Nothing -> do
warn $
"Warning: "
- ++ pretty dflags thisMod
+ ++ pretty sDocContext thisMod
++ ": Couldn't find .haddock for export "
- ++ pretty dflags t
+ ++ pretty sDocContext t
let subs_ = availNoDocs avail
pure (noDocForDecl, subs_)
Just instIface ->
@@ -596,7 +604,7 @@ availExportItem
extractDecl prr dflags sDocContext declName parentDecl >>= \case
Right d -> pure d
Left err -> do
- synifiedDeclOpt <- hiDecl dflags sDocContext prr declName
+ synifiedDeclOpt <- hiDecl sDocContext prr declName
case synifiedDeclOpt of
Just synifiedDecl -> pure synifiedDecl
Nothing -> pprPanic "availExportItem" (O.text err)
@@ -708,16 +716,15 @@ applyExportSince _ _ dd = dd
hiDecl
:: MonadIO m
- => DynFlags
- -> SDocContext
+ => SDocContext
-> PrintRuntimeReps
-> Name
-> IfM m (Maybe (LHsDecl GhcRn))
-hiDecl dflags sDocContext prr t = do
+hiDecl sDocContext prr t = do
mayTyThing <- lookupName t
case mayTyThing of
Nothing -> do
- warn $ "Warning: Not found in environment: " ++ pretty dflags t
+ warn $ "Warning: Not found in environment: " ++ pretty sDocContext t
return Nothing
Just x -> case tyThingToLHsDecl prr x of
Left m -> (warn $ bugWarn m) >> return Nothing
@@ -830,7 +837,7 @@ extractDecl prr dflags sDocContext name decl
in pure (Right $ L pos (SigD noExtField sig))
(_, [L pos fam_decl]) -> pure (Right $ L pos (TyClD noExtField (FamDecl noExtField fam_decl)))
([], []) -> do
- famInstDeclOpt <- hiDecl dflags sDocContext prr name
+ famInstDeclOpt <- hiDecl sDocContext prr name
case famInstDeclOpt of
Nothing ->
pure $
@@ -867,7 +874,7 @@ extractDecl prr dflags sDocContext name decl
pure (SigD noExtField <$> lsig)
TyClD _ FamDecl{}
| isValName name -> do
- famInstOpt <- hiDecl dflags sDocContext prr name
+ famInstOpt <- hiDecl sDocContext prr name
case famInstOpt of
Just famInst -> extractDecl prr dflags sDocContext name famInst
Nothing -> pure $ Left ("extractDecl: Unhandled decl for " ++ getOccString name)
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/LexParseRn.hs
=====================================
@@ -35,6 +35,7 @@ import GHC.Data.EnumSet as EnumSet
import GHC.Data.FastString (unpackFS)
import GHC.Driver.Session
import qualified GHC.LanguageExtensions as LangExt
+import GHC.Parser.Lexer (ParserOpts)
import GHC.Parser.PostProcess
import GHC.Types.Avail
import GHC.Types.Name
@@ -49,39 +50,40 @@ import Haddock.Types
processDocStringsParas
:: MonadIO m
- => DynFlags
+ => ParserOpts
-> SDocContext
-> Maybe Package
-> [HsDoc GhcRn]
-> IfM m (MDoc Name)
-processDocStringsParas dflags sDocContext pkg hdss =
- overDocF (rename sDocContext $ hsDocRenamer hds) $ parseParas dflags pkg (renderHsDocStrings $ hsDocString hds)
+processDocStringsParas parserOpts sDocContext pkg hdss =
+ overDocF (rename sDocContext $ hsDocRenamer hds) $ parseParas parserOpts pkg (renderHsDocStrings $ hsDocString hds)
where
hds :: WithHsDocIdentifiers [HsDocString] GhcRn
hds = WithHsDocIdentifiers (map hsDocString hdss) (concatMap hsDocIdentifiers hdss)
processDocStringParas
:: MonadIO m
- => DynFlags
+ => ParserOpts
-> SDocContext
-> Maybe Package
-> HsDoc GhcRn
-> IfM m (MDoc Name)
-processDocStringParas dflags sDocContext pkg hds =
- overDocF (rename sDocContext $ hsDocRenamer hds) $ parseParas dflags pkg (renderHsDocString $ hsDocString hds)
+processDocStringParas parserOpts sDocContext pkg hds =
+ overDocF (rename sDocContext $ hsDocRenamer hds) $ parseParas parserOpts pkg (renderHsDocString $ hsDocString hds)
processDocString
:: MonadIO m
- => DynFlags
+ => ParserOpts
-> SDocContext
-> HsDoc GhcRn
-> IfM m (Doc Name)
-processDocString dflags sDocContext hds =
- rename sDocContext (hsDocRenamer hds) $ parseString dflags (renderHsDocString $ hsDocString hds)
+processDocString parserOpts sDocContext hds =
+ rename sDocContext (hsDocRenamer hds) $ parseString parserOpts (renderHsDocString $ hsDocString hds)
processModuleHeader
:: MonadIO m
- => DynFlags
+ => Maybe Language
+ -> ParserOpts
-> SDocContext
-> Maybe Package
-> SafeHaskellMode
@@ -89,13 +91,13 @@ processModuleHeader
-> EnumSet LangExt.Extension
-> Maybe (HsDoc GhcRn)
-> IfM m (HaddockModInfo Name, Maybe (MDoc Name))
-processModuleHeader dflags sDocContext pkgName safety mayLang extSet mayStr = do
+processModuleHeader mLanguage parserOpts sDocContext pkgName safety mayLang extSet mayStr = do
(hmi, doc) <-
case mayStr of
Nothing -> return failure
Just hsDoc -> do
let str = renderHsDocString $ hsDocString hsDoc
- (hmi, doc) = parseModuleHeader dflags pkgName str
+ (hmi, doc) = parseModuleHeader parserOpts pkgName str
renamer = hsDocRenamer hsDoc
!descr <- case hmi_description hmi of
Just hmi_descr -> Just <$> rename sDocContext renamer hmi_descr
@@ -110,7 +112,7 @@ processModuleHeader dflags sDocContext pkgName safety mayLang extSet mayStr = do
return
( hmi
{ hmi_safety = Just $ Outputable.renderWithContext sDocContext (Outputable.ppr safety)
- , hmi_language = language dflags
+ , hmi_language = mLanguage
, hmi_extensions = flags
}
, doc
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
=====================================
@@ -18,7 +18,7 @@ module Haddock.Interface.ParseModuleHeader (parseModuleHeader) where
import Control.Applicative (Alternative (..))
import Control.Monad (ap)
import Data.Char
-import GHC.Driver.Session
+import GHC.Parser.Lexer (ParserOpts)
import Haddock.Parser
import Haddock.Types
@@ -28,8 +28,8 @@ import Haddock.Types
-- NB. The headers must be given in the order Module, Description,
-- Copyright, License, Maintainer, Stability, Portability, except that
-- any or all may be omitted.
-parseModuleHeader :: DynFlags -> Maybe Package -> String -> (HaddockModInfo NsRdrName, MDoc NsRdrName)
-parseModuleHeader dflags pkgName str0 =
+parseModuleHeader :: ParserOpts -> Maybe Package -> String -> (HaddockModInfo NsRdrName, MDoc NsRdrName)
+parseModuleHeader parserOpts pkgName str0 =
let
kvs :: [(String, String)]
str1 :: String
@@ -53,7 +53,7 @@ parseModuleHeader dflags pkgName str0 =
portabilityOpt = getKey "Portability"
in
( HaddockModInfo
- { hmi_description = parseString dflags <$> descriptionOpt
+ { hmi_description = parseString parserOpts <$> descriptionOpt
, hmi_copyright = copyrightOpt
, hmi_license = spdxLicenceOpt <|> licenseOpt <|> licenceOpt
, hmi_maintainer = maintainerOpt
@@ -63,7 +63,7 @@ parseModuleHeader dflags pkgName str0 =
, hmi_language = Nothing -- set in LexParseRn
, hmi_extensions = [] -- also set in LexParseRn
}
- , parseParas dflags pkgName str1
+ , parseParas parserOpts pkgName str1
)
-------------------------------------------------------------------------------
=====================================
utils/haddock/haddock-api/src/Haddock/Parser.hs
=====================================
@@ -19,22 +19,20 @@ import Haddock.Types
import GHC.Data.FastString (fsLit)
import GHC.Data.StringBuffer (stringToStringBuffer)
-import GHC.Driver.Config.Parser (initParserOpts)
-import GHC.Driver.Session (DynFlags)
import GHC.Parser (parseIdentifier)
-import GHC.Parser.Lexer (ParseResult (PFailed, POk), initParserState, unP)
+import GHC.Parser.Lexer (ParseResult (PFailed, POk), ParserOpts, initParserState, unP)
import GHC.Types.Name.Occurrence (occNameString)
import GHC.Types.Name.Reader (RdrName (..))
import GHC.Types.SrcLoc (GenLocated (..), mkRealSrcLoc)
-parseParas :: DynFlags -> Maybe Package -> String -> MetaDoc mod (Wrap NsRdrName)
-parseParas dflags p = overDoc (P.overIdentifier (parseIdent dflags)) . P.parseParas p
+parseParas :: ParserOpts -> Maybe Package -> String -> MetaDoc mod (Wrap NsRdrName)
+parseParas parserOpts p = overDoc (P.overIdentifier (parseIdent parserOpts)) . P.parseParas p
-parseString :: DynFlags -> String -> DocH mod (Wrap NsRdrName)
-parseString dflags = P.overIdentifier (parseIdent dflags) . P.parseString
+parseString :: ParserOpts -> String -> DocH mod (Wrap NsRdrName)
+parseString parserOpts = P.overIdentifier (parseIdent parserOpts) . P.parseString
-parseIdent :: DynFlags -> Namespace -> String -> Maybe (Wrap NsRdrName)
-parseIdent dflags ns str0 =
+parseIdent :: ParserOpts -> Namespace -> String -> Maybe (Wrap NsRdrName)
+parseIdent parserOpts ns str0 =
case unP parseIdentifier (pstate str1) of
POk _ (L _ name)
-- Guards against things like 'Q.--', 'Q.case', etc.
@@ -47,7 +45,7 @@ parseIdent dflags ns str0 =
PFailed{} -> Nothing
where
realSrcLc = mkRealSrcLoc (fsLit "<unknown file>") 0 0
- pstate str = initParserState (initParserOpts dflags) (stringToStringBuffer str) realSrcLc
+ pstate str = initParserState parserOpts (stringToStringBuffer str) realSrcLc
(wrap, str1) = case str0 of
'(' : s@(c : _)
| c /= ','
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f599d81612fa93a9c7ccec54d6d55857e92cfc62...210cf1cd04d6761ee65d591868bbce15d94055b4
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f599d81612fa93a9c7ccec54d6d55857e92cfc62...210cf1cd04d6761ee65d591868bbce15d94055b4
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240624/016f5ace/attachment-0001.html>
More information about the ghc-commits
mailing list