From 4e12c3fa784dd906a69306f88f466248fb1ff933 Mon Sep 17 00:00:00 2001 From: Sylvain Henry Date: Wed, 5 Aug 2020 11:31:49 +0200 Subject: Fix after HomeUnit --- haddock-api/src/Haddock/Interface.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'haddock-api/src/Haddock/Interface.hs') diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index fa20b836..a702d3d6 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -51,6 +51,7 @@ import Distribution.Verbosity import Text.Printf import GHC.Unit.Module.Env (mkModuleSet, emptyModuleSet, unionModuleSet, ModuleSet) +import GHC.Unit.Types import GHC.Data.Graph.Directed import GHC.Driver.Session hiding (verbosity) import GHC hiding (verbosity) @@ -168,11 +169,11 @@ processModule verbosity modsum flags modMap instIfaceMap = do -- See https://github.com/haskell/haddock/issues/469. hsc_env <- getSession let new_rdr_env = tcg_rdr_env . fst . GHC.tm_internals_ $ tm - this_pkg = homeUnit (hsc_dflags hsc_env) + home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env) !mods = mkModuleSet [ nameModule name | gre <- globalRdrEnvElts new_rdr_env , let name = gre_name gre - , nameIsFromExternalPackage this_pkg name + , nameIsFromExternalPackage home_unit name , isTcOcc (nameOccName name) -- Types and classes only , unQualOK gre ] -- In scope unqualified -- cgit v1.2.3 From 904a3c276643d15da24303493b62e95dfb0b7726 Mon Sep 17 00:00:00 2001 From: Sylvain Henry Date: Mon, 26 Oct 2020 19:31:54 +0100 Subject: GHC.Driver.Types refactoring (#1242) --- haddock-api/src/Haddock/Backends/Hoogle.hs | 5 +++-- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 2 +- haddock-api/src/Haddock/Convert.hs | 6 ++++-- haddock-api/src/Haddock/GhcUtils.hs | 1 - haddock-api/src/Haddock/Interface.hs | 3 ++- haddock-api/src/Haddock/Interface/Create.hs | 8 ++++++-- haddock-api/src/Haddock/Interface/Json.hs | 2 +- haddock-api/src/Haddock/InterfaceFile.hs | 2 +- haddock-api/src/Haddock/Types.hs | 3 ++- 9 files changed, 20 insertions(+), 12 deletions(-) (limited to 'haddock-api/src/Haddock/Interface.hs') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index ecc4bf97..c9aad6ed 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -17,8 +17,9 @@ module Haddock.Backends.Hoogle ( ppHoogle ) where -import GHC.Types.Basic ( OverlapFlag(..), OverlapMode(..), SourceText(..) - , PromotionFlag(..), TopLevelFlag(..) ) +import GHC.Types.Basic ( OverlapFlag(..), OverlapMode(..), + PromotionFlag(..), TopLevelFlag(..) ) +import GHC.Types.SourceText import GHC.Core.InstEnv (ClsInst(..)) import Documentation.Haddock.Markup import Haddock.GhcUtils diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 1b3ed35c..1de62a2e 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -9,7 +9,7 @@ import Data.List ( isPrefixOf, isSuffixOf ) import qualified Data.ByteString as BS -import GHC.Types.Basic ( IntegralLit(..) ) +import GHC.Types.SourceText import GHC.Driver.Session import GHC.Utils.Error ( pprLocErrMsg ) import GHC.Data.FastString ( mkFastString ) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 650f8a1d..7eb9c683 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -22,8 +22,9 @@ module Haddock.Convert ( #include "HsVersions.h" import GHC.Data.Bag ( emptyBag ) -import GHC.Types.Basic ( TupleSort(..), SourceText(..), LexicalFixity(..) - , PromotionFlag(..), DefMethSpec(..) ) +import GHC.Types.Basic ( TupleSort(..), PromotionFlag(..), DefMethSpec(..) ) +import GHC.Types.SourceText (SourceText(..)) +import GHC.Types.Fixity (LexicalFixity(..)) import GHC.Core.Class import GHC.Core.Coercion.Axiom import GHC.Core.ConLike @@ -31,6 +32,7 @@ import Data.Either (lefts, rights) import GHC.Core.DataCon import GHC.Core.FamInstEnv import GHC.Hs +import GHC.Types.TyThing import GHC.Types.Name import GHC.Types.Name.Set ( emptyNameSet ) import GHC.Types.Name.Reader ( mkVarUnqual ) diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index a03587b4..8d0b382b 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -32,7 +32,6 @@ import GHC.Utils.Panic ( panic ) import GHC.Driver.Ppr (showPpr ) import GHC.Types.Name import GHC.Unit.Module -import GHC.Driver.Types import GHC import GHC.Core.Class import GHC.Driver.Session diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index a702d3d6..583cacf8 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -51,11 +51,12 @@ import Distribution.Verbosity import Text.Printf import GHC.Unit.Module.Env (mkModuleSet, emptyModuleSet, unionModuleSet, ModuleSet) +import GHC.Unit.Module.ModSummary import GHC.Unit.Types import GHC.Data.Graph.Directed import GHC.Driver.Session hiding (verbosity) import GHC hiding (verbosity) -import GHC.Driver.Types +import GHC.Driver.Env import GHC.Data.FastString (unpackFS) import GHC.Tc.Types (tcg_rdr_env) import GHC.Types.Name (nameIsFromExternalPackage, nameOccName) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 46f0cfe8..59809e89 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -40,10 +40,12 @@ import Data.Traversable import GHC.Types.Avail hiding (avail) import qualified GHC.Types.Avail as Avail import qualified GHC.Unit.Module as Module +import GHC.Unit.Module.ModDetails +import GHC.Unit.Module.ModSummary import qualified GHC.Types.SrcLoc as SrcLoc +import GHC.Types.SourceFile import GHC.Core.ConLike (ConLike(..)) import GHC -import GHC.Driver.Types import GHC.Driver.Ppr import GHC.Types.Name import GHC.Types.Name.Set @@ -52,11 +54,13 @@ import GHC.Unit.State import GHC.Types.Name.Reader import GHC.Tc.Types import GHC.Data.FastString ( unpackFS, bytesFS ) -import GHC.Types.Basic ( StringLiteral(..), SourceText(..), PromotionFlag(..) ) +import GHC.Types.Basic ( PromotionFlag(..) ) +import GHC.Types.SourceText import qualified GHC.Utils.Outputable as O import GHC.Utils.Panic import GHC.HsToCore.Docs hiding (mkMaps) import GHC.Parser.Annotation (IsUnicodeSyntax(..)) +import GHC.Unit.Module.Warnings -- | Use a 'TypecheckedModule' to produce an 'Interface'. diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs index 043a1530..df585f29 100644 --- a/haddock-api/src/Haddock/Interface/Json.hs +++ b/haddock-api/src/Haddock/Interface/Json.hs @@ -5,7 +5,7 @@ module Haddock.Interface.Json ( , renderJson ) where -import GHC.Types.Basic +import GHC.Types.Fixity import GHC.Utils.Json import GHC.Unit.Module import GHC.Types.Name diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index fffef2fa..72fcb79b 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -38,7 +38,7 @@ import GHC.Data.FastMutInt import GHC.Data.FastString import GHC hiding (NoLink) import GHC.Driver.Monad (withSession) -import GHC.Driver.Types +import GHC.Driver.Env import GHC.Types.Name.Cache import GHC.Iface.Env import GHC.Types.Name diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 89fd6658..6aad5dd1 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -36,7 +36,8 @@ import Data.Typeable (Typeable) import Data.Map (Map) import Data.Data (Data) import Documentation.Haddock.Types -import GHC.Types.Basic (Fixity(..), PromotionFlag(..)) +import GHC.Types.Basic (PromotionFlag(..)) +import GHC.Types.Fixity (Fixity(..)) import GHC import GHC.Driver.Session (Language) -- cgit v1.2.3 From 9b403b0f5f565674adce6c64b6942d36c3d6f7ec Mon Sep 17 00:00:00 2001 From: Sylvain Henry Date: Wed, 18 Nov 2020 13:54:03 +0100 Subject: DynFlags's unit fields moved to HscEnv --- haddock-api/src/Haddock.hs | 26 +++++++++++++------------- haddock-api/src/Haddock/Backends/Hoogle.hs | 19 ++++++++++--------- haddock-api/src/Haddock/Interface.hs | 5 +++-- haddock-api/src/Haddock/Interface/Create.hs | 9 +++++---- haddock-api/src/Haddock/Options.hs | 11 ++++++----- 5 files changed, 37 insertions(+), 33 deletions(-) (limited to 'haddock-api/src/Haddock/Interface.hs') diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index cb444844..3543d8e2 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -178,6 +178,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do ghc flags' $ withDir $ do dflags <- getDynFlags + unit_state <- hsc_units <$> getSession forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] noChecks @@ -195,7 +196,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do } -- Render the interfaces. - liftIO $ renderStep dflags flags sinceQual qual packages ifaces + liftIO $ renderStep dflags unit_state flags sinceQual qual packages ifaces else do when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $ @@ -205,7 +206,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) noChecks -- Render even though there are no input files (usually contents/index). - liftIO $ renderStep dflags flags sinceQual qual packages [] + liftIO $ renderStep dflags unit_state flags sinceQual qual packages [] -- | Run the GHC action using a temporary output directory withTempOutputDir :: Ghc a -> Ghc a @@ -254,9 +255,9 @@ readPackagesAndProcessModules flags files = do return (packages, ifaces, homeLinks) -renderStep :: DynFlags -> [Flag] -> SinceQual -> QualOption +renderStep :: DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO () -renderStep dflags flags sinceQual nameQual pkgs interfaces = do +renderStep dflags unit_state flags sinceQual nameQual pkgs interfaces = do updateHTMLXRefs pkgs let ifaceFiles = map snd pkgs @@ -265,12 +266,12 @@ renderStep dflags flags sinceQual nameQual pkgs interfaces = do ((_, Just path), ifile) <- pkgs iface <- ifInstalledIfaces ifile return (instMod iface, path) - render dflags flags sinceQual nameQual interfaces installedIfaces extSrcMap + render dflags unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap -- | Render the interfaces with whatever backend is specified in the flags. -render :: DynFlags -> [Flag] -> SinceQual -> QualOption -> [Interface] +render :: DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption -> [Interface] -> [InstalledInterface] -> Map Module FilePath -> IO () -render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do +render dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = do let title = fromMaybe "" (optTitle flags) @@ -283,7 +284,6 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do opt_latex_style = optLaTeXStyle flags opt_source_css = optSourceCssFile flags opt_mathjax = optMathjax flags - pkgs = unitState dflags dflags' | unicode = gopt_set dflags Opt_PrintUnicodeSyntax | otherwise = dflags @@ -297,7 +297,7 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do pkgMod = fmap ifaceMod (listToMaybe ifaces) pkgKey = fmap moduleUnit pkgMod pkgStr = fmap unitString pkgKey - pkgNameVer = modulePackageInfo dflags flags pkgMod + pkgNameVer = modulePackageInfo unit_state flags pkgMod pkgName = fmap (unpackFS . (\(PackageName n) -> n)) (fst pkgNameVer) sincePkg = case sinceQual of External -> pkgName @@ -342,7 +342,7 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do -- records the *wired in* identity base. So untranslate it -- so that we can service the request. unwire :: Module -> Module - unwire m = m { moduleUnit = unwireUnit (unitState dflags) (moduleUnit m) } + unwire m = m { moduleUnit = unwireUnit unit_state (moduleUnit m) } reexportedIfaces <- concat `fmap` (for (reexportFlags flags) $ \mod_str -> do let warn = hPutStrLn stderr . ("Warning: " ++) @@ -373,7 +373,7 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do when (Flag_GenContents `elem` flags) $ do withTiming dflags' "ppHtmlContents" (const ()) $ do _ <- {-# SCC ppHtmlContents #-} - ppHtmlContents pkgs odir title pkgStr + ppHtmlContents unit_state odir title pkgStr themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls allVisibleIfaces True prologue pretty sincePkg (makeContentsQual qual) @@ -383,7 +383,7 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do when (Flag_Html `elem` flags) $ do withTiming dflags' "ppHtml" (const ()) $ do _ <- {-# SCC ppHtml #-} - ppHtml pkgs title pkgStr visibleIfaces reexportedIfaces odir + ppHtml unit_state title pkgStr visibleIfaces reexportedIfaces odir prologue themes opt_mathjax sourceUrls' opt_wiki_urls opt_contents_url opt_index_url unicode sincePkg qual @@ -403,7 +403,7 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do pkgVer = fromMaybe (makeVersion []) mpkgVer - in ppHoogle dflags' 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 " diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 1f55db10..2ef0c61b 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -31,6 +31,7 @@ import GHC.Driver.Ppr import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Parser.Annotation (IsUnicodeSyntax(..)) +import GHC.Unit.State import Data.Char import Data.List @@ -46,8 +47,8 @@ prefix = ["-- Hoogle documentation, generated by Haddock" ,""] -ppHoogle :: DynFlags -> String -> Version -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO () -ppHoogle dflags package version synopsis prologue ifaces odir = do +ppHoogle :: DynFlags -> UnitState -> String -> Version -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO () +ppHoogle dflags unit_state package version synopsis prologue ifaces odir = do let -- Since Hoogle is line based, we want to avoid breaking long lines. dflags' = dflags{ pprCols = maxBound } filename = package ++ ".txt" @@ -56,16 +57,16 @@ ppHoogle dflags package version synopsis prologue ifaces odir = do ["@package " ++ package] ++ ["@version " ++ showVersion version | not (null (versionBranch version)) ] ++ - concat [ppModule dflags' i | i <- ifaces, OptHide `notElem` ifaceOptions i] + concat [ppModule dflags' unit_state i | i <- ifaces, OptHide `notElem` ifaceOptions i] createDirectoryIfMissing True odir writeUtf8File (odir filename) (unlines contents) -ppModule :: DynFlags -> Interface -> [String] -ppModule dflags iface = +ppModule :: DynFlags -> UnitState -> Interface -> [String] +ppModule dflags unit_state iface = "" : ppDocumentation dflags (ifaceDoc iface) ++ ["module " ++ moduleString (ifaceMod iface)] ++ concatMap (ppExport dflags) (ifaceExportItems iface) ++ - concatMap (ppInstance dflags) (ifaceInstances iface) + concatMap (ppInstance dflags unit_state) (ifaceInstances iface) --------------------------------------------------------------------- @@ -204,9 +205,9 @@ ppFam dflags decl@(FamilyDecl { fdInfo = info }) ClosedTypeFamily{} -> decl { fdInfo = OpenTypeFamily } _ -> decl -ppInstance :: DynFlags -> ClsInst -> [String] -ppInstance dflags x = - [dropComment $ outWith (showSDocForUser dflags alwaysQualify) cls] +ppInstance :: DynFlags -> UnitState -> ClsInst -> [String] +ppInstance dflags unit_state x = + [dropComment $ outWith (showSDocForUser dflags unit_state alwaysQualify) cls] where -- As per #168, we don't want safety information about the class -- in Hoogle output. The easiest way to achieve this is to set the diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index 583cacf8..be9bd09a 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -159,10 +159,11 @@ processModule verbosity modsum flags modMap instIfaceMap = do IsBoot -> return Nothing NotBoot -> do + unit_state <- hsc_units <$> getSession out verbosity verbose "Creating interface..." (interface, msgs) <- {-# SCC createIterface #-} withTimingD "createInterface" (const ()) $ do - runWriterGhc $ createInterface tm flags modMap instIfaceMap + runWriterGhc $ createInterface tm unit_state flags modMap instIfaceMap -- We need to keep track of which modules were somehow in scope so that when -- Haddock later looks for instances, it also looks in these modules too. @@ -170,7 +171,7 @@ processModule verbosity modsum flags modMap instIfaceMap = do -- See https://github.com/haskell/haddock/issues/469. hsc_env <- getSession let new_rdr_env = tcg_rdr_env . fst . GHC.tm_internals_ $ tm - home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env) + home_unit = hsc_home_unit hsc_env !mods = mkModuleSet [ nameModule name | gre <- globalRdrEnvElts new_rdr_env , let name = gre_name gre diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 8bc8d306..7ef64a94 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -47,6 +47,7 @@ import GHC.Types.SourceFile import GHC.Core.ConLike (ConLike(..)) import GHC import GHC.Driver.Ppr +import GHC.Driver.Env import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env @@ -67,11 +68,12 @@ import GHC.Unit.Module.Warnings -- To do this, we need access to already processed modules in the topological -- sort. That's what's in the 'IfaceMap'. createInterface :: TypecheckedModule + -> UnitState -> [Flag] -- Boolean flags -> IfaceMap -- Locally processed modules -> InstIfaceMap -- External, already installed interfaces -> ErrMsgGhc Interface -createInterface tm flags modMap instIfaceMap = do +createInterface tm unit_state flags modMap instIfaceMap = do let ms = pm_mod_summary . tm_parsed_module $ tm mi = moduleInfo tm @@ -84,7 +86,7 @@ createInterface tm flags modMap instIfaceMap = do !instances = modInfoInstances mi !fam_instances = md_fam_insts md !exportedNames = modInfoExportsWithSelectors mi - (pkgNameFS, _) = modulePackageInfo dflags flags (Just mdl) + (pkgNameFS, _) = modulePackageInfo unit_state flags (Just mdl) pkgName = fmap (unpackFS . (\(PackageName n) -> n)) pkgNameFS (TcGblEnv { tcg_rdr_env = gre @@ -164,8 +166,7 @@ createInterface tm flags modMap instIfaceMap = do | otherwise = exportItems !prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems' - let !aliases = - mkAliasMap (unitState dflags) $ tm_renamed_source tm + let !aliases = mkAliasMap unit_state $ tm_renamed_source tm modWarn <- liftErrMsg (moduleWarning dflags gre warnings) diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs index 5c9bf448..eda40935 100644 --- a/haddock-api/src/Haddock/Options.hs +++ b/haddock-api/src/Haddock/Options.hs @@ -45,7 +45,8 @@ import Data.Version import Control.Applicative import Distribution.Verbosity import GHC.Data.FastString -import GHC ( DynFlags, Module, moduleUnit, unitState ) +import GHC ( DynFlags, Module, moduleUnit ) +import GHC.Unit.State import Haddock.Types import Haddock.Utils import GHC.Unit.State @@ -370,16 +371,16 @@ optLast xs = Just (last xs) -- -- The @--package-name@ and @--package-version@ Haddock flags allow the user to -- specify this information manually and it is returned here if present. -modulePackageInfo :: DynFlags +modulePackageInfo :: UnitState -> [Flag] -- ^ Haddock flags are checked as they may contain -- the package name or version provided by the user -- which we prioritise -> Maybe Module -> (Maybe PackageName, Maybe Data.Version.Version) -modulePackageInfo _dflags _flags Nothing = (Nothing, Nothing) -modulePackageInfo dflags flags (Just modu) = +modulePackageInfo _unit_state _flags Nothing = (Nothing, Nothing) +modulePackageInfo unit_state flags (Just modu) = ( optPackageName flags <|> fmap unitPackageName pkgDb , optPackageVersion flags <|> fmap unitPackageVersion pkgDb ) where - pkgDb = lookupUnit (unitState dflags) (moduleUnit modu) + pkgDb = lookupUnit unit_state (moduleUnit modu) -- cgit v1.2.3 From 8a5ccf93c53a40abe42134c2282ac9b9d653224c Mon Sep 17 00:00:00 2001 From: Adam Gundry Date: Tue, 1 Dec 2020 09:17:04 +0000 Subject: Adapt to changes to GlobalRdrElt and AvailInfo Needed for ghc/ghc!4467 --- haddock-api/src/Haddock/Interface.hs | 4 ++-- haddock-api/src/Haddock/Interface/Create.hs | 12 ++---------- haddock-api/src/Haddock/Interface/LexParseRn.hs | 4 ++-- 3 files changed, 6 insertions(+), 14 deletions(-) (limited to 'haddock-api/src/Haddock/Interface.hs') diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index be9bd09a..e9cd6e0d 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -61,7 +61,7 @@ import GHC.Data.FastString (unpackFS) import GHC.Tc.Types (tcg_rdr_env) import GHC.Types.Name (nameIsFromExternalPackage, nameOccName) import GHC.Types.Name.Occurrence (isTcOcc) -import GHC.Types.Name.Reader (unQualOK, gre_name, globalRdrEnvElts) +import GHC.Types.Name.Reader (unQualOK, greMangledName, globalRdrEnvElts) import GHC.Utils.Error (withTimingD) import GHC.HsToCore.Docs @@ -174,7 +174,7 @@ processModule verbosity modsum flags modMap instIfaceMap = do home_unit = hsc_home_unit hsc_env !mods = mkModuleSet [ nameModule name | gre <- globalRdrEnvElts new_rdr_env - , let name = gre_name gre + , let name = greMangledName gre , nameIsFromExternalPackage home_unit name , isTcOcc (nameOccName name) -- Types and classes only , unQualOK gre ] -- In scope unqualified diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 7ef64a94..e3263f9d 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -293,7 +293,7 @@ mkWarningMap dflags warnings gre exps = case warnings of let ws' = [ (n, w) | (occ, w) <- ws , elt <- lookupGlobalRdrEnv gre occ - , let n = gre_name elt, n `elem` exps ] + , let n = greMangledName elt, n `elem` exps ] in M.fromList <$> traverse (bitraverse pure (parseWarning dflags gre)) ws' moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> ErrMsgM (Maybe (Doc Name)) @@ -693,16 +693,8 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames constructor_names = filter isDataConName (availSubordinates avail) --- this heavily depends on the invariants stated in Avail -availExportsDecl :: AvailInfo -> Bool -availExportsDecl (AvailTC ty_name names _) - | n : _ <- names = ty_name == n - | otherwise = False -availExportsDecl _ = True - availSubordinates :: AvailInfo -> [Name] -availSubordinates avail = - filter (/= availName avail) (availNamesWithSelectors avail) +availSubordinates = map greNameMangledName . availSubordinateGreNames availNoDocs :: AvailInfo -> [(Name, DocForDecl Name)] availNoDocs avail = diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 2c06438f..44c02875 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -120,7 +120,7 @@ rename dflags gre = rn -- There is only one name in the environment that matches so -- use it. - [a] -> pure (DocIdentifier (gre_name a)) + [a] -> pure (DocIdentifier (greMangledName a)) -- There are multiple names available. gres -> ambiguous dflags x gres @@ -182,7 +182,7 @@ ambiguous dflags x gres = do let noChildren = map availName (gresToAvailInfo gres) dflt = maximumBy (comparing (isLocalName &&& isTyConName)) noChildren msg = "Warning: " ++ x_str ++ " is ambiguous. It is defined\n" ++ - concatMap (\n -> " * " ++ defnLoc n ++ "\n") (map gre_name gres) ++ + concatMap (\n -> " * " ++ defnLoc n ++ "\n") (map greMangledName gres) ++ " You may be able to disambiguate the identifier by qualifying it or\n" ++ " by hiding some imports.\n" ++ " Defaulting to " ++ x_str ++ " defined " ++ defnLoc dflt -- cgit v1.2.3 From e7ee7957a7ac746cfa05d7218fe0c2d1fd27f569 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Fri, 20 Sep 2019 14:20:55 -0400 Subject: Support a new ghc --make node type for parallel backpack upsweep --- haddock-api/src/Haddock/Interface.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'haddock-api/src/Haddock/Interface.hs') diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index e9cd6e0d..81c79cdf 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -52,6 +52,7 @@ import Text.Printf import GHC.Unit.Module.Env (mkModuleSet, emptyModuleSet, unionModuleSet, ModuleSet) import GHC.Unit.Module.ModSummary +import GHC.Unit.Module.Graph import GHC.Unit.Types import GHC.Data.Graph.Directed import GHC.Driver.Session hiding (verbosity) @@ -137,10 +138,11 @@ createIfaces verbosity modules flags instIfaceMap = do (ifaces, _, !ms) <- foldM f ([], Map.empty, emptyModuleSet) sortedMods return (reverse ifaces, ms) where - f (ifaces, ifaceMap, !ms) modSummary = do + f state (InstantiationNode _) = pure state + f (ifaces, ifaceMap, !ms) (ModuleNode ems) = do x <- {-# SCC processModule #-} withTimingD "processModule" (const ()) $ do - processModule verbosity modSummary flags ifaceMap instIfaceMap + processModule verbosity (emsModSummary ems) flags ifaceMap instIfaceMap return $ case x of Just (iface, ms') -> ( iface:ifaces , Map.insert (ifaceMod iface) iface ifaceMap -- cgit v1.2.3 From d1e3e365cc4cdf086e1ad6c192db80d4e91563d2 Mon Sep 17 00:00:00 2001 From: Alex Biehl Date: Fri, 25 Dec 2020 13:57:56 +0100 Subject: Prepare Haddock for being a GHC Plugin --- haddock-api/src/Haddock/Interface.hs | 8 +- haddock-api/src/Haddock/Interface/Create.hs | 247 ++++++++++++++++++++++++---- 2 files changed, 222 insertions(+), 33 deletions(-) (limited to 'haddock-api/src/Haddock/Interface.hs') diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index 81c79cdf..a0ba001f 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -163,9 +163,15 @@ processModule verbosity modsum flags modMap instIfaceMap = do NotBoot -> do unit_state <- hsc_units <$> getSession out verbosity verbose "Creating interface..." + + let + mod_summary = pm_mod_summary (tm_parsed_module tm) + tcg_gbl_env = fst (tm_internals_ tm) + (interface, msgs) <- {-# SCC createIterface #-} withTimingD "createInterface" (const ()) $ do - runWriterGhc $ createInterface tm unit_state flags modMap instIfaceMap + runWriterGhc $ createInterface1 flags unit_state + mod_summary tcg_gbl_env modMap instIfaceMap -- We need to keep track of which modules were somehow in scope so that when -- Haddock later looks for instances, it also looks in these modules too. diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index e3263f9d..8bf9d7d6 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, TupleSections, BangPatterns, LambdaCase #-} +{-# LANGUAGE CPP, TupleSections, BangPatterns, LambdaCase, NamedFieldPuns #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wwarn #-} @@ -18,7 +18,7 @@ -- which creates a Haddock 'Interface' from the typechecking -- results 'TypecheckedModule' from GHC. ----------------------------------------------------------------------------- -module Haddock.Interface.Create (createInterface) where +module Haddock.Interface.Create (createInterface, createInterface1) where import Documentation.Haddock.Doc (metaDocAppend) import Haddock.Types @@ -37,6 +37,7 @@ import Data.Maybe import Control.Monad import Data.Traversable +import GHC.Tc.Utils.Monad (finalSafeMode) import GHC.Types.Avail hiding (avail) import qualified GHC.Types.Avail as Avail import qualified GHC.Unit.Module as Module @@ -64,6 +65,191 @@ import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import GHC.Unit.Module.Warnings +createInterface1 + :: [Flag] + -> UnitState + -> ModSummary + -> TcGblEnv + -> IfaceMap + -> InstIfaceMap + -> ErrMsgGhc Interface +createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do + + let + ModSummary + { + -- Cached flags from OPTIONS, INCLUDE and LANGUAGE + -- pragmas in the modules source code. Used to infer + -- safety of module. + ms_hspp_opts + , ms_location = ModLocation + { + ml_hie_file + } + } = mod_sum + + TcGblEnv + { + tcg_mod + , tcg_src + , tcg_semantic_mod + , tcg_rdr_env + , tcg_exports + , tcg_insts + , tcg_fam_insts + , tcg_warns + + -- Renamed source + , tcg_rn_imports + , tcg_rn_exports + , tcg_rn_decls + + , tcg_doc_hdr + } = tc_gbl_env + + dflags = ms_hspp_opts + + is_sig = tcg_src == HsigFile + + (pkg_name_fs, _) = + modulePackageInfo unit_state flags (Just tcg_mod) + + pkg_name :: Maybe Package + pkg_name = + let + unpack (PackageName name) = unpackFS name + in + fmap unpack pkg_name_fs + + fixities :: FixMap + fixities = case tcg_rn_decls of + Nothing -> mempty + Just dx -> mkFixMap dx + + -- Locations of all the TH splices + loc_splices :: [SrcSpan] + loc_splices = case tcg_rn_decls of + Nothing -> [] + Just HsGroup { hs_splcds } -> [ loc | L loc _ <- hs_splcds ] + + decls <- case tcg_rn_decls of + Nothing -> do + liftErrMsg $ tell [ "Warning: Renamed source is not available" ] + pure [] + Just dx -> + pure (topDecls dx) + + -- Derive final options to use for haddocking this module + doc_opts <- liftErrMsg $ mkDocOpts (haddockOptions ms_hspp_opts) flags tcg_mod + + let + -- All elements of an explicit export list, if present + export_list :: Maybe [(IE GhcRn, Avails)] + export_list + | OptIgnoreExports `elem` doc_opts = + Nothing + | Just rn_exports <- tcg_rn_exports = + Just [ (ie, avail) | (L _ ie, avail) <- rn_exports ] + | otherwise = + Nothing + + -- All the exported Names of this module. + exported_names :: [Name] + exported_names = + concatMap availNamesWithSelectors tcg_exports + + -- Module imports of the form `import X`. Note that there is + -- a) no qualification and + -- b) no import list + imported_modules :: Map ModuleName [ModuleName] + imported_modules + | Just{} <- export_list = + unrestrictedModuleImports (map unLoc tcg_rn_imports) + | otherwise = + M.empty + + -- TyThings that have instances defined in this module + local_instances :: [Name] + local_instances = + [ name + | name <- map getName tcg_insts ++ map getName tcg_fam_insts + , nameIsLocalOrFrom tcg_semantic_mod name + ] + + -- Infer module safety + safety <- liftIO (finalSafeMode ms_hspp_opts tc_gbl_env) + + -- Process the top-level module header documentation. + (!info, header_doc) <- liftErrMsg $ processModuleHeader dflags pkg_name + tcg_rdr_env safety tcg_doc_hdr + + -- Warnings on declarations in this module + decl_warnings <- liftErrMsg (mkWarningMap dflags tcg_warns tcg_rdr_env exported_names) + + -- Warning on the module header + mod_warning <- liftErrMsg (moduleWarning dflags tcg_rdr_env tcg_warns) + + let + -- Warnings in this module and transitive warnings from dependend modules + warnings :: Map Name (Doc Name) + warnings = M.unions (decl_warnings : map ifaceWarningMap (M.elems ifaces)) + + maps@(!docs, !arg_docs, !decl_map, _) <- + liftErrMsg (mkMaps dflags pkg_name tcg_rdr_env local_instances decls) + + export_items <- mkExportItems is_sig ifaces pkg_name tcg_mod tcg_semantic_mod + warnings tcg_rdr_env exported_names (map fst decls) maps fixities + imported_modules loc_splices export_list tcg_exports inst_ifaces dflags + + let + visible_names :: [Name] + visible_names = mkVisibleNames maps export_items doc_opts + + -- Measure haddock documentation coverage. + pruned_export_items :: [ExportItem GhcRn] + pruned_export_items = pruneExportItems export_items + + !haddockable = 1 + length export_items -- module + exports + !haddocked = (if isJust tcg_doc_hdr then 1 else 0) + length pruned_export_items + + coverage :: (Int, Int) + !coverage = (haddockable, haddocked) + + aliases :: Map Module ModuleName + aliases = mkAliasMap unit_state tcg_rn_imports + + return $! Interface + { + ifaceMod = tcg_mod + , ifaceIsSig = is_sig + , ifaceOrigFilename = msHsFilePath mod_sum + , ifaceHieFile = Just ml_hie_file + , ifaceInfo = info + , ifaceDoc = Documentation header_doc mod_warning + , ifaceRnDoc = Documentation Nothing Nothing + , ifaceOptions = doc_opts + , ifaceDocMap = docs + , ifaceArgMap = arg_docs + , ifaceRnDocMap = M.empty + , ifaceRnArgMap = M.empty + , ifaceExportItems = if OptPrune `elem` doc_opts then + pruned_export_items else export_items + , ifaceRnExportItems = [] + , ifaceExports = exported_names + , ifaceVisibleExports = visible_names + , ifaceDeclMap = decl_map + , ifaceFixMap = fixities + , ifaceModuleAliases = aliases + , ifaceInstances = tcg_insts + , ifaceFamInstances = tcg_fam_insts + , ifaceOrphanInstances = [] -- Filled in attachInstances + , ifaceRnOrphanInstances = [] -- Filled in attachInstances + , ifaceHaddockCoverage = coverage + , ifaceWarningMap = warnings + , ifaceDynFlags = dflags + } + + -- | Use a 'TypecheckedModule' to produce an 'Interface'. -- To do this, we need access to already processed modules in the topological -- sort. That's what's in the 'IfaceMap'. @@ -166,7 +352,7 @@ createInterface tm unit_state flags modMap instIfaceMap = do | otherwise = exportItems !prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems' - let !aliases = mkAliasMap unit_state $ tm_renamed_source tm + let !aliases = mkAliasMap unit_state imports modWarn <- liftErrMsg (moduleWarning dflags gre warnings) @@ -204,35 +390,32 @@ createInterface tm unit_state flags modMap instIfaceMap = do -- create a mapping from the module identity of M, to an alias N -- (if there are multiple aliases, we pick the last one.) This -- will go in 'ifaceModuleAliases'. -mkAliasMap :: UnitState -> Maybe RenamedSource -> M.Map Module ModuleName -mkAliasMap state mRenamedSource = - case mRenamedSource of - Nothing -> M.empty - Just (_,impDecls,_,_) -> - M.fromList $ - mapMaybe (\(SrcLoc.L _ impDecl) -> do - SrcLoc.L _ alias <- ideclAs impDecl - return $ - (lookupModuleDyn state - -- TODO: This is supremely dodgy, because in general the - -- UnitId isn't going to look anything like the package - -- qualifier (even with old versions of GHC, the - -- IPID would be p-0.1, but a package qualifier never - -- has a version number it. (Is it possible that in - -- Haddock-land, the UnitIds never have version numbers? - -- I, ezyang, have not quite understand Haddock's package - -- identifier model.) - -- - -- Additionally, this is simulating some logic GHC already - -- has for deciding how to qualify names when it outputs - -- them to the user. We should reuse that information; - -- or at least reuse the renamed imports, which know what - -- they import! - (fmap Module.fsToUnit $ - fmap sl_fs $ ideclPkgQual impDecl) - (case ideclName impDecl of SrcLoc.L _ name -> name), - alias)) - impDecls +mkAliasMap :: UnitState -> [LImportDecl GhcRn] -> M.Map Module ModuleName +mkAliasMap state impDecls = + M.fromList $ + mapMaybe (\(SrcLoc.L _ impDecl) -> do + SrcLoc.L _ alias <- ideclAs impDecl + return $ + (lookupModuleDyn state + -- TODO: This is supremely dodgy, because in general the + -- UnitId isn't going to look anything like the package + -- qualifier (even with old versions of GHC, the + -- IPID would be p-0.1, but a package qualifier never + -- has a version number it. (Is it possible that in + -- Haddock-land, the UnitIds never have version numbers? + -- I, ezyang, have not quite understand Haddock's package + -- identifier model.) + -- + -- Additionally, this is simulating some logic GHC already + -- has for deciding how to qualify names when it outputs + -- them to the user. We should reuse that information; + -- or at least reuse the renamed imports, which know what + -- they import! + (fmap Module.fsToUnit $ + fmap sl_fs $ ideclPkgQual impDecl) + (case ideclName impDecl of SrcLoc.L _ name -> name), + alias)) + impDecls -- We want to know which modules are imported without any qualification. This -- way we can display module reexports more compactly. This mapping also looks -- cgit v1.2.3 From 409cc2c7d7c521f171ea3f7a533721d2101fbf8b Mon Sep 17 00:00:00 2001 From: Alex Biehl Date: Sun, 27 Dec 2020 12:48:43 +0100 Subject: Make Haddock a GHC Plugin --- haddock-api/src/Haddock/Interface.hs | 308 ++++++++++++++++++++++++----------- 1 file changed, 212 insertions(+), 96 deletions(-) (limited to 'haddock-api/src/Haddock/Interface.hs') diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index a0ba001f..87ac4861 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, OverloadedStrings, BangPatterns #-} +{-# LANGUAGE CPP, OverloadedStrings, BangPatterns, NamedFieldPuns #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface @@ -29,7 +29,8 @@ -- using this environment. ----------------------------------------------------------------------------- module Haddock.Interface ( - processModules + plugin + , processModules ) where @@ -43,7 +44,7 @@ import Haddock.Types import Haddock.Utils import Control.Monad -import Control.Exception (evaluate) +import Data.IORef import Data.List import qualified Data.Map as Map import qualified Data.Set as Set @@ -58,13 +59,17 @@ import GHC.Data.Graph.Directed import GHC.Driver.Session hiding (verbosity) import GHC hiding (verbosity) import GHC.Driver.Env +import GHC.Driver.Monad (Session(..), modifySession, reflectGhc) import GHC.Data.FastString (unpackFS) -import GHC.Tc.Types (tcg_rdr_env) +import GHC.Tc.Types (TcGblEnv(..)) +import GHC.Tc.Utils.Monad (getTopEnv) import GHC.Types.Name (nameIsFromExternalPackage, nameOccName) import GHC.Types.Name.Occurrence (isTcOcc) import GHC.Types.Name.Reader (unQualOK, greMangledName, globalRdrEnvElts) import GHC.Utils.Error (withTimingD) import GHC.HsToCore.Docs +import GHC.Plugins (Outputable, StaticPlugin(..), Plugin(..), PluginWithArgs(..), + defaultPlugin, keepRenamedSource) #if defined(mingw32_HOST_OS) import System.IO @@ -90,8 +95,14 @@ processModules verbosity modules flags extIfaces = do #endif out verbosity verbose "Creating interfaces..." - let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces - , iface <- ifInstalledIfaces ext ] + let + instIfaceMap :: InstIfaceMap + instIfaceMap = Map.fromList + [ (instMod iface, iface) + | ext <- extIfaces + , iface <- ifInstalledIfaces ext + ] + (interfaces, ms) <- createIfaces verbosity modules flags instIfaceMap let exportedNames = @@ -127,100 +138,206 @@ processModules verbosity modules flags extIfaces = do createIfaces :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc ([Interface], ModuleSet) createIfaces verbosity modules flags instIfaceMap = do - -- Ask GHC to tell us what the module graph is + (haddockPlugin, getIfaces, getModules) <- liftIO $ plugin + verbosity flags instIfaceMap + + let + installHaddockPlugin :: HscEnv -> HscEnv + installHaddockPlugin hsc_env = hsc_env + { + hsc_dflags = + gopt_set (hsc_dflags hsc_env) Opt_PluginTrustworthy + , hsc_static_plugins = + haddockPlugin : hsc_static_plugins hsc_env + } + + -- Note that we would rather use withTempSession but as long as we + -- have the separate attachInstances step we need to keep the session + -- alive to be able to find all the instances. + modifySession installHaddockPlugin + targets <- mapM (\filePath -> guessTarget filePath Nothing) modules setTargets targets - modGraph <- depanal [] False - -- Visit modules in that order - let sortedMods = flattenSCCs $ topSortModuleGraph False modGraph Nothing - out verbosity normal "Haddock coverage:" - (ifaces, _, !ms) <- foldM f ([], Map.empty, emptyModuleSet) sortedMods - return (reverse ifaces, ms) - where - f state (InstantiationNode _) = pure state - f (ifaces, ifaceMap, !ms) (ModuleNode ems) = do - x <- {-# SCC processModule #-} - withTimingD "processModule" (const ()) $ do - processModule verbosity (emsModSummary ems) flags ifaceMap instIfaceMap - return $ case x of - Just (iface, ms') -> ( iface:ifaces - , Map.insert (ifaceMod iface) iface ifaceMap - , unionModuleSet ms ms' ) - Nothing -> ( ifaces - , ifaceMap - , ms ) -- Boot modules don't generate ifaces. - - -processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe (Interface, ModuleSet)) -processModule verbosity modsum flags modMap instIfaceMap = do - out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..." - tm <- {-# SCC "parse/typecheck/load" #-} loadModule =<< typecheckModule =<< parseModule modsum - - case isBootSummary modsum of - IsBoot -> - return Nothing - NotBoot -> do - unit_state <- hsc_units <$> getSession - out verbosity verbose "Creating interface..." + loadOk <- withTimingD "load" (const ()) $ + {-# SCC load #-} GHC.load LoadAllTargets + + case loadOk of + Failed -> + throwE "Cannot typecheck modules" + Succeeded -> do + modGraph <- GHC.getModuleGraph + ifaceMap <- liftIO getIfaces + moduleSet <- liftIO getModules let - mod_summary = pm_mod_summary (tm_parsed_module tm) - tcg_gbl_env = fst (tm_internals_ tm) - - (interface, msgs) <- {-# SCC createIterface #-} - withTimingD "createInterface" (const ()) $ do - runWriterGhc $ createInterface1 flags unit_state - mod_summary tcg_gbl_env modMap instIfaceMap - - -- We need to keep track of which modules were somehow in scope so that when - -- Haddock later looks for instances, it also looks in these modules too. - -- - -- See https://github.com/haskell/haddock/issues/469. - hsc_env <- getSession - let new_rdr_env = tcg_rdr_env . fst . GHC.tm_internals_ $ tm - home_unit = hsc_home_unit hsc_env - !mods = mkModuleSet [ nameModule name - | gre <- globalRdrEnvElts new_rdr_env - , let name = greMangledName gre - , nameIsFromExternalPackage home_unit name - , isTcOcc (nameOccName name) -- Types and classes only - , unQualOK gre ] -- In scope unqualified - - liftIO $ mapM_ putStrLn (nub msgs) - dflags <- getDynFlags - let (haddockable, haddocked) = ifaceHaddockCoverage interface - percentage = round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) :: Int - modString = moduleString (ifaceMod interface) - coverageMsg = printf " %3d%% (%3d /%3d) in '%s'" percentage haddocked haddockable modString - header = case ifaceDoc interface of - Documentation Nothing _ -> False - _ -> True - undocumentedExports = [ formatName s n | ExportDecl { expItemDecl = L s n - , expItemMbDoc = (Documentation Nothing _, _) - } <- ifaceExportItems interface ] - where - formatName :: SrcSpan -> HsDecl GhcRn -> String - formatName loc n = p (getMainDeclBinder n) ++ case loc of - RealSrcSpan rss _ -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++ show (srcSpanStartLine rss) ++ ")" - _ -> "" - - p [] = "" - p (x:_) = let n = pretty dflags x - ms = modString ++ "." - in if ms `isPrefixOf` n - then drop (length ms) n - else n - - when (OptHide `notElem` ifaceOptions interface) $ do - out verbosity normal coverageMsg - when (Flag_NoPrintMissingDocs `notElem` flags - && not (null undocumentedExports && header)) $ do - out verbosity normal " Missing documentation for:" - unless header $ out verbosity normal " Module header" - mapM_ (out verbosity normal . (" " ++)) undocumentedExports - interface' <- liftIO $ evaluate interface - return (Just (interface', mods)) + ifaces :: [Interface] + ifaces = + [ Map.findWithDefault + (error "haddock:iface") + (ms_mod (emsModSummary ems)) + ifaceMap + | ModuleNode ems <- flattenSCCs $ topSortModuleGraph True modGraph Nothing + ] + + return (ifaces, moduleSet) + + +-- | A `Plugin` that hooks into GHC's compilation pipeline to generate Haddock +-- interfaces. Due to the plugin nature we benefit from GHC's capabilities to +-- parallelize the compilation process. +plugin + :: MonadIO m + => Verbosity + -> [Flag] + -> InstIfaceMap + -> m + ( + StaticPlugin -- the plugin to install with GHC + , m IfaceMap -- get the processed interfaces + , m ModuleSet -- get the loaded modules + ) +plugin verbosity flags instIfaceMap = liftIO $ do + ifaceMapRef <- newIORef Map.empty + moduleSetRef <- newIORef emptyModuleSet + + let + processTypeCheckedResult :: ModSummary -> TcGblEnv -> Ghc () + processTypeCheckedResult mod_summary tc_gbl_env + -- Don't do anything for hs-boot modules + | IsBoot <- isBootSummary mod_summary = + pure () + | otherwise = do + ifaces <- liftIO $ readIORef ifaceMapRef + (iface, modules) <- withTimingD "processModule" (const ()) $ + processModule1 verbosity flags ifaces instIfaceMap mod_summary tc_gbl_env + + liftIO $ do + atomicModifyIORef' ifaceMapRef $ \xs -> + (Map.insert (ms_mod mod_summary) iface xs, ()) + + atomicModifyIORef' moduleSetRef $ \xs -> + (modules `unionModuleSet` xs, ()) + + staticPlugin :: StaticPlugin + staticPlugin = StaticPlugin + { + spPlugin = PluginWithArgs + { + paPlugin = defaultPlugin + { + renamedResultAction = keepRenamedSource + , typeCheckResultAction = \_ mod_summary tc_gbl_env -> do + session <- getTopEnv >>= liftIO . newIORef + liftIO $ reflectGhc + (processTypeCheckedResult mod_summary tc_gbl_env) + (Session session) + pure tc_gbl_env + + } + , paArguments = [] + } + } + + pure + ( staticPlugin + , liftIO (readIORef ifaceMapRef) + , liftIO (readIORef moduleSetRef) + ) + + + +processModule1 + :: Verbosity + -> [Flag] + -> IfaceMap + -> InstIfaceMap + -> ModSummary + -> TcGblEnv + -> Ghc (Interface, ModuleSet) +processModule1 verbosity flags ifaces inst_ifaces mod_summary tc_gbl_env = do + out verbosity verbose "Creating interface..." + + let + TcGblEnv { tcg_rdr_env } = tc_gbl_env + + unit_state <- hsc_units <$> getSession + + (!interface, messages) <- {-# SCC createInterface #-} + withTimingD "createInterface" (const ()) $ + runWriterGhc $ createInterface1 flags unit_state + mod_summary tc_gbl_env ifaces inst_ifaces + + -- We need to keep track of which modules were somehow in scope so that when + -- Haddock later looks for instances, it also looks in these modules too. + -- + -- See https://github.com/haskell/haddock/issues/469. + hsc_env <- getSession + let + mods :: ModuleSet + !mods = mkModuleSet + [ nameModule name + | gre <- globalRdrEnvElts tcg_rdr_env + , let name = greMangledName gre + , nameIsFromExternalPackage (hsc_home_unit hsc_env) name + , isTcOcc (nameOccName name) -- Types and classes only + , unQualOK gre -- In scope unqualified + ] + + liftIO $ mapM_ putStrLn (nub messages) + dflags <- getDynFlags + + let + (haddockable, haddocked) = + ifaceHaddockCoverage interface + + percentage :: Int + percentage = + round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) + + modString :: String + modString = moduleString (ifaceMod interface) + + coverageMsg :: String + coverageMsg = + printf " %3d%% (%3d /%3d) in '%s'" percentage haddocked haddockable modString + + header :: Bool + header = case ifaceDoc interface of + Documentation Nothing _ -> False + _ -> True + + undocumentedExports :: [String] + undocumentedExports = + [ formatName s n + | ExportDecl { expItemDecl = L s n + , expItemMbDoc = (Documentation Nothing _, _) + } <- ifaceExportItems interface + ] + where + formatName :: SrcSpan -> HsDecl GhcRn -> String + formatName loc n = p (getMainDeclBinder n) ++ case loc of + RealSrcSpan rss _ -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++ + show (srcSpanStartLine rss) ++ ")" + _ -> "" + + p :: Outputable a => [a] -> String + p [] = "" + p (x:_) = let n = pretty dflags x + ms = modString ++ "." + in if ms `isPrefixOf` n + then drop (length ms) n + else n + + when (OptHide `notElem` ifaceOptions interface) $ do + out verbosity normal coverageMsg + when (Flag_NoPrintMissingDocs `notElem` flags + && not (null undocumentedExports && header)) $ do + out verbosity normal " Missing documentation for:" + unless header $ out verbosity normal " Module header" + mapM_ (out verbosity normal . (" " ++)) undocumentedExports + + pure (interface, mods) -------------------------------------------------------------------------------- @@ -249,4 +366,3 @@ buildHomeLinks ifaces = foldl upd Map.empty (reverse ifaces) mdl = ifaceMod iface keep_old env n = Map.insertWith (\_ old -> old) n mdl env keep_new env n = Map.insert n mdl env - -- cgit v1.2.3 From 703e5f0263dfc7c3173cf8ae1348c14902b9bcd7 Mon Sep 17 00:00:00 2001 From: Alex Biehl Date: Thu, 7 Jan 2021 23:40:56 +0100 Subject: Abstract Monad for interface creation I found that when running as a plugin the lookupName function (which runs in Ghc monad) does not work correctly from the typeCheckResultAction hook. Instead, we abstracted the monad used when creating interfaces, so that access to GHC session specific parts is explicit and so that the TcM can provide their (correct) implementation of lookupName. --- haddock-api/haddock-api.cabal | 1 + haddock-api/src/Haddock/Backends/LaTeX.hs | 2 +- haddock-api/src/Haddock/GhcUtils.hs | 9 - haddock-api/src/Haddock/Interface.hs | 32 ++- haddock-api/src/Haddock/Interface/Create.hs | 335 ++++++++++-------------- haddock-api/src/Haddock/Interface/LexParseRn.hs | 3 +- haddock-api/src/Haddock/Interface/Rename.hs | 1 - haddock-api/src/Haddock/InterfaceFile.hs | 2 +- haddock-api/src/Haddock/Options.hs | 3 +- haddock-api/src/Haddock/Types.hs | 67 ++--- 10 files changed, 180 insertions(+), 275 deletions(-) (limited to 'haddock-api/src/Haddock/Interface.hs') diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index cea9c4bd..87761ff8 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -61,6 +61,7 @@ library , exceptions , filepath , ghc-boot + , mtl , transformers hs-source-dirs: src diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 2ba0bf52..d95c86b2 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -39,7 +39,7 @@ import System.FilePath import Data.Char import Control.Monad import Data.Maybe -import Data.List +import Data.List (sort) import Prelude hiding ((<>)) import Haddock.Doc (combineDocumentation) diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 452cb6f4..0a0211c9 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -34,7 +34,6 @@ import GHC.Driver.Ppr (showPpr ) import GHC.Types.Name import GHC.Unit.Module import GHC -import GHC.Core.Class import GHC.Driver.Session import GHC.Types.SrcLoc ( advanceSrcLoc ) import GHC.Types.Var ( Specificity, VarBndr(..), TyVarBinder @@ -403,14 +402,6 @@ modifySessionDynFlags f = do return () --- Extract the minimal complete definition of a Name, if one exists -minimalDef :: GhcMonad m => Name -> m (Maybe ClassMinimalDef) -minimalDef n = do - mty <- lookupGlobalName n - case mty of - Just (ATyCon (tyConClass_maybe -> Just c)) -> return . Just $ classMinimalDef c - _ -> return Nothing - ------------------------------------------------------------------------------- -- * DynFlags ------------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index 87ac4861..c557968f 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -61,8 +61,9 @@ import GHC hiding (verbosity) import GHC.Driver.Env import GHC.Driver.Monad (Session(..), modifySession, reflectGhc) import GHC.Data.FastString (unpackFS) -import GHC.Tc.Types (TcGblEnv(..)) -import GHC.Tc.Utils.Monad (getTopEnv) +import GHC.Tc.Types (TcM, TcGblEnv(..)) +import GHC.Tc.Utils.Monad (getTopEnv, setGblEnv) +import GHC.Tc.Utils.Env (tcLookupGlobal) import GHC.Types.Name (nameIsFromExternalPackage, nameOccName) import GHC.Types.Name.Occurrence (isTcOcc) import GHC.Types.Name.Reader (unQualOK, greMangledName, globalRdrEnvElts) @@ -202,15 +203,16 @@ plugin verbosity flags instIfaceMap = liftIO $ do moduleSetRef <- newIORef emptyModuleSet let - processTypeCheckedResult :: ModSummary -> TcGblEnv -> Ghc () + processTypeCheckedResult :: ModSummary -> TcGblEnv -> TcM () processTypeCheckedResult mod_summary tc_gbl_env -- Don't do anything for hs-boot modules | IsBoot <- isBootSummary mod_summary = pure () | otherwise = do + hsc_env <- getTopEnv ifaces <- liftIO $ readIORef ifaceMapRef (iface, modules) <- withTimingD "processModule" (const ()) $ - processModule1 verbosity flags ifaces instIfaceMap mod_summary tc_gbl_env + processModule1 verbosity flags ifaces instIfaceMap hsc_env mod_summary tc_gbl_env liftIO $ do atomicModifyIORef' ifaceMapRef $ \xs -> @@ -227,11 +229,8 @@ plugin verbosity flags instIfaceMap = liftIO $ do paPlugin = defaultPlugin { renamedResultAction = keepRenamedSource - , typeCheckResultAction = \_ mod_summary tc_gbl_env -> do - session <- getTopEnv >>= liftIO . newIORef - liftIO $ reflectGhc - (processTypeCheckedResult mod_summary tc_gbl_env) - (Session session) + , typeCheckResultAction = \_ mod_summary tc_gbl_env -> setGblEnv tc_gbl_env $ do + processTypeCheckedResult mod_summary tc_gbl_env pure tc_gbl_env } @@ -246,33 +245,32 @@ plugin verbosity flags instIfaceMap = liftIO $ do ) - processModule1 :: Verbosity -> [Flag] -> IfaceMap -> InstIfaceMap + -> HscEnv -> ModSummary -> TcGblEnv - -> Ghc (Interface, ModuleSet) -processModule1 verbosity flags ifaces inst_ifaces mod_summary tc_gbl_env = do + -> TcM (Interface, ModuleSet) +processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env = do out verbosity verbose "Creating interface..." let TcGblEnv { tcg_rdr_env } = tc_gbl_env - unit_state <- hsc_units <$> getSession + unit_state = hsc_units hsc_env (!interface, messages) <- {-# SCC createInterface #-} - withTimingD "createInterface" (const ()) $ - runWriterGhc $ createInterface1 flags unit_state - mod_summary tc_gbl_env ifaces inst_ifaces + withTimingD "createInterface" (const ()) $ runIfM (fmap Just . tcLookupGlobal) $ + createInterface1 flags unit_state mod_summary tc_gbl_env + ifaces inst_ifaces -- We need to keep track of which modules were somehow in scope so that when -- Haddock later looks for instances, it also looks in these modules too. -- -- See https://github.com/haskell/haddock/issues/469. - hsc_env <- getSession let mods :: ModuleSet !mods = mkModuleSet diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 8bf9d7d6..30fb8b7e 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -1,6 +1,8 @@ -{-# LANGUAGE CPP, TupleSections, BangPatterns, LambdaCase, NamedFieldPuns #-} +{-# LANGUAGE StandaloneDeriving, FlexibleInstances, MultiParamTypeClasses, CPP, TupleSections, BangPatterns, LambdaCase, NamedFieldPuns, ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -Wwarn #-} ----------------------------------------------------------------------------- -- | @@ -18,43 +20,42 @@ -- which creates a Haddock 'Interface' from the typechecking -- results 'TypecheckedModule' from GHC. ----------------------------------------------------------------------------- -module Haddock.Interface.Create (createInterface, createInterface1) where +module Haddock.Interface.Create (IfM, runIfM, createInterface1) where import Documentation.Haddock.Doc (metaDocAppend) -import Haddock.Types +import Haddock.Types hiding (liftErrMsg) import Haddock.Options import Haddock.GhcUtils import Haddock.Utils import Haddock.Convert import Haddock.Interface.LexParseRn -import Data.Bifunctor +import Control.Monad.Reader +import Control.Monad.Writer.Strict hiding (tell) import Data.Bitraversable import qualified Data.Map as M import Data.Map (Map) import Data.List import Data.Maybe -import Control.Monad import Data.Traversable import GHC.Tc.Utils.Monad (finalSafeMode) import GHC.Types.Avail hiding (avail) import qualified GHC.Types.Avail as Avail import qualified GHC.Unit.Module as Module -import GHC.Unit.Module.ModDetails import GHC.Unit.Module.ModSummary import qualified GHC.Types.SrcLoc as SrcLoc import GHC.Types.SourceFile +import GHC.Core.Class import GHC.Core.ConLike (ConLike(..)) -import GHC +import GHC hiding (lookupName) import GHC.Driver.Ppr -import GHC.Driver.Env import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env import GHC.Unit.State import GHC.Types.Name.Reader -import GHC.Tc.Types +import GHC.Tc.Types hiding (IfM) import GHC.Data.FastString ( unpackFS, bytesFS ) import GHC.Types.Basic ( PromotionFlag(..) ) import GHC.Types.SourceText @@ -65,14 +66,68 @@ import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import GHC.Unit.Module.Warnings +newtype IfEnv m = IfEnv + { + -- | Lookup names in the enviroment. + ife_lookup_name :: Name -> m (Maybe TyThing) + } + + +-- | A monad in which we create Haddock interfaces. Not to be confused with +-- `GHC.Tc.Types.IfM` which is used to write GHC interfaces. +-- +-- In the past `createInterface` was running in the `Ghc` monad but proved hard +-- to sustain as soon as we moved over for Haddock to be a plugin. Also abstracting +-- over the Ghc specific clarifies where side effects happen. +newtype IfM m a = IfM { unIfM :: ReaderT (IfEnv m) (WriterT [ErrMsg] m) a } + + +deriving newtype instance Functor m => Functor (IfM m) +deriving newtype instance Applicative m => Applicative (IfM m) +deriving newtype instance Monad m => Monad (IfM m) +deriving newtype instance MonadIO m => MonadIO (IfM m) +deriving newtype instance Monad m => MonadReader (IfEnv m) (IfM m) +deriving newtype instance Monad m => MonadWriter [ErrMsg] (IfM m) + + +-- | Run an `IfM` action. +runIfM + -- | Lookup a global name in the current session. Used in cases + -- where declarations don't + :: (Name -> m (Maybe TyThing)) + -- | The action to run. + -> IfM m a + -- | Result and accumulated error/warning messages. + -> m (a, [ErrMsg]) +runIfM lookup_name action = do + let + if_env = IfEnv + { + ife_lookup_name = lookup_name + } + runWriterT (runReaderT (unIfM action) if_env) + + +liftErrMsg :: Monad m => ErrMsgM a -> IfM m a +liftErrMsg action = do + writer (runWriter action) + + +lookupName :: Monad m => Name -> IfM m (Maybe TyThing) +lookupName name = IfM $ do + lookup_name <- asks ife_lookup_name + lift $ lift (lookup_name name) + + createInterface1 - :: [Flag] + :: MonadIO m + => [Flag] -> UnitState -> ModSummary -> TcGblEnv -> IfaceMap -> InstIfaceMap - -> ErrMsgGhc Interface + -> IfM m Interface createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do let @@ -134,7 +189,7 @@ createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do decls <- case tcg_rn_decls of Nothing -> do - liftErrMsg $ tell [ "Warning: Renamed source is not available" ] + tell [ "Warning: Renamed source is not available" ] pure [] Just dx -> pure (topDecls dx) @@ -250,142 +305,6 @@ createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do } --- | Use a 'TypecheckedModule' to produce an 'Interface'. --- To do this, we need access to already processed modules in the topological --- sort. That's what's in the 'IfaceMap'. -createInterface :: TypecheckedModule - -> UnitState - -> [Flag] -- Boolean flags - -> IfaceMap -- Locally processed modules - -> InstIfaceMap -- External, already installed interfaces - -> ErrMsgGhc Interface -createInterface tm unit_state flags modMap instIfaceMap = do - - let ms = pm_mod_summary . tm_parsed_module $ tm - mi = moduleInfo tm - L _ hsm = parsedSource tm - !safety = modInfoSafe mi - mdl = ms_mod ms - sem_mdl = tcg_semantic_mod (fst (tm_internals_ tm)) - is_sig = ms_hsc_src ms == HsigFile - dflags = ms_hspp_opts ms - !instances = modInfoInstances mi - !fam_instances = md_fam_insts md - !exportedNames = modInfoExportsWithSelectors mi - (pkgNameFS, _) = modulePackageInfo unit_state flags (Just mdl) - pkgName = fmap (unpackFS . (\(PackageName n) -> n)) pkgNameFS - - (TcGblEnv { tcg_rdr_env = gre - , tcg_warns = warnings - , tcg_exports = all_exports - }, md) = tm_internals_ tm - - -- The 'pkgName' is necessary to decide what package to mention in "@since" - -- annotations. Not having it is not fatal though. - -- - -- Cabal can be trusted to pass the right flags, so this warning should be - -- mostly encountered when running Haddock outside of Cabal. - when (isNothing pkgName) $ - liftErrMsg $ tell [ "Warning: Package name is not available." ] - - -- The renamed source should always be available to us, but it's best - -- to be on the safe side. - (group_, imports, mayExports, mayDocHeader) <- - case renamedSource tm of - Nothing -> do - liftErrMsg $ tell [ "Warning: Renamed source is not available." ] - return (emptyRnGroup, [], Nothing, Nothing) - Just x -> return x - - opts <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl - - -- Process the top-level module header documentation. - (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags pkgName gre safety mayDocHeader - - let declsWithDocs = topDecls group_ - - exports0 = fmap (map (first unLoc)) mayExports - exports - | OptIgnoreExports `elem` opts = Nothing - | otherwise = exports0 - - unrestrictedImportedMods - -- module re-exports are only possible with - -- explicit export list - | Just{} <- exports - = unrestrictedModuleImports (map unLoc imports) - | otherwise = M.empty - - fixMap = mkFixMap group_ - (decls, _) = unzip declsWithDocs - localInsts = filter (nameIsLocalOrFrom sem_mdl) - $ map getName instances - ++ map getName fam_instances - -- Locations of all TH splices - splices = [ l | L l (SpliceD _ _) <- hsmodDecls hsm ] - - warningMap <- liftErrMsg (mkWarningMap dflags warnings gre exportedNames) - - maps@(!docMap, !argMap, !declMap, _) <- - liftErrMsg (mkMaps dflags pkgName gre localInsts declsWithDocs) - - let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap)) - - -- The MAIN functionality: compute the export items which will - -- each be the actual documentation of this module. - exportItems <- mkExportItems is_sig modMap pkgName mdl sem_mdl allWarnings gre - exportedNames decls maps fixMap unrestrictedImportedMods - splices exports all_exports instIfaceMap dflags - - let !visibleNames = mkVisibleNames maps exportItems opts - - -- Measure haddock documentation coverage. - let prunedExportItems0 = pruneExportItems exportItems - !haddockable = 1 + length exportItems -- module + exports - !haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0 - !coverage = (haddockable, haddocked) - - -- Prune the export list to just those declarations that have - -- documentation, if the 'prune' option is on. - let prunedExportItems' - | OptPrune `elem` opts = prunedExportItems0 - | otherwise = exportItems - !prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems' - - let !aliases = mkAliasMap unit_state imports - - modWarn <- liftErrMsg (moduleWarning dflags gre warnings) - - return $! Interface { - ifaceMod = mdl - , ifaceIsSig = is_sig - , ifaceOrigFilename = msHsFilePath ms - , ifaceInfo = info - , ifaceDoc = Documentation mbDoc modWarn - , ifaceRnDoc = Documentation Nothing Nothing - , ifaceOptions = opts - , ifaceDocMap = docMap - , ifaceArgMap = argMap - , ifaceRnDocMap = M.empty - , ifaceRnArgMap = M.empty - , ifaceExportItems = prunedExportItems - , ifaceRnExportItems = [] - , ifaceExports = exportedNames - , ifaceVisibleExports = visibleNames - , ifaceDeclMap = declMap - , ifaceFixMap = fixMap - , ifaceModuleAliases = aliases - , ifaceInstances = instances - , ifaceFamInstances = fam_instances - , ifaceOrphanInstances = [] -- Filled in `attachInstances` - , ifaceRnOrphanInstances = [] -- Filled in `renameInterface` - , ifaceHaddockCoverage = coverage - , ifaceWarningMap = warningMap - , ifaceHieFile = Just $ ml_hie_file $ ms_location ms - , ifaceDynFlags = dflags - } - - -- | Given all of the @import M as N@ declarations in a package, -- create a mapping from the module identity of M, to an alias N -- (if there are multiple aliases, we pick the last one.) This @@ -640,7 +559,8 @@ mkFixMap group_ = -- We create the export items even if the module is hidden, since they -- might be useful when creating the export items for other modules. mkExportItems - :: Bool -- is it a signature + :: Monad m + => Bool -- is it a signature -> IfaceMap -> Maybe Package -- this package -> Module -- this module @@ -657,7 +577,7 @@ mkExportItems -> Avails -- exported stuff from this module -> InstIfaceMap -> DynFlags - -> ErrMsgGhc [ExportItem GhcRn] + -> IfM m [ExportItem GhcRn] mkExportItems is_sig modMap pkgName thisMod semMod warnings gre exportedNames decls maps fixMap unrestricted_imp_mods splices exportList allExports @@ -699,24 +619,39 @@ mkExportItems availExportItem is_sig modMap thisMod semMod warnings exportedNames maps fixMap splices instIfaceMap dflags avail -availExportItem :: Bool -- is it a signature - -> IfaceMap - -> Module -- this module - -> Module -- semantic module - -> WarningMap - -> [Name] -- exported names (orig) - -> Maps - -> FixMap - -> [SrcSpan] -- splice locations - -> InstIfaceMap - -> DynFlags - -> AvailInfo - -> ErrMsgGhc [ExportItem GhcRn] + +-- Extract the minimal complete definition of a Name, if one exists +minimalDef :: Monad m => Name -> IfM m (Maybe ClassMinimalDef) +minimalDef n = do + mty <- lookupName n + case mty of + Just (ATyCon (tyConClass_maybe -> Just c)) -> + return . Just $ classMinimalDef c + _ -> + return Nothing + + +availExportItem + :: forall m + . Monad m + => Bool -- is it a signature + -> IfaceMap + -> Module -- this module + -> Module -- semantic module + -> WarningMap + -> [Name] -- exported names (orig) + -> Maps + -> FixMap + -> [SrcSpan] -- splice locations + -> InstIfaceMap + -> DynFlags + -> AvailInfo + -> IfM m [ExportItem GhcRn] availExportItem is_sig modMap thisMod semMod warnings exportedNames (docMap, argMap, declMap, _) fixMap splices instIfaceMap dflags availInfo = declWith availInfo where - declWith :: AvailInfo -> ErrMsgGhc [ ExportItem GhcRn ] + declWith :: AvailInfo -> IfM m [ ExportItem GhcRn ] declWith avail = do let t = availName avail r <- findDecl avail @@ -753,7 +688,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames in availExportDecl avail newDecl docs_ L loc (TyClD _ cl@ClassDecl{}) -> do - mdef <- liftGhcToErrMsgGhc $ minimalDef t + mdef <- minimalDef t let sig = maybeToList $ fmap (noLoc . MinimalSig noExtField NoSourceText . noLoc . fmap noLoc) mdef availExportDecl avail (L loc $ TyClD noExtField cl { tcdSigs = sig ++ tcdSigs cl }) docs_ @@ -783,7 +718,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames availExportDecl :: AvailInfo -> LHsDecl GhcRn -> (DocForDecl Name, [(Name, DocForDecl Name)]) - -> ErrMsgGhc [ ExportItem GhcRn ] + -> IfM m [ ExportItem GhcRn ] availExportDecl avail decl (doc, subs) | availExportsDecl avail = do -- bundled pattern synonyms only make sense if the declaration is @@ -828,7 +763,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames exportedNameSet = mkNameSet exportedNames isExported n = elemNameSet n exportedNameSet - findDecl :: AvailInfo -> ErrMsgGhc ([LHsDecl GhcRn], (DocForDecl Name, [(Name, DocForDecl Name)])) + findDecl :: AvailInfo -> IfM m ([LHsDecl GhcRn], (DocForDecl Name, [(Name, DocForDecl Name)])) findDecl avail | m == semMod = case M.lookup n declMap of @@ -857,10 +792,10 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames n = availName avail m = nameModule n - findBundledPatterns :: AvailInfo -> ErrMsgGhc [(HsDecl GhcRn, DocForDecl Name)] + findBundledPatterns :: AvailInfo -> IfM m [(HsDecl GhcRn, DocForDecl Name)] findBundledPatterns avail = do patsyns <- for constructor_names $ \name -> do - mtyThing <- liftGhcToErrMsgGhc (lookupName name) + mtyThing <- lookupName name case mtyThing of Just (AConLike PatSynCon{}) -> do export_items <- declWith (Avail.avail name) @@ -890,9 +825,9 @@ semToIdMod this_uid m | Module.isHoleModule m = mkModule this_uid (moduleName m) | otherwise = m -hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl GhcRn)) +hiDecl :: Monad m => DynFlags -> Name -> IfM m (Maybe (LHsDecl GhcRn)) hiDecl dflags t = do - mayTyThing <- liftGhcToErrMsgGhc $ lookupName t + mayTyThing <- lookupName t case mayTyThing of Nothing -> do liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty dflags t] @@ -911,8 +846,9 @@ hiDecl dflags t = do -- It gets the type signature from GHC and that means it's not going to -- have a meaningful 'SrcSpan'. So we pass down 'SrcSpan' for the -- declaration and use it instead - 'nLoc' here. -hiValExportItem :: DynFlags -> Name -> SrcSpan -> DocForDecl Name -> Bool - -> Maybe Fixity -> ErrMsgGhc (ExportItem GhcRn) +hiValExportItem + :: Monad m => DynFlags -> Name -> SrcSpan -> DocForDecl Name -> Bool + -> Maybe Fixity -> IfM m (ExportItem GhcRn) hiValExportItem dflags name nLoc doc splice fixity = do mayDecl <- hiDecl dflags name case mayDecl of @@ -942,12 +878,14 @@ lookupDocs avail warnings docMap argMap = -- | Export the given module as `ExportModule`. We are not concerned with the -- single export items of the given module. -moduleExport :: Module -- ^ Module A (identity, NOT semantic) - -> DynFlags -- ^ The flags used when typechecking A - -> IfaceMap -- ^ Already created interfaces - -> InstIfaceMap -- ^ Interfaces in other packages - -> ModuleName -- ^ The exported module - -> ErrMsgGhc [ExportItem GhcRn] -- ^ Resulting export items +moduleExport + :: Monad m + => Module -- ^ Module A (identity, NOT semantic) + -> DynFlags -- ^ The flags used when typechecking A + -> IfaceMap -- ^ Already created interfaces + -> InstIfaceMap -- ^ Interfaces in other packages + -> ModuleName -- ^ The exported module + -> IfM m [ExportItem GhcRn] -- ^ Resulting export items moduleExport thisMod dflags ifaceMap instIfaceMap expMod = -- NB: we constructed the identity module when looking up in -- the IfaceMap. @@ -961,9 +899,8 @@ moduleExport thisMod dflags ifaceMap instIfaceMap expMod = case M.lookup expMod (M.mapKeys moduleName instIfaceMap) of Just iface -> return [ ExportModule (instMod iface) ] Nothing -> do - liftErrMsg $ - tell ["Warning: " ++ pretty dflags thisMod ++ ": Could not find " ++ - "documentation for exported module: " ++ pretty dflags expMod] + liftErrMsg $ tell ["Warning: " ++ pretty dflags thisMod ++ ": Could not find " ++ + "documentation for exported module: " ++ pretty dflags expMod] return [] where m = mkModule (moduleUnit thisMod) expMod -- Identity module! @@ -989,22 +926,24 @@ moduleExport thisMod dflags ifaceMap instIfaceMap expMod = -- every locally defined declaration is exported; thus, we just -- zip through the renamed declarations. -fullModuleContents :: Bool -- is it a signature - -> IfaceMap - -> Maybe Package -- this package - -> Module -- this module - -> Module -- semantic module - -> WarningMap - -> GlobalRdrEnv -- ^ The renaming environment - -> [Name] -- exported names (orig) - -> [LHsDecl GhcRn] -- renamed source declarations - -> Maps - -> FixMap - -> [SrcSpan] -- splice locations - -> InstIfaceMap - -> DynFlags - -> Avails - -> ErrMsgGhc [ExportItem GhcRn] +fullModuleContents + :: Monad m + => Bool -- is it a signature + -> IfaceMap + -> Maybe Package -- this package + -> Module -- this module + -> Module -- semantic module + -> WarningMap + -> GlobalRdrEnv -- ^ The renaming environment + -> [Name] -- exported names (orig) + -> [LHsDecl GhcRn] -- renamed source declarations + -> Maps + -> FixMap + -> [SrcSpan] -- splice locations + -> InstIfaceMap + -> DynFlags + -> Avails + -> IfM m [ExportItem GhcRn] fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNames decls maps@(_, _, declMap, _) fixMap splices instIfaceMap dflags avails = do let availEnv = availsToNameEnv (nubAvails avails) diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 44c02875..87064a0f 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wwarn #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | @@ -22,7 +23,7 @@ module Haddock.Interface.LexParseRn import GHC.Types.Avail import Control.Arrow import Control.Monad -import Data.List +import Data.List ((\\), maximumBy) import Data.Ord import Documentation.Haddock.Doc (metaDocConcat) import GHC.Driver.Session (languageExtensions) diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index bfbdf392..14032d15 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -29,7 +29,6 @@ import GHC.Builtin.Types (eqTyCon_RDR) import Control.Applicative import Control.Arrow ( first ) import Control.Monad hiding (mapM) -import Data.List import qualified Data.Map as Map hiding ( Map ) import Prelude hiding (mapM) import GHC.HsToCore.Docs diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index 72fcb79b..4455f0f8 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -27,7 +27,7 @@ import Haddock.Utils hiding (out) import Control.Monad import Data.Array import Data.IORef -import Data.List +import Data.List (mapAccumR) import qualified Data.Map as Map import Data.Map (Map) import Data.Word diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs index 65aacc61..04189b99 100644 --- a/haddock-api/src/Haddock/Options.hs +++ b/haddock-api/src/Haddock/Options.hs @@ -46,11 +46,10 @@ import Data.Version import Control.Applicative import Distribution.Verbosity import GHC.Data.FastString -import GHC ( DynFlags, Module, moduleUnit ) +import GHC ( Module, moduleUnit ) import GHC.Unit.State import Haddock.Types import Haddock.Utils -import GHC.Unit.State import System.Console.GetOpt import qualified Text.ParserCombinators.ReadP as RP diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 53a91cf5..32f14f74 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -3,6 +3,9 @@ {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- @@ -25,13 +28,16 @@ module Haddock.Types ( , HsDocString, LHsDocString , Fixity(..) , module Documentation.Haddock.Types + + -- $ Reexports + , runWriter + , tell ) where import Control.Exception -import Control.Arrow hiding ((<+>)) import Control.DeepSeq -import Control.Monad (ap) import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Writer.Strict (Writer, WriterT, MonadWriter(..), lift, runWriter, runWriterT) import Data.Typeable (Typeable) import Data.Map (Map) import Data.Data (Data) @@ -595,26 +601,7 @@ data SinceQual type ErrMsg = String -newtype ErrMsgM a = Writer { runWriter :: (a, [ErrMsg]) } - - -instance Functor ErrMsgM where - fmap f (Writer (a, msgs)) = Writer (f a, msgs) - -instance Applicative ErrMsgM where - pure a = Writer (a, []) - (<*>) = ap - -instance Monad ErrMsgM where - return = pure - m >>= k = Writer $ let - (a, w) = runWriter m - (b, w') = runWriter (k a) - in (b, w ++ w') - - -tell :: [ErrMsg] -> ErrMsgM () -tell w = Writer ((), w) +type ErrMsgM = Writer [ErrMsg] -- Exceptions @@ -637,34 +624,24 @@ throwE str = throw (HaddockException str) -- @Haddock.Types.ErrMsg@s a lot, like @ErrMsgM@ does, -- but we can't just use @GhcT ErrMsgM@ because GhcT requires the -- transformed monad to be MonadIO. -newtype ErrMsgGhc a = WriterGhc { runWriterGhc :: Ghc (a, [ErrMsg]) } ---instance MonadIO ErrMsgGhc where --- liftIO = WriterGhc . fmap (\a->(a,[])) liftIO ---er, implementing GhcMonad involves annoying ExceptionMonad and ---WarnLogMonad classes, so don't bother. -liftGhcToErrMsgGhc :: Ghc a -> ErrMsgGhc a -liftGhcToErrMsgGhc = WriterGhc . fmap (\a->(a,[])) -liftErrMsg :: ErrMsgM a -> ErrMsgGhc a -liftErrMsg = WriterGhc . return . runWriter --- for now, use (liftErrMsg . tell) for this ---tell :: [ErrMsg] -> ErrMsgGhc () ---tell msgs = WriterGhc $ return ( (), msgs ) +newtype ErrMsgGhc a = ErrMsgGhc { unErrMsgGhc :: WriterT [ErrMsg] Ghc a } -instance Functor ErrMsgGhc where - fmap f (WriterGhc x) = WriterGhc (fmap (first f) x) +deriving newtype instance Functor ErrMsgGhc +deriving newtype instance Applicative ErrMsgGhc +deriving newtype instance Monad ErrMsgGhc +deriving newtype instance (MonadWriter [ErrMsg]) ErrMsgGhc +deriving newtype instance MonadIO ErrMsgGhc -instance Applicative ErrMsgGhc where - pure a = WriterGhc (return (a, [])) - (<*>) = ap -instance Monad ErrMsgGhc where - return = pure - m >>= k = WriterGhc $ runWriterGhc m >>= \ (a, msgs1) -> - fmap (second (msgs1 ++)) (runWriterGhc (k a)) +runWriterGhc :: ErrMsgGhc a -> Ghc (a, [ErrMsg]) +runWriterGhc = runWriterT . unErrMsgGhc -instance MonadIO ErrMsgGhc where - liftIO m = WriterGhc (fmap (\x -> (x, [])) (liftIO m)) +liftGhcToErrMsgGhc :: Ghc a -> ErrMsgGhc a +liftGhcToErrMsgGhc = ErrMsgGhc . lift + +liftErrMsg :: ErrMsgM a -> ErrMsgGhc a +liftErrMsg = writer . runWriter ----------------------------------------------------------------------------- -- * Pass sensitive types -- cgit v1.2.3