From f035633fbd427977a68c3145d2ed7547ba2cbe43 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Sun, 29 May 2022 06:19:05 +0200 Subject: [PATCH] Support --haddock-html-location By passing `--haddock-html-location` one can link to haddocks to documentation published on hackage. However one can use it or `--base-url`. The latter will build self contained directory of haddock documentation. --- Cabal/src/Distribution/Simple/Setup.hs | 7 ++ .../src/Distribution/Client/CmdHaddockProject.hs | 98 +++++++++++++--------- 2 files changed, 64 insertions(+), 41 deletions(-) diff --git a/Cabal/src/Distribution/Simple/Setup.hs b/Cabal/src/Distribution/Simple/Setup.hs index 8e454a74e..b95867757 100644 --- a/Cabal/src/Distribution/Simple/Setup.hs +++ b/Cabal/src/Distribution/Simple/Setup.hs @@ -1600,6 +1600,7 @@ data HaddockProjectFlags = HaddockProjectFlags { haddockProjectProgramArgs :: [(String, [String])], haddockProjectHoogle :: Flag Bool, -- haddockHtml is not supported + haddockProjectHtmlLocation :: Flag String, -- haddockForHackage is not supported haddockProjectExecutables :: Flag Bool, haddockProjectTestSuites :: Flag Bool, @@ -1630,6 +1631,7 @@ defaultHaddockProjectFlags = HaddockProjectFlags { haddockProjectProgramPaths = mempty, haddockProjectProgramArgs = mempty, haddockProjectHoogle = Flag False, + haddockProjectHtmlLocation = NoFlag, haddockProjectExecutables = Flag False, haddockProjectBenchmarks = Flag False, haddockProjectForeignLibs = Flag False, @@ -1697,6 +1699,11 @@ haddockProjectOptions _showOrParseArgs = haddockProjectHoogle (\v flags -> flags { haddockProjectHoogle = v }) trueArg + ,option "" ["html-location"] + "Location of HTML documentation for pre-requisite packages" + haddockProjectHtmlLocation (\v flags -> flags { haddockProjectHtmlLocation = v }) + (reqArgFlag "URL") + ,option "" ["executables"] "Run haddock for Executables targets" haddockProjectExecutables (\v flags -> flags { haddockProjectExecutables = v }) diff --git a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs index cab0e9bf7..469c71ac0 100644 --- a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs +++ b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs @@ -80,9 +80,12 @@ haddockProjectAction flags _extraArgs globalFlags = do -- build all packages with appropriate haddock flags let haddockFlags = defaultHaddockFlags { haddockHtml = Flag True - , haddockBaseUrl = Flag ".." + -- one can either use `--haddock-base-url` or + -- `--haddock-html-location`. + , haddockBaseUrl = if localStyle then Flag ".." else NoFlag , haddockProgramPaths = haddockProjectProgramPaths flags , haddockProgramArgs = haddockProjectProgramArgs flags + , haddockHtmlLocation = haddockProjectHtmlLocation flags , haddockHoogle = haddockProjectHoogle flags , haddockExecutables = haddockProjectExecutables flags , haddockTestSuites = haddockProjectTestSuites flags @@ -93,8 +96,10 @@ haddockProjectAction flags _extraArgs globalFlags = do , haddockLinkedSource = haddockProjectLinkedSource flags , haddockQuickJump = haddockProjectQuickJump flags , haddockHscolourCss = haddockProjectHscolourCss flags - , haddockContents = Flag (toPathTemplate "../index.html") - , haddockIndex = Flag (toPathTemplate "../doc-index.html") + , haddockContents = if localStyle then Flag (toPathTemplate "../index.html") + else NoFlag + , haddockIndex = if localStyle then Flag (toPathTemplate "../doc-index.html") + else NoFlag , haddockKeepTempFiles= haddockProjectKeepTempFiles flags , haddockVerbosity = haddockProjectVerbosity flags , haddockLib = haddockProjectLib flags @@ -159,6 +164,8 @@ haddockProjectAction flags _extraArgs globalFlags = do packageInfos <- fmap (nub . concat) $ for pkgs $ \pkg -> case pkg of + Left _ | not localStyle -> + return [] Left package -> do let packageName = unPackageName (pkgName $ sourcePackageId package) destDir = outputDir packageName @@ -174,44 +181,46 @@ haddockProjectAction flags _extraArgs globalFlags = do False -> return Nothing Right package -> - if elabLocalToProject package - then do - let distDirParams = elabDistDirParams sharedConfig' package - buildDir = distBuildDirectory distLayout distDirParams - packageName = unPackageName (pkgName $ elabPkgSourceId package) - let docDir = buildDir - "doc" "html" - packageName - destDir = outputDir packageName - interfacePath = destDir - packageName <.> "haddock" - a <- doesDirectoryExist docDir - case a of - True -> copyDirectoryRecursive verbosity docDir destDir - >> return [( packageName - , interfacePath - , Visible - )] - False -> return [] - else do - let packageName = unPackageName (pkgName $ elabPkgSourceId package) - packageDir = storePackageDirectory (cabalStoreDirLayout cabalLayout) - (compilerId (pkgConfigCompiler sharedConfig')) - (elabUnitId package) - docDir = packageDir "share" "doc" "html" - destDir = outputDir packageName - interfacePath = destDir - packageName <.> "haddock" - a <- doesDirectoryExist docDir - case a of - True -> copyDirectoryRecursive verbosity docDir destDir - -- non local packages will be hidden in haddock's - -- generated contents page - >> return [( packageName - , interfacePath - , Hidden - )] - False -> return [] + case elabLocalToProject package of + True -> do + let distDirParams = elabDistDirParams sharedConfig' package + buildDir = distBuildDirectory distLayout distDirParams + packageName = unPackageName (pkgName $ elabPkgSourceId package) + let docDir = buildDir + "doc" "html" + packageName + destDir = outputDir packageName + interfacePath = destDir + packageName <.> "haddock" + a <- doesDirectoryExist docDir + case a of + True -> copyDirectoryRecursive verbosity docDir destDir + >> return [( packageName + , interfacePath + , Visible + )] + False -> return [] + False | not localStyle -> + return [] + False -> do + let packageName = unPackageName (pkgName $ elabPkgSourceId package) + packageDir = storePackageDirectory (cabalStoreDirLayout cabalLayout) + (compilerId (pkgConfigCompiler sharedConfig')) + (elabUnitId package) + docDir = packageDir "share" "doc" "html" + destDir = outputDir packageName + interfacePath = destDir + packageName <.> "haddock" + a <- doesDirectoryExist docDir + case a of + True -> copyDirectoryRecursive verbosity docDir destDir + -- non local packages will be hidden in haddock's + -- generated contents page + >> return [( packageName + , interfacePath + , Hidden + )] + False -> return [] -- run haddock to generate index, content, etc. let flags' = flags @@ -233,6 +242,13 @@ haddockProjectAction flags _extraArgs globalFlags = do where verbosity = fromFlagOrDefault normal (haddockProjectVerbosity flags) + -- Build a self contained directory which contains haddocks of all + -- transitive dependencies; or depend on `--haddocks-html-location` to + -- provide location of the documentation of dependencies. + localStyle = case haddockProjectHtmlLocation flags of + NoFlag -> True + Flag _ -> False + reportTargetProblems :: Show x => [x] -> IO a reportTargetProblems = die' verbosity . unlines . map show -- 2.11.4.GIT