diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 29f151b14f03888a1fd0bb0c8ec55714dd93a042..2f6a9cc356b3294108e615f9eb783227df5aaf1c 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} @@ -46,6 +47,7 @@ import Haddock.Options import Haddock.Utils import Haddock.GhcUtils (modifySessionDynFlags, setOutputDir) +import Control.DeepSeq (force) import Control.Monad hiding (forM_) import Control.Monad.IO.Class (MonadIO(..)) import Data.Bifunctor (second) @@ -55,9 +57,9 @@ import Data.List (find, isPrefixOf, nub) import Control.Exception import Data.Maybe import Data.IORef -import Data.Map (Map) +import Data.Map.Strict (Map) import Data.Version (makeVersion) -import qualified Data.Map as Map +import qualified Data.Map.Strict as Map import System.IO import System.Exit import System.FilePath @@ -73,9 +75,9 @@ import System.Directory (doesDirectoryExist, getTemporaryDirectory) import Text.ParserCombinators.ReadP (readP_to_S) import GHC hiding (verbosity) import GHC.Settings.Config -import GHC.Driver.Session hiding (projectVersion, verbosity) import GHC.Driver.Config.Logger (initLogFlags) import GHC.Driver.Env +import GHC.Driver.Session hiding (projectVersion, verbosity) import GHC.Utils.Error import GHC.Utils.Logger import GHC.Types.Name.Cache @@ -197,7 +199,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do ghc flags' $ withDir $ do dflags <- getDynFlags logger <- getLogger - unit_state <- hsc_units <$> getSession + !unit_state <- hsc_units <$> getSession -- If any --show-interface was used, show the given interfaces forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do @@ -771,8 +773,10 @@ hypSrcWarnings flags = do updateHTMLXRefs :: [(FilePath, InterfaceFile)] -> IO () updateHTMLXRefs packages = do - writeIORef html_xrefs_ref (Map.fromList mapping) - writeIORef html_xrefs_ref' (Map.fromList mapping') + let !modMap = force $ Map.fromList mapping + !modNameMap = force $ Map.fromList mapping' + writeIORef html_xrefs_ref modMap + writeIORef html_xrefs_ref' modNameMap where mapping = [ (instMod iface, html) | (html, ifaces) <- packages , iface <- ifInstalledIfaces ifaces ] diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 211dd70aa2a59e5642e6ef801e0ecaf9c31ee6c6..15d6e4e2022c5cd7d809c00855a277dc927877ad 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -15,7 +15,11 @@ -- http://www.haskell.org/hoogle/ ----------------------------------------------------------------------------- module Haddock.Backends.Hoogle ( + -- * Main entry point to Hoogle output generation ppHoogle + + -- * Utilities for generating Hoogle output during interface creation + , ppExportD , outWith ) where @@ -55,7 +59,8 @@ ppHoogle dflags package version synopsis prologue ifaces odir = do docWith dflags' (drop 2 $ dropWhile (/= ':') synopsis) prologue ++ ["@package " ++ package] ++ ["@version " ++ showVersion version - | not (null (versionBranch version)) ] ++ + | not (null (versionBranch version)) + ] ++ concat [ppModule dflags' i | i <- ifaces, OptHide `notElem` ifaceOptions i] createDirectoryIfMissing True odir writeUtf8File (odir </> filename) (unlines contents) @@ -64,9 +69,14 @@ ppModule :: DynFlags -> Interface -> [String] ppModule dflags iface = "" : ppDocumentation dflags (ifaceDoc iface) ++ ["module " ++ moduleString (ifaceMod iface)] ++ - concatMap (ppExport dflags) (ifaceExportItems iface) ++ + concatMap ppExportItem (ifaceRnExportItems $ iface) ++ map (fromMaybe "" . haddockClsInstPprHoogle) (ifaceInstances iface) +-- | If the export item is an 'ExportDecl', get the attached Hoogle textual +-- database entries for that export declaration. +ppExportItem :: ExportItem DocNameI -> [String] +ppExportItem (ExportDecl RnExportD { rnExpDHoogle = o }) = o +ppExportItem _ = [] --------------------------------------------------------------------- -- Utility functions @@ -116,28 +126,37 @@ commaSeparate dflags = showSDoc dflags . interpp'SP --------------------------------------------------------------------- -- How to print each export -ppExport :: DynFlags -> ExportItem GhcRn -> [String] -ppExport dflags ExportDecl { expItemDecl = L _ decl - , expItemPats = bundledPats - , expItemMbDoc = mbDoc - , expItemSubDocs = subdocs - , expItemFixities = fixities - } = concat [ ppDocumentation dflags dc ++ f d - | (d, (dc, _)) <- (decl, mbDoc) : bundledPats - ] ++ - ppFixities - where - f (TyClD _ d@DataDecl{}) = ppData dflags d subdocs - f (TyClD _ d@SynDecl{}) = ppSynonym dflags d - f (TyClD _ d@ClassDecl{}) = ppClass dflags d subdocs - f (TyClD _ (FamDecl _ d)) = ppFam dflags d - f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] typ] - f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] typ] - f (SigD _ sig) = ppSig dflags sig - f _ = [] - - ppFixities = concatMap (ppFixity dflags) fixities -ppExport _ _ = [] +ppExportD :: DynFlags -> ExportD GhcRn -> [String] +ppExportD dflags + ExportD + { expDDecl = L _ decl + , expDPats = bundledPats + , expDMbDoc = mbDoc + , expDSubDocs = subdocs + , expDFixities = fixities + } + = let + -- Since Hoogle is line based, we want to avoid breaking long lines. + dflags' = dflags{ pprCols = maxBound } + in + concat + [ ppDocumentation dflags' dc ++ f d + | (d, (dc, _)) <- (decl, mbDoc) : bundledPats + ] ++ ppFixities + where + f :: HsDecl GhcRn -> [String] + f (TyClD _ d@DataDecl{}) = ppData dflags d subdocs + f (TyClD _ d@SynDecl{}) = ppSynonym dflags d + f (TyClD _ d@ClassDecl{}) = ppClass dflags d subdocs + f (TyClD _ (FamDecl _ d)) = ppFam dflags d + f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] typ] + f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] typ] + f (SigD _ sig) = ppSig dflags sig + f _ = [] + + ppFixities :: [String] + ppFixities = concatMap (ppFixity dflags) fixities + ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String] ppSigWithDoc dflags sig subdocs = case sig of diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index d335e8fa1769293bcc4b386de0c8e53d05a3c5b2..f07534920a2c555164b4ee77a19fa0c904b941ae 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -18,6 +18,7 @@ module Haddock.Backends.LaTeX ( ) where import Documentation.Haddock.Markup +import Haddock.Doc (combineDocumentation) import Haddock.Types import Haddock.Utils import Haddock.GhcUtils @@ -42,8 +43,6 @@ import Data.List.NonEmpty ( NonEmpty (..) ) import Data.Foldable ( toList ) import Prelude hiding ((<>)) -import Haddock.Doc (combineDocumentation) - {- SAMPLE OUTPUT \haddockmoduleheading{\texttt{Data.List}} @@ -178,7 +177,18 @@ ppLaTeXModule _title odir iface = do -- | Prints out an entry in a module export list. exportListItem :: ExportItem DocNameI -> LaTeX -exportListItem ExportDecl { expItemDecl = decl, expItemSubDocs = subdocs } +exportListItem + ( ExportDecl + ( RnExportD + { rnExpDExpD = + ( ExportD + { expDDecl = decl + , expDSubDocs = subdocs + } + ) + } + ) + ) = let (leader, names) = declNames decl in sep (punctuate comma [ leader <+> ppDocBinder name | name <- names ]) <> case subdocs of @@ -213,9 +223,18 @@ processExports (e : es) = isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsSigType DocNameI) -isSimpleSig ExportDecl { expItemDecl = L _ (SigD _ (TypeSig _ lnames t)) - , expItemMbDoc = (Documentation Nothing Nothing, argDocs) } - | Map.null argDocs = Just (map unLoc lnames, unLoc (dropWildCards t)) +isSimpleSig + ( ExportDecl + ( RnExportD + { rnExpDExpD = + ExportD + { expDDecl = L _ (SigD _ (TypeSig _ lnames t)) + , expDMbDoc = (Documentation Nothing Nothing, argDocs) + } + } + ) + ) + | Map.null argDocs = Just (map unLoc lnames, unLoc (dropWildCards t)) isSimpleSig _ = Nothing @@ -227,7 +246,7 @@ isExportModule _ = Nothing processExport :: ExportItem DocNameI -> LaTeX processExport (ExportGroup lev _id0 doc) = ppDocGroup lev (docToLaTeX doc) -processExport (ExportDecl decl pats doc subdocs insts fixities _splice) +processExport (ExportDecl (RnExportD (ExportD decl pats doc subdocs insts fixities _splice) _)) = ppDecl decl pats doc insts subdocs fixities processExport (ExportNoDecl y []) = ppDocName y @@ -290,13 +309,9 @@ ppDecl :: LHsDecl DocNameI -- ^ decl to print -> LaTeX ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of - TyClD _ d@FamDecl {} -> ppFamDecl False doc instances d unicode - TyClD _ d@DataDecl {} -> ppDataDecl pats instances subdocs (Just doc) d unicode - TyClD _ d@SynDecl {} -> ppTySyn (doc, fnArgsDoc) d unicode --- Family instances happen via FamInst now --- TyClD _ d@TySynonym{} --- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode --- Family instances happen via FamInst now + TyClD _ d@FamDecl {} -> ppFamDecl False doc instances d unicode + TyClD _ d@DataDecl {} -> ppDataDecl pats instances subdocs (Just doc) d unicode + TyClD _ d@SynDecl {} -> ppTySyn (doc, fnArgsDoc) d unicode TyClD _ d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode SigD _ (TypeSig _ lnames ty) -> ppFunSig Nothing (doc, fnArgsDoc) (map unLoc lnames) (dropWildCards ty) unicode SigD _ (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 4cc6aa77096633b99f443dad404be2ffc74e146d..da4d1ed01e5c61238c96f0696ed67790a84b2eb6 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -11,7 +11,11 @@ -- Stability : experimental -- Portability : portable ----------------------------------------------------------------------------- -{-# LANGUAGE CPP, NamedFieldPuns, TupleSections, TypeApplications #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + module Haddock.Backends.Xhtml ( ppHtml, copyHtmlBits, ppHtmlIndex, ppHtmlContents, @@ -356,7 +360,7 @@ ppPrologue pkg qual title (Just doc) = ppSignatureTrees :: Maybe Package -> Qualification -> [(PackageInfo, [ModuleTree])] -> Html ppSignatureTrees _ _ tss | all (null . snd) tss = mempty -ppSignatureTrees pkg qual [(info, ts)] = +ppSignatureTrees pkg qual [(info, ts)] = divPackageList << (sectionName << "Signatures" +++ ppSignatureTree pkg qual "n" info ts) ppSignatureTrees pkg qual tss = divModuleList << @@ -427,8 +431,6 @@ mkNode pkg qual ss p (Node s leaf _pkg srcPkg short ts) = mkNodeList pkg qual (s:ss) p ts ) - - -------------------------------------------------------------------------------- -- * Generate the index -------------------------------------------------------------------------------- @@ -522,11 +524,11 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces ins names = exportName item ++ exportSubs item exportSubs :: ExportItem DocNameI -> [IdP DocNameI] - exportSubs ExportDecl { expItemSubDocs } = map fst expItemSubDocs + exportSubs (ExportDecl (RnExportD { rnExpDExpD = ExportD { expDSubDocs } })) = map fst expDSubDocs exportSubs _ = [] exportName :: ExportItem DocNameI -> [IdP DocNameI] - exportName ExportDecl { expItemDecl } = getMainDeclBinderI (unLoc expItemDecl) + exportName (ExportDecl (RnExportD { rnExpDExpD = ExportD { expDDecl } })) = getMainDeclBinderI (unLoc expDDecl) exportName ExportNoDecl { expItemName } = [expItemName] exportName _ = [] @@ -538,7 +540,7 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces ins -- update link using relative path to output directory fixLink :: FilePath -> JsonIndexEntry -> JsonIndexEntry - fixLink ifaceFile jie = + fixLink ifaceFile jie = jie { jieLink = makeRelative odir (takeDirectory ifaceFile) FilePath.</> jieLink jie } @@ -722,7 +724,17 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg qual -- todo: if something has only sub-docs, or fn-args-docs, should -- it be measured here and thus prevent omitting the synopsis? - has_doc ExportDecl { expItemMbDoc = (Documentation mDoc mWarning, _) } = isJust mDoc || isJust mWarning + has_doc + ( ExportDecl + ( RnExportD + { rnExpDExpD = + ExportD + { expDMbDoc = + ( Documentation mDoc mWarn, _ ) + } + } + ) + ) = isJust mDoc || isJust mWarn has_doc (ExportNoDecl _ _) = False has_doc (ExportModule _) = False has_doc _ = True @@ -816,11 +828,28 @@ numberSectionHeadings = go 1 processExport :: Bool -> LinksInfo -> Bool -> Maybe Package -> Qualification -> ExportItem DocNameI -> Maybe Html -processExport _ _ _ _ _ ExportDecl { expItemDecl = L _ (InstD {}) } = Nothing -- Hide empty instances +processExport _ _ _ _ _ + ( ExportDecl + ( RnExportD + { rnExpDExpD = + ExportD + { expDDecl = L _ (InstD {}) + } + } + ) + ) + = Nothing -- Hide empty instances +processExport summary links unicode pkg qual + ( ExportDecl + ( RnExportD + { rnExpDExpD = + ExportD decl pats doc subdocs insts fixities splice + } + ) + ) + = processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode pkg qual processExport summary _ _ pkg qual (ExportGroup lev id0 doc) = nothingIf summary $ groupHeading lev id0 << docToHtmlNoAnchors (Just id0) pkg qual (mkMeta doc) -processExport summary links unicode pkg qual (ExportDecl decl pats doc subdocs insts fixities splice) - = processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode pkg qual processExport summary _ _ _ qual (ExportNoDecl y []) = processDeclOneLiner summary $ ppDocName qual Prefix True y processExport summary _ _ _ qual (ExportNoDecl y subs) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 496b357490254d5664f13622998ce9c70106336b..25d5a0648eea57b1aded4299053bc3f7a4f3b969 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -1,4 +1,8 @@ -{-# LANGUAGE CPP, PatternGuards, TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BangPatterns #-} + ----------------------------------------------------------------------------- -- | -- Module : Haddock.Convert @@ -639,7 +643,7 @@ synifyType _ vs (TyConApp tc tys) = mk_app_tys (HsTyVar noAnn prom $ noLocA (getName tc)) vis_tys where - prom = if isPromotedDataCon tc then IsPromoted else NotPromoted + !prom = if isPromotedDataCon tc then IsPromoted else NotPromoted mk_app_tys ty_app ty_args = foldl (\t1 t2 -> noLocA $ HsAppTy noExtField t1 t2) (noLocA ty_app) diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index 215458bab82e91009baf0cbebf4a6dbaa06df16b..0eba8b1fb9396dabbc1301be387adbc6a9795997 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -40,14 +40,11 @@ import Haddock.Interface.Create (createInterface1, runIfM) import Haddock.Interface.Rename (renameInterface) import Haddock.InterfaceFile (InterfaceFile, ifInstalledIfaces, ifLinkEnv) import Haddock.Options hiding (verbosity) -import Haddock.Types (DocOption (..), Documentation (..), ExportItem (..), IfaceMap, InstIfaceMap, Interface, LinkEnv, - expItemDecl, expItemMbDoc, ifaceDoc, ifaceExportItems, ifaceExports, ifaceHaddockCoverage, - ifaceInstances, ifaceMod, ifaceOptions, ifaceVisibleExports, instMod, throwE, haddockClsInstName) +import Haddock.Types import Haddock.Utils (Verbosity (..), normal, out, verbose) import Control.Monad (unless, when) -import Control.Monad.IO.Class (MonadIO) -import Data.IORef (atomicModifyIORef', newIORef, readIORef) +import Data.IORef (atomicModifyIORef', newIORef, readIORef, IORef) import Data.List (foldl', isPrefixOf, nub) import Data.Maybe (mapMaybe) import Data.Traversable (for) @@ -64,7 +61,7 @@ import GHC.HsToCore.Docs (getMainDeclBinder) import GHC.Plugins import GHC.Tc.Types (TcGblEnv (..), TcM) import GHC.Tc.Utils.Env (tcLookupGlobal) -import GHC.Tc.Utils.Monad (getTopEnv, setGblEnv) +import GHC.Tc.Utils.Monad (getTopEnv) import GHC.Unit.Module.Graph import GHC.Utils.Error (withTiming) @@ -91,8 +88,11 @@ processModules verbosity modules flags extIfaces = do liftIO $ hSetEncoding stderr $ mkLocaleEncoding TransliterateCodingFailure #endif + dflags <- getDynFlags + out verbosity verbose "Creating interfaces..." + -- Map from a module to a corresponding installed interface let instIfaceMap :: InstIfaceMap instIfaceMap = Map.fromList @@ -129,7 +129,7 @@ processModules verbosity modules flags extIfaces = do withTimingM "renameAllInterfaces" (const ()) $ for interfaces' $ \i -> do withTimingM ("renameInterface: " <+> pprModuleName (moduleName (ifaceMod i))) (const ()) $ - renameInterface ignoredSymbolSet links warnings i + renameInterface dflags ignoredSymbolSet links warnings (Flag_Hoogle `elem` flags) i return (interfaces'', homeLinks) @@ -150,10 +150,15 @@ createIfaces -> Ghc ([Interface], ModuleSet) -- ^ Resulting interfaces createIfaces verbosity modules flags instIfaceMap = do - (haddockPlugin, getIfaces, getModules) <- liftIO $ plugin - verbosity flags instIfaceMap + -- Initialize the IORefs for the interface map and the module set + (ifaceMapRef, moduleSetRef) <- liftIO $ do + m <- newIORef Map.empty + s <- newIORef emptyModuleSet + return (m, s) let + haddockPlugin = plugin verbosity flags instIfaceMap ifaceMapRef moduleSetRef + installHaddockPlugin :: HscEnv -> HscEnv installHaddockPlugin hsc_env = let @@ -178,8 +183,11 @@ createIfaces verbosity modules flags instIfaceMap = do throwE "Cannot typecheck modules" Succeeded -> do modGraph <- GHC.getModuleGraph - ifaceMap <- liftIO getIfaces - moduleSet <- liftIO getModules + + (ifaceMap, moduleSet) <- liftIO $ do + m <- readIORef ifaceMapRef + s <- readIORef moduleSetRef + return (m, s) let -- We topologically sort the module graph including boot files, @@ -245,23 +253,18 @@ createIfaces verbosity modules flags instIfaceMap = do -- interfaces. Due to the plugin nature we benefit from GHC's capabilities to -- parallelize the compilation process. plugin - :: MonadIO m - => Verbosity + :: Verbosity -- ^ Verbosity requested by the Haddock caller -> [Flag] -- ^ Command line flags which Hadddock was invoked with -> InstIfaceMap -- ^ Map from module to corresponding installed interface file - -> 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 - + -> IORef IfaceMap + -- ^ The 'IORef' to write the interface map to + -> IORef ModuleSet + -- ^ The 'IORef' to write the module set to + -> StaticPlugin -- the plugin to install with GHC +plugin verbosity flags instIfaceMap ifaceMapRef moduleSetRef = let processTypeCheckedResult :: ModSummary -> TcGblEnv -> TcM () processTypeCheckedResult mod_summary tc_gbl_env @@ -282,16 +285,15 @@ plugin verbosity flags instIfaceMap = liftIO $ do atomicModifyIORef' moduleSetRef $ \xs -> (modules `unionModuleSet` xs, ()) - - staticPlugin :: StaticPlugin - staticPlugin = StaticPlugin + in + StaticPlugin { spPlugin = PluginWithArgs { paPlugin = defaultPlugin { renamedResultAction = keepRenamedSource - , typeCheckResultAction = \_ mod_summary tc_gbl_env -> setGblEnv tc_gbl_env $ do + , typeCheckResultAction = \_ mod_summary tc_gbl_env -> do processTypeCheckedResult mod_summary tc_gbl_env pure tc_gbl_env } @@ -299,13 +301,6 @@ plugin verbosity flags instIfaceMap = liftIO $ do } } - pure - ( staticPlugin - , liftIO (readIORef ifaceMapRef) - , liftIO (readIORef moduleSetRef) - ) - - processModule1 :: Verbosity -- ^ Verbosity requested by the Haddock caller @@ -375,9 +370,10 @@ processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env undocumentedExports :: [String] undocumentedExports = [ formatName (locA s) n - | ExportDecl { expItemDecl = L s n - , expItemMbDoc = (Documentation Nothing _, _) - } <- ifaceExportItems interface + | ExportDecl ExportD + { expDDecl = L s n + , expDMbDoc = (Documentation Nothing _, _) + } <- ifaceExportItems interface ] where formatName :: SrcSpan -> HsDecl GhcRn -> String diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 71cc25c7f0b49cafd7a97e56c253f6b5f2a5ae4d..6b854247889f686981c3dd506915d710937e29db 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -102,7 +102,7 @@ attachToExportItem -> Ghc (ExportItem GhcRn) attachToExportItem index expInfo getInstDoc getFixity export = case attachFixities export of - e@ExportDecl { expItemDecl = L eSpan (TyClD _ d) } -> do + ExportDecl e@(ExportD { expDDecl = L eSpan (TyClD _ d) }) -> do insts <- let mb_instances = lookupNameEnv index (tcdName d) cls_instances = maybeToList mb_instances >>= fst @@ -139,18 +139,27 @@ attachToExportItem index expInfo getInstDoc getFixity export = let mkBug = (text "haddock-bug:" <+>) . text putMsgM (sep $ map mkBug famInstErrs) return $ cls_insts ++ cleanFamInsts - return $ e { expItemInstances = insts } + return $ ExportDecl e { expDInstances = insts } e -> return e where - attachFixities e@ExportDecl{ expItemDecl = L _ d - , expItemPats = patsyns - , expItemSubDocs = subDocs - } = e { expItemFixities = - nubByName fst $ expItemFixities e ++ - [ (n',f) | n <- getMainDeclBinder emptyOccEnv d - , n' <- n : (map fst subDocs ++ patsyn_names) - , f <- maybeToList (getFixity n') - ] } + attachFixities + ( ExportDecl + ( e@ExportD + { expDDecl = L _ d + , expDPats = patsyns + , expDSubDocs = subDocs + } + ) + ) + = ExportDecl e + { expDFixities = + nubByName fst $ expDFixities e ++ + [ (n',f) + | n <- getMainDeclBinder emptyOccEnv d + , n' <- n : (map fst subDocs ++ patsyn_names) + , f <- maybeToList (getFixity n') + ] + } where patsyn_names = concatMap (getMainDeclBinder emptyOccEnv . fst) patsyns diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 06b494c1581f23398cfa09d9465ae0547ab8b8f7..2a3450d506785c16d823ddc812c45df4e3b658f2 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -50,8 +50,8 @@ import Data.Foldable (toList) import Data.List (find, foldl') import qualified Data.IntMap as IM import Data.IntMap (IntMap) -import Data.Map (Map) -import qualified Data.Map as M +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M import Data.Maybe (catMaybes, fromJust, isJust, mapMaybe, maybeToList) import Data.Traversable (for) @@ -312,8 +312,6 @@ createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do , 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 = [] -- Filled in renameInterfaceRn @@ -544,11 +542,11 @@ mkMaps dflags pkgName gre instances decls thDocs = do , force $ fmap intmap2mapint $ th_b `unionArgMaps` (f (filterMapping (not . IM.null) b)) - , f (filterMapping (not . null) c) + , f c , instanceMap ) where - f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b + f :: (Ord a, Semigroup b) => [[(a, b)]] -> Map a b f = M.fromListWith (<>) . concat f' :: [[(Name, MDoc Name)]] -> Map Name (MDoc Name) @@ -585,7 +583,7 @@ mkMaps dflags pkgName gre instances decls thDocs = do mappings :: (LHsDecl GhcRn, [HsDoc GhcRn]) -> ErrMsgM ( [(Name, MDoc Name)] , [(Name, IntMap (MDoc Name))] - , [(Name, [LHsDecl GhcRn])] + , [(Name, DeclMapEntry)] ) mappings (ldecl@(L (SrcSpanAnn _ (RealSrcSpan l _)) decl), hs_docStrs) = do let docStrs = map hsDocString hs_docStrs @@ -610,7 +608,7 @@ mkMaps dflags pkgName gre instances decls thDocs = do subNs = [ n | (n, _, _) <- subs ] dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ] am = [ (n, args) | n <- ns ] ++ zip subNs subArgs - cm = [ (n, [ldecl]) | n <- ns ++ subNs ] + cm = [ (n, toDeclMapEntry ldecl) | n <- ns ++ subNs ] seqList ns `seq` seqList subNs `seq` @@ -773,19 +771,24 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames let t = availName avail r <- findDecl avail case r of - ([L l' (ValD _ _)], (doc, _)) -> do - let l = locA l' - -- Top-level binding without type signature - export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap + (Just (EValD srcSpan), (doc, _)) -> do + -- Since the DeclMapEntry is an 'EValD', we know the declaration is a + -- top-level binding without a type signature. We get type information + -- for the binding from the GHC interface file using the + -- 'hiValExportItem' function + export <- hiValExportItem dflags t srcSpan doc (srcSpan `elem` splices) $ M.lookup t fixMap return [export] - (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds -> - let declNames = getMainDeclBinder emptyOccEnv (unL decl) + + (Just (EOther d), docs_) -> + let declNames = getMainDeclBinder emptyOccEnv (unL d) in case () of _ - -- We should not show a subordinate by itself if any of its - -- parents is also exported. See note [1]. + -- If 't' is not the main declaration binder, then it is a + -- subordinate name in the declaration. If any of its parents are + -- also exported, we do not want to show its documentation by + -- itself. See note [1]. | t `notElem` declNames, - Just p <- find isExported (parents t $ unL decl) -> + Just p <- find isExported (parents t $ unL d) -> do liftErrMsg $ tell [ "Warning: " ++ moduleString thisMod ++ ": " ++ pretty dflags (nameOccName t) ++ " is exported separately but " ++ @@ -795,7 +798,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames return [] -- normal case - | otherwise -> case decl of + | otherwise -> case d of -- A single signature might refer to many names, but we -- create an export item for a single name only. So we -- modify the signature to contain only that single name. @@ -811,10 +814,10 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames availExportDecl avail (L loc $ TyClD noExtField ClassDecl { tcdSigs = sig ++ tcdSigs, .. }) docs_ - _ -> availExportDecl avail decl docs_ + _ -> availExportDecl avail d docs_ -- Declaration from another package - ([], _) -> do + (Nothing, _) -> do mayDecl <- hiDecl dflags t case mayDecl of Nothing -> return [ ExportNoDecl t [] ] @@ -832,8 +835,6 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames Just iface -> availExportDecl avail decl (lookupDocs avail warnings (instDocMap iface) (instArgMap iface)) - _ -> return [] - -- Tries 'extractDecl' first then falls back to 'hiDecl' if that fails availDecl :: Name -> LHsDecl GhcRn -> IfM m (LHsDecl GhcRn) availDecl declName parentDecl = @@ -866,38 +867,40 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames , Just f <- [M.lookup n fixMap] ] - return [ ExportDecl { - expItemDecl = restrictTo (fmap fst subs) extractedDecl - , expItemPats = bundledPatSyns - , expItemMbDoc = doc - , expItemSubDocs = subs - , expItemInstances = [] - , expItemFixities = fixities - , expItemSpliced = False - } - ] + return + [ ExportDecl ExportD + { expDDecl = restrictTo (fmap fst subs) extractedDecl + , expDPats = bundledPatSyns + , expDMbDoc = doc + , expDSubDocs = subs + , expDInstances = [] + , expDFixities = fixities + , expDSpliced = False + } + ] | otherwise = for subs $ \(sub, sub_doc) -> do extractedDecl <- availDecl sub decl - return ( ExportDecl { - expItemDecl = extractedDecl - , expItemPats = [] - , expItemMbDoc = sub_doc - , expItemSubDocs = [] - , expItemInstances = [] - , expItemFixities = [ (sub, f) | Just f <- [M.lookup sub fixMap] ] - , expItemSpliced = False - } ) + return $ + ExportDecl ExportD + { expDDecl = extractedDecl + , expDPats = [] + , expDMbDoc = sub_doc + , expDSubDocs = [] + , expDInstances = [] + , expDFixities = [ (sub, f) | Just f <- [M.lookup sub fixMap] ] + , expDSpliced = False + } exportedNameSet = mkNameSet exportedNames isExported n = elemNameSet n exportedNameSet - findDecl :: AvailInfo -> IfM m ([LHsDecl GhcRn], (DocForDecl Name, [(Name, DocForDecl Name)])) + findDecl :: AvailInfo -> IfM m (Maybe DeclMapEntry, (DocForDecl Name, [(Name, DocForDecl Name)])) findDecl avail | m == semMod = case M.lookup n declMap of - Just ds -> return (ds, lookupDocs avail warnings docMap argMap) + Just d -> return (Just d, lookupDocs avail warnings docMap argMap) Nothing | is_sig -> do -- OK, so it wasn't in the local declaration map. It could @@ -905,19 +908,19 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames -- from the type. mb_r <- hiDecl dflags n case mb_r of - Nothing -> return ([], (noDocForDecl, availNoDocs avail)) + Nothing -> return (Nothing, (noDocForDecl, availNoDocs avail)) -- TODO: If we try harder, we might be able to find -- a Haddock! Look in the Haddocks for each thing in -- requirementContext (unitState) - Just decl -> return ([decl], (noDocForDecl, availNoDocs avail)) + Just decl -> return (Just $ toDeclMapEntry decl, (noDocForDecl, availNoDocs avail)) | otherwise -> - return ([], (noDocForDecl, availNoDocs avail)) + return (Nothing, (noDocForDecl, availNoDocs avail)) | Just iface <- M.lookup (semToIdMod (moduleUnit thisMod) m) modMap - , Just ds <- M.lookup n (ifaceDeclMap iface) = - return (ds, lookupDocs avail warnings + , Just d <- M.lookup n (ifaceDeclMap iface) = + return (Just d, lookupDocs avail warnings (ifaceDocMap iface) (ifaceArgMap iface)) - | otherwise = return ([], (noDocForDecl, availNoDocs avail)) + | otherwise = return (Nothing, (noDocForDecl, availNoDocs avail)) where n = availName avail m = nameModule n @@ -930,9 +933,9 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames Just (AConLike PatSynCon{}) -> do export_items <- declWith (Avail.avail name) pure [ (unLoc patsyn_decl, patsyn_doc) - | ExportDecl { - expItemDecl = patsyn_decl - , expItemMbDoc = patsyn_doc + | ExportDecl ExportD + { expDDecl = patsyn_decl + , expDMbDoc = patsyn_doc } <- export_items ] _ -> pure [] @@ -983,7 +986,7 @@ hiValExportItem dflags name nLoc doc splice fixity = do mayDecl <- hiDecl dflags name case mayDecl of Nothing -> return (ExportNoDecl name []) - Just decl -> return (ExportDecl (fixSpan decl) [] doc [] [] fixities splice) + Just decl -> return (ExportDecl $ ExportD (fixSpan decl) [] doc [] [] fixities splice) where fixSpan (L (SrcSpanAnn a l) t) = L (SrcSpanAnn a (SrcLoc.combineSrcSpans l nLoc)) t fixities = case fixity of @@ -994,7 +997,7 @@ hiValExportItem dflags name nLoc doc splice fixity = do -- | Lookup docs for a declaration from maps. lookupDocs :: AvailInfo -> WarningMap -> DocMap Name -> ArgMap Name -> (DocForDecl Name, [(Name, DocForDecl Name)]) -lookupDocs avail warnings docMap argMap = +lookupDocs avail warningMap docMap argMap = let n = availName avail in let lookupArgDoc x = M.findWithDefault M.empty x argMap in let doc = (lookupDoc n, lookupArgDoc n) in @@ -1003,7 +1006,7 @@ lookupDocs avail warnings docMap argMap = ] in (doc, subDocs) where - lookupDoc name = Documentation (M.lookup name docMap) (M.lookup name warnings) + lookupDoc name = Documentation (M.lookup name docMap) (M.lookup name warningMap) -- | Export the given module as `ExportModule`. We are not concerned with the @@ -1087,7 +1090,7 @@ fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNam return [[ExportDoc doc]] (L _ (ValD _ valDecl)) | name:_ <- collectHsBindBinders CollNoDictBinders valDecl - , Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap + , Just (EOther (L _ SigD{})) <- M.lookup name declMap -> return [] _ -> for (getMainDeclBinder emptyOccEnv (unLoc decl)) $ \nm -> do @@ -1097,9 +1100,6 @@ fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNam semMod warnings exportedNames maps fixMap splices instIfaceMap dflags avail Nothing -> pure []) - where - isSigD (L _ SigD{}) = True - isSigD _ = False -- | Sometimes the declaration we want to export is not the "main" declaration: -- it might be an individual record selector or a class method. In these @@ -1144,7 +1144,7 @@ extractDecl declMap name decl (_, [L pos fam_decl]) -> pure (L pos (TyClD noExtField (FamDecl noExtField fam_decl))) ([], []) - | Just (famInstDecl:_) <- M.lookup name declMap + | Just (EOther famInstDecl) <- M.lookup name declMap -> extractDecl declMap name famInstDecl _ -> Left (concat [ "Ambiguous decl for ", getOccString name , " in class ", getOccString clsNm ]) @@ -1159,7 +1159,7 @@ extractDecl declMap name decl TyClD _ FamDecl {} | isValName name - , Just (famInst:_) <- M.lookup name declMap + , Just (EOther famInst) <- M.lookup name declMap -> extractDecl declMap name famInst InstD _ (DataFamInstD _ (DataFamInstDecl (FamEqn { feqn_tycon = L _ n @@ -1257,7 +1257,7 @@ extractRecSel nm t tvs (L _ con : rest) = pruneExportItems :: [ExportItem GhcRn] -> [ExportItem GhcRn] pruneExportItems = filter hasDoc where - hasDoc (ExportDecl{expItemMbDoc = (Documentation d _, _)}) = isJust d + hasDoc (ExportDecl ExportD {expDMbDoc = (Documentation d _, _)}) = isJust d hasDoc _ = True @@ -1267,10 +1267,10 @@ mkVisibleNames (_, _, _, instMap) exports opts | otherwise = let ns = concatMap exportName exports in seqList ns `seq` ns where - exportName e@ExportDecl {} = name ++ subs ++ patsyns - where subs = map fst (expItemSubDocs e) - patsyns = concatMap (getMainDeclBinder emptyOccEnv . fst) (expItemPats e) - name = case unLoc $ expItemDecl e of + exportName (ExportDecl e@ExportD{}) = name ++ subs ++ patsyns + where subs = map fst (expDSubDocs e) + patsyns = concatMap (getMainDeclBinder emptyOccEnv . fst) (expDPats e) + name = case unLoc $ expDDecl e of InstD _ d -> maybeToList $ SrcLoc.lookupSrcSpan (getInstLoc d) instMap decl -> getMainDeclBinder emptyOccEnv decl exportName ExportNoDecl {} = [] -- we don't count these as visible, since diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index d731d612041dc60bb4c24b59f9ec3f2fc0f0483f..f142f0651aeac99c3249559b70e765d109ce9b99 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -22,7 +22,6 @@ module Haddock.Interface.LexParseRn ) where import Control.Arrow -import Control.DeepSeq import Control.Monad import Data.Functor import Data.List ((\\), maximumBy) @@ -45,25 +44,24 @@ processDocStrings :: DynFlags -> Maybe Package -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (MDoc Name)) processDocStrings dflags pkg gre strs = do mdoc <- metaDocConcat <$> traverse (processDocStringParas dflags pkg gre) strs - force <$> - case mdoc of - -- We check that we don't have any version info to render instead - -- of just checking if there is no comment: there may not be a - -- comment but we still want to pass through any meta data. - MetaDoc { _meta = Meta Nothing Nothing, _doc = DocEmpty } -> pure Nothing - x -> pure (Just x) + case mdoc of + -- We check that we don't have any version info to render instead + -- of just checking if there is no comment: there may not be a + -- comment but we still want to pass through any meta data. + MetaDoc { _meta = Meta Nothing Nothing, _doc = DocEmpty } -> pure Nothing + x -> pure (Just x) processDocStringParas :: DynFlags -> Maybe Package -> GlobalRdrEnv -> HsDocString -> ErrMsgM (MDoc Name) -processDocStringParas dflags pkg gre hds = force <$> - overDocF (rename dflags gre) (parseParas dflags pkg (renderHsDocString hds)) +processDocStringParas dflags pkg gre hds = + overDocF (rename dflags gre) (parseParas dflags pkg (renderHsDocString hds)) processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Doc Name) processDocString dflags gre hds = - force <$> processDocStringFromString dflags gre (renderHsDocString hds) + processDocStringFromString dflags gre (renderHsDocString hds) processDocStringFromString :: DynFlags -> GlobalRdrEnv -> String -> ErrMsgM (Doc Name) processDocStringFromString dflags gre hds = - force <$> rename dflags gre (parseString dflags hds) + rename dflags gre (parseString dflags hds) processModuleHeader :: DynFlags -> Maybe Package -> GlobalRdrEnv -> SafeHaskellMode -> Maybe HsDocString -> ErrMsgM (HaddockModInfo Name, Maybe (MDoc Name)) @@ -84,7 +82,7 @@ processModuleHeader dflags pkgName gre safety mayStr = do let flags :: [LangExt.Extension] -- We remove the flags implied by the language setting and we display the language instead flags = EnumSet.toList (extensionFlags dflags) \\ languageExtensions (language dflags) - return $ force + return (hmi { hmi_safety = Just $ showPpr dflags safety , hmi_language = language dflags , hmi_extensions = flags diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 2e25ded9900121d60ddb5e1637c84324729c6f32..49ff2dace237aca2d28be671750d36950984a030 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -20,6 +20,7 @@ module Haddock.Interface.Rename (renameInterface) where import Data.Traversable (mapM) +import Haddock.Backends.Hoogle (ppExportD) import Haddock.GhcUtils import Haddock.Types hiding (runWriter) @@ -48,7 +49,9 @@ import GHC.Types.Basic ( TopLevelFlag(..) ) -- The renamed output gets written into fields in the Haddock interface record -- that were previously left empty. renameInterface - :: Map.Map (Maybe String) (Set.Set String) + :: DynFlags + -- ^ GHC session dyn flags + -> Map.Map (Maybe String) (Set.Set String) -- ^ Ignored symbols. A map from module names to unqualified names. Module -- 'Just M' mapping to name 'f' means that link warnings should not be -- generated for occurances of specifically 'M.f'. Module 'Nothing' mapping to @@ -58,15 +61,23 @@ renameInterface -- module 'M' if 'M' is the preferred link destination for name 'n'. -> Bool -- ^ Are warnings enabled? + -> Bool + -- ^ Is Hoogle output enabled? -> Interface -- ^ The interface we are renaming. -> Ghc Interface -- ^ The renamed interface. Note that there is nothing really special about -- this being in the 'Ghc' monad. This could very easily be any 'MonadIO' or -- even pure, depending on the link warnings are reported. -renameInterface ignoreSet renamingEnv warnings iface = do +renameInterface dflags ignoreSet renamingEnv warnings hoogle iface = do let (iface', warnedNames) = - runRnM mdl localLinkEnv warnName $ renameInterfaceRn iface + runRnM + dflags + mdl + localLinkEnv + warnName + (hoogle && not (OptHide `elem` ifaceOptions iface)) + (renameInterfaceRn iface) reportMissingLinks mdl warnedNames return iface' where @@ -139,17 +150,29 @@ newtype RnM a = RnM { unRnM :: ReaderT RnMEnv (Writer (Set.Set Name)) a } -- | The renaming monad environment. Stores the linking environment (mapping -- names to modules), the link warning predicate, and the current module. data RnMEnv = RnMEnv - { rnLinkEnv :: LinkEnv + { -- | The linking environment (map from names to modules) + rnLinkEnv :: LinkEnv + + -- | Link warning predicate (whether failing to find a link destination + -- for a given name should result in a warning) , rnWarnName :: (Name -> Bool) + + -- | The current module , rnModuleString :: String + + -- | Should Hoogle output be generated for this module? + , rnHoogleOutput :: Bool + + -- | GHC Session DynFlags, necessary for Hoogle output generation + , rnDynFlags :: DynFlags } -- | Run the renamer action in a renaming environment built using the given -- module, link env, and link warning predicate. Returns the renamed value along -- with a set of 'Name's that were not renamed and should be warned for (i.e. -- they satisfied the link warning predicate). -runRnM :: Module -> LinkEnv -> (Name -> Bool) -> RnM a -> (a, Set.Set Name) -runRnM mdl linkEnv warnName rn = +runRnM :: DynFlags -> Module -> LinkEnv -> (Name -> Bool) -> Bool -> RnM a -> (a, Set.Set Name) +runRnM dflags mdl linkEnv warnName hoogleOutput rn = runWriter $ runReaderT (unRnM rn) rnEnv where rnEnv :: RnMEnv @@ -157,6 +180,8 @@ runRnM mdl linkEnv warnName rn = { rnLinkEnv = linkEnv , rnWarnName = warnName , rnModuleString = moduleString mdl + , rnHoogleOutput = hoogleOutput + , rnDynFlags = dflags } -------------------------------------------------------------------------------- @@ -167,16 +192,18 @@ runRnM mdl linkEnv warnName rn = renameInterfaceRn :: Interface -> RnM Interface renameInterfaceRn iface = do exportItems <- renameExportItems (ifaceExportItems iface) - docMap <- mapM renameDoc (ifaceDocMap iface) - argMap <- mapM (mapM renameDoc) (ifaceArgMap iface) orphans <- mapM renameDocInstance (ifaceOrphanInstances iface) finalModDoc <- renameDocumentation (ifaceDoc iface) pure $! iface { ifaceRnDoc = finalModDoc - , ifaceRnDocMap = docMap - , ifaceRnArgMap = argMap + + -- The un-renamed export items are not used after renaming , ifaceRnExportItems = exportItems + , ifaceExportItems = [] + + -- The un-renamed orphan instances are not used after renaming , ifaceRnOrphanInstances = orphans + , ifaceOrphanInstances = [] } -- | Lookup a 'Name' in the renaming environment. @@ -216,7 +243,15 @@ renameExportItem item = case item of ExportGroup lev id_ doc -> do doc' <- renameDoc doc return (ExportGroup lev id_ doc') - ExportDecl decl pats doc subs instances fixities splice -> do + ExportDecl ed@(ExportD decl pats doc subs instances fixities splice) -> do + -- If Hoogle output should be generated, generate it + RnMEnv{..} <- ask + let hoogleOut = + if rnHoogleOutput then + ppExportD rnDynFlags ed + else + [] + decl' <- renameLDecl decl pats' <- renamePats pats doc' <- renameDocForDecl doc @@ -225,7 +260,12 @@ renameExportItem item = case item of fixities' <- forM fixities $ \(name, fixity) -> do name' <- lookupRn name return (name', fixity) - return (ExportDecl decl' pats' doc' subs' instances' fixities' splice) + + return $ + ExportDecl RnExportD + { rnExpDExpD = ExportD decl' pats' doc' subs' instances' fixities' splice + , rnExpDHoogle = hoogleOut + } ExportNoDecl x subs -> do x' <- lookupRn x subs' <- mapM lookupRn subs diff --git a/haddock-api/src/Haddock/Syb.hs b/haddock-api/src/Haddock/Syb.hs index fc946c8e5ffc4ef549dcdb9d234f09da13b8cb40..e2dc77fb0ba9c5b22208435482c0524c992fac1a 100644 --- a/haddock-api/src/Haddock/Syb.hs +++ b/haddock-api/src/Haddock/Syb.hs @@ -4,15 +4,15 @@ {-# LANGUAGE ScopedTypeVariables #-} module Haddock.Syb - ( everything, everythingButType, everythingWithState - , everywhere, everywhereButType - , mkT, mkQ, extQ - , combine + ( everythingWithState + , everywhereButType + , mkT + , mkQ + , extQ ) where import Data.Data -import Control.Applicative import Data.Maybe import Data.Foldable @@ -21,34 +21,6 @@ import Data.Foldable isType :: forall a b. (Typeable a, Typeable b) => b -> Bool isType _ = isJust $ eqT @a @b --- | Perform a query on each level of a tree. --- --- This is stolen directly from SYB package and copied here to not introduce --- additional dependencies. -everything :: (r -> r -> r) - -> (forall a. Data a => a -> r) - -> (forall a. Data a => a -> r) -everything k f x = foldl' k (f x) (gmapQ (everything k f) x) - --- | Variation of "everything" with an added stop condition --- Just like 'everything', this is stolen from SYB package. -everythingBut :: (r -> r -> r) - -> (forall a. Data a => a -> (r, Bool)) - -> (forall a. Data a => a -> r) -everythingBut k f x = let (v, stop) = f x - in if stop - then v - else foldl' k v (gmapQ (everythingBut k f) x) - --- | Variation of "everything" that does not recurse into children of type t --- requires AllowAmbiguousTypes -everythingButType :: - forall t r. (Typeable t) - => (r -> r -> r) - -> (forall a. Data a => a -> r) - -> (forall a. Data a => a -> r) -everythingButType k f = everythingBut k $ (,) <$> f <*> isType @t - -- | Perform a query with state on each level of a tree. -- -- This is the same as 'everything' but allows for stateful computations. In @@ -61,12 +33,6 @@ everythingWithState s k f x = let (r, s') = f x s in foldl' k r (gmapQ (everythingWithState s' k f) x) --- | Apply transformation on each level of a tree. --- --- Just like 'everything', this is stolen from SYB package. -everywhere :: (forall a. Data a => a -> a) -> (forall a. Data a => a -> a) -everywhere f = f . gmapT (everywhere f) - -- | Variation on everywhere with an extra stop condition -- Just like 'everything', this is stolen from SYB package. everywhereBut :: (forall a. Data a => a -> Bool) @@ -105,9 +71,3 @@ mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r -- Another function stolen from SYB package. extQ :: (Typeable a, Typeable b) => (a -> q) -> (b -> q) -> a -> q extQ f g a = maybe (f a) g (cast a) - --- | Combine two queries into one using alternative combinator. -combine :: Alternative f => (forall a. Data a => a -> f r) - -> (forall a. Data a => a -> f r) - -> (forall a. Data a => a -> f r) -combine f g x = f x <|> g x diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 2d19003e8afc21893999926b6246d49f6b318d3f..9601f0f5c9b66cdd067082e2b0fe905b7376a52c 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -66,7 +66,7 @@ type InstIfaceMap = Map Module InstalledInterface -- TODO: rename type DocMap a = Map Name (MDoc a) type ArgMap a = Map Name (Map Int (MDoc a)) type SubMap = Map Name [Name] -type DeclMap = Map Name [LHsDecl GhcRn] +type DeclMap = Map Name DeclMapEntry type InstMap = Map RealSrcSpan Name type FixMap = Map Name Fixity type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources @@ -109,18 +109,13 @@ data Interface = Interface -- | Declarations originating from the module. Excludes declarations without -- names (instances and stand-alone documentation comments). Includes -- names of subordinate declarations mapped to their parent declarations. - , ifaceDeclMap :: !(Map Name [LHsDecl GhcRn]) + , ifaceDeclMap :: !DeclMap -- | Documentation of declarations originating from the module (including -- subordinates). , ifaceDocMap :: !(DocMap Name) , ifaceArgMap :: !(ArgMap Name) - -- | Documentation of declarations originating from the module (including - -- subordinates). - , ifaceRnDocMap :: !(DocMap DocName) - , ifaceRnArgMap :: !(ArgMap DocName) - , ifaceFixMap :: !(Map Name Fixity) , ifaceExportItems :: [ExportItem GhcRn] @@ -141,7 +136,7 @@ data Interface = Interface , ifaceInstances :: [HaddockClsInst] -- | Orphan instances - , ifaceOrphanInstances :: [DocInstance GhcRn] + , ifaceOrphanInstances :: [DocInstance GhcRn] , ifaceRnOrphanInstances :: [DocInstance DocNameI] -- | The number of haddockable and haddocked items in the module, as a @@ -154,6 +149,7 @@ data Interface = Interface -- | Tokenized source code of module (available if Haddock is invoked with -- source generation flag). , ifaceHieFile :: !(Maybe FilePath) + , ifaceDynFlags :: !DynFlags } @@ -216,32 +212,7 @@ toInstalledIface interface = InstalledInterface data ExportItem name -- | An exported declaration. - = ExportDecl - { - -- | A declaration. - expItemDecl :: !(LHsDecl name) - - -- | Bundled patterns for a data type declaration - , expItemPats :: ![(HsDecl name, DocForDecl (IdP name))] - - -- | Maybe a doc comment, and possibly docs for arguments (if this - -- decl is a function or type-synonym). - , expItemMbDoc :: !(DocForDecl (IdP name)) - - -- | Subordinate names, possibly with documentation. - , expItemSubDocs :: ![(IdP name, DocForDecl (IdP name))] - - -- | Instances relevant to this declaration, possibly with - -- documentation. - , expItemInstances :: ![DocInstance name] - - -- | Fixity decls relevant to this declaration (including subordinates). - , expItemFixities :: ![(IdP name, Fixity)] - - -- | Whether the ExportItem is from a TH splice or not, for generating - -- the appropriate type of Source link. - , expItemSpliced :: !Bool - } + = ExportDecl (XExportDecl name) -- | An exported entity for which we have no documentation (perhaps because it -- resides in another package). @@ -249,7 +220,7 @@ data ExportItem name { expItemName :: !(IdP name) -- | Subordinate names. - , expItemSubs :: ![IdP name] + , expItemSubs :: [IdP name] } -- | A section heading. @@ -271,9 +242,66 @@ data ExportItem name -- | A cross-reference to another module. | ExportModule !Module +-- | A type family mapping a name type index to types of export declarations. +-- The pre-renaming type index ('GhcRn') is mapped to the type of export +-- declarations which do not include Hoogle output ('ExportD'), since Hoogle output is +-- generated during the Haddock renaming step. The post-renaming type index +-- ('DocNameI') is mapped to the type of export declarations which do include +-- Hoogle output ('RnExportD'). +type family XExportDecl x where + XExportDecl GhcRn = ExportD GhcRn + XExportDecl DocNameI = RnExportD + +-- | Represents an export declaration that Haddock has discovered to be exported +-- from a module. The @name@ index indicated whether the declaration has been +-- renamed such that each 'Name' points to it's optimal link destination. +data ExportD name = ExportD + { + -- | A declaration. + expDDecl :: !(LHsDecl name) + + -- | Bundled patterns for a data type declaration + , expDPats :: [(HsDecl name, DocForDecl (IdP name))] + + -- | Maybe a doc comment, and possibly docs for arguments (if this + -- decl is a function or type-synonym). + , expDMbDoc :: !(DocForDecl (IdP name)) + + -- | Subordinate names, possibly with documentation. + , expDSubDocs :: [(IdP name, DocForDecl (IdP name))] + + -- | Instances relevant to this declaration, possibly with + -- documentation. + , expDInstances :: [DocInstance name] + + -- | Fixity decls relevant to this declaration (including subordinates). + , expDFixities :: [(IdP name, Fixity)] + + -- | Whether the ExportD is from a TH splice or not, for generating + -- the appropriate type of Source link. + , expDSpliced :: !Bool + } + +-- | Represents export declarations that have undergone renaming such that every +-- 'Name' in the declaration points to an optimal link destination. Since Hoogle +-- output is also generated during the renaming step, each declaration is also +-- attached to its Hoogle textual database entries, /if/ Hoogle output is +-- enabled and the module is not hidden in the generated documentation using the +-- @{-# OPTIONS_HADDOCK hide #-}@ pragma. +data RnExportD = RnExportD + { + -- | The renamed export declaration + rnExpDExpD :: !(ExportD DocNameI) + + -- | If Hoogle textbase (textual database) output is enabled, the text + -- output lines for this declaration. If Hoogle output is not enabled, the + -- list will be empty. + , rnExpDHoogle :: [String] + } + data Documentation name = Documentation - { documentationDoc :: Maybe (MDoc name) - , documentationWarning :: !(Maybe (Doc name)) + { documentationDoc :: Maybe (MDoc name) + , documentationWarning :: Maybe (Doc name) } deriving Functor -- | Arguments and result are indexed by Int, zero-based from the left, @@ -284,6 +312,32 @@ type DocForDecl name = (Documentation name, FnArgsDoc name) noDocForDecl :: DocForDecl name noDocForDecl = (Documentation Nothing Nothing, mempty) +-- | As we build the declaration map, we really only care to track whether we +-- have only seen a value declaration for a 'Name', or anything else. This type +-- is used to represent those cases. If the only declaration attached to a +-- 'Name' is a 'ValD', we will consult the GHC interface file to determine the +-- type of the value, and attach the 'SrcSpan' from the 'EValD' constructor to +-- it. If we see any other type of declaration for the 'Name', we can just use +-- it. +-- +-- This type saves us from storing /every/ declaration we see for a given 'Name' +-- in the map, which is unnecessary and very problematic for overall memory +-- usage. +data DeclMapEntry + = EValD !SrcSpan + | EOther (LHsDecl GhcRn) + +instance Semigroup DeclMapEntry where + (EValD _) <> e = e + e <> _ = e + +-- | Transform a declaration into a 'DeclMapEntry'. If it is a 'ValD' +-- declaration, only the source location will be noted (since that is all we +-- care to store in the 'DeclMap' due to the way top-level bindings with no type +-- signatures are handled). Otherwise, the entire declaration will be kept. +toDeclMapEntry :: LHsDecl GhcRn -> DeclMapEntry +toDeclMapEntry (L l (ValD _ _)) = EValD (locA l) +toDeclMapEntry d = EOther d ----------------------------------------------------------------------------- -- * Cross-referencing