hackport-0.9.0.0: cabal/cabal-install/src/Distribution/Client/CmdHaddockProject.hs
module Distribution.Client.CmdHaddockProject
( haddockProjectCommand
, haddockProjectAction
) where
import Prelude ()
import Distribution.Client.Compat.Prelude hiding (get)
import qualified Distribution.Client.CmdBuild as CmdBuild
import qualified Distribution.Client.CmdHaddock as CmdHaddock
import Distribution.Client.DistDirLayout (DistDirLayout(..)
,CabalDirLayout(..)
,StoreDirLayout(..))
import Distribution.Client.InstallPlan (foldPlanPackage)
import qualified Distribution.Client.InstallPlan as InstallPlan
import qualified Distribution.Client.NixStyleOptions as NixStyleOptions
import Distribution.Client.ProjectOrchestration
(AvailableTarget(..)
,AvailableTargetStatus(..)
,CurrentCommand(..)
,ProjectBaseContext(..)
,ProjectBuildContext(..)
,TargetSelector(..)
,printPlan
,pruneInstallPlanToTargets
,resolveTargets
,runProjectPreBuildPhase
,selectComponentTargetBasic)
import Distribution.Client.ProjectPlanning (ElaboratedConfiguredPackage(..)
,ElaboratedInstallPlan
,ElaboratedSharedConfig(..)
,TargetAction(..))
import Distribution.Client.ProjectPlanning.Types
(elabDistDirParams)
import Distribution.Client.Setup (GlobalFlags(..)
,ConfigFlags(..))
import Distribution.Client.ScriptUtils (AcceptNoTargets(..)
,TargetContext(..)
,updateContextAndWriteProjectFile
,withContextAndSelectors)
import Distribution.Client.TargetProblem (TargetProblem(..))
import Distribution.Types.PackageId (pkgName)
import Distribution.Types.PackageName (unPackageName)
import Distribution.Types.UnitId (unUnitId)
import Distribution.Types.Version (mkVersion)
import Distribution.Types.VersionRange (orLaterVersion)
import Distribution.Types.InstalledPackageInfo (InstalledPackageInfo (..))
import Distribution.Simple.Command
( CommandUI(..) )
import Distribution.Simple.Compiler
( Compiler (..) )
import Distribution.Simple.Flag
( Flag(..)
, fromFlag
, fromFlagOrDefault
)
import Distribution.Simple.InstallDirs
( toPathTemplate )
import Distribution.Simple.Haddock (createHaddockIndex)
import Distribution.Simple.Utils
( die', createDirectoryIfMissingVerbose
, copyDirectoryRecursive, warn )
import Distribution.Simple.Program.Builtin
( haddockProgram )
import Distribution.Simple.Program.Db
( addKnownProgram, reconfigurePrograms, requireProgramVersion )
import Distribution.Simple.Setup
( HaddockFlags(..), defaultHaddockFlags
, HaddockProjectFlags(..)
, Visibility(..)
, haddockProjectCommand
)
import Distribution.Verbosity as Verbosity
( normal )
import System.FilePath ( takeDirectory, normalise, (</>), (<.>) )
import System.Directory ( doesDirectoryExist, doesFileExist )
haddockProjectAction :: HaddockProjectFlags -> [String] -> GlobalFlags -> IO ()
haddockProjectAction flags _extraArgs globalFlags = do
-- create destination directory if it does not exist
let outputDir = normalise $ fromFlag (haddockProjectDir flags)
createDirectoryIfMissingVerbose verbosity True outputDir
warn verbosity "haddock-project command is experimental, it might break in the future"
-- build all packages with appropriate haddock flags
let haddockFlags = defaultHaddockFlags
{ haddockHtml = Flag True
-- 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 = if fromFlagOrDefault False (haddockProjectHackage flags)
then Flag "https://hackage.haskell.org/package/$pkg-$version/docs"
else haddockProjectHtmlLocation flags
, haddockHoogle = haddockProjectHoogle flags
, haddockExecutables = haddockProjectExecutables flags
, haddockTestSuites = haddockProjectTestSuites flags
, haddockBenchmarks = haddockProjectBenchmarks flags
, haddockForeignLibs = haddockProjectForeignLibs flags
, haddockInternal = haddockProjectInternal flags
, haddockCss = haddockProjectCss flags
, haddockLinkedSource = Flag True
, haddockQuickJump = Flag True
, haddockHscolourCss = haddockProjectHscolourCss flags
, 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
}
nixFlags = (commandDefaultFlags CmdHaddock.haddockCommand)
{ NixStyleOptions.haddockFlags = haddockFlags
, NixStyleOptions.configFlags =
(NixStyleOptions.configFlags (commandDefaultFlags CmdBuild.buildCommand))
{ configVerbosity = haddockProjectVerbosity flags }
}
--
-- Construct the build plan and infer the list of packages which haddocks
-- we need.
--
withContextAndSelectors RejectNoTargets Nothing (commandDefaultFlags CmdBuild.buildCommand) ["all"] globalFlags HaddockCommand $ \targetCtx ctx targetSelectors -> do
baseCtx <- case targetCtx of
ProjectContext -> return ctx
GlobalContext -> return ctx
ScriptContext path exemeta -> updateContextAndWriteProjectFile ctx path exemeta
let distLayout = distDirLayout baseCtx
cabalLayout = cabalDirLayout baseCtx
buildCtx <-
runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
-- Interpret the targets on the command line as build targets
-- (as opposed to say repl or haddock targets).
targets <- either reportTargetProblems return
$ resolveTargets
selectPackageTargets
selectComponentTargetBasic
elaboratedPlan
Nothing
targetSelectors
let elaboratedPlan' = pruneInstallPlanToTargets
TargetActionBuild
targets
elaboratedPlan
return (elaboratedPlan', targets)
printPlan verbosity baseCtx buildCtx
let elaboratedPlan :: ElaboratedInstallPlan
elaboratedPlan = elaboratedPlanOriginal buildCtx
sharedConfig :: ElaboratedSharedConfig
sharedConfig = elaboratedShared buildCtx
pkgs :: [Either InstalledPackageInfo ElaboratedConfiguredPackage ]
pkgs = matchingPackages elaboratedPlan
progs <- reconfigurePrograms verbosity
(haddockProjectProgramPaths flags)
(haddockProjectProgramArgs flags)
-- we need to insert 'haddockProgram' before we reconfigure it,
-- otherwise 'set
. addKnownProgram haddockProgram
. pkgConfigCompilerProgs
$ sharedConfig
let sharedConfig' = sharedConfig { pkgConfigCompilerProgs = progs }
_ <- requireProgramVersion
verbosity haddockProgram
(orLaterVersion (mkVersion [2,26,1])) progs
--
-- Build project; we need to build dependencies.
-- Issue #8958.
--
when localStyle $
CmdBuild.buildAction
(commandDefaultFlags CmdBuild.buildCommand)
["all"]
globalFlags
--
-- Build haddocks of each components
--
CmdHaddock.haddockAction
nixFlags
["all"]
globalFlags
--
-- Copy haddocks to the destination folder
--
packageInfos <- fmap (nub . concat) $ for pkgs $ \pkg ->
case pkg of
Left _ | not localStyle ->
return []
Left package -> do
-- TODO: this might not work for public packages with sublibraries.
-- Issue #9026.
let packageName = unPackageName (pkgName $ sourcePackageId package)
destDir = outputDir </> packageName
fmap catMaybes $ for (haddockInterfaces package) $ \interfacePath -> do
let docDir = takeDirectory interfacePath
a <- doesFileExist interfacePath
case a of
True -> copyDirectoryRecursive verbosity docDir destDir
>> return (Just ( packageName
, interfacePath
, Hidden
))
False -> return Nothing
Right package ->
case elabLocalToProject package of
True -> do
let distDirParams = elabDistDirParams sharedConfig' package
unitId = unUnitId (elabUnitId package)
buildDir = distBuildDirectory distLayout distDirParams
packageName = unPackageName (pkgName $ elabPkgSourceId package)
let docDir = buildDir
</> "doc" </> "html"
</> packageName
destDir = outputDir </> unitId
interfacePath = destDir
</> packageName <.> "haddock"
a <- doesDirectoryExist docDir
case a of
True -> copyDirectoryRecursive verbosity docDir destDir
>> return [( packageName
, interfacePath
, Visible
)]
False -> do
warn verbosity
("haddocks of "
++ show unitId
++ " not found in the store")
return []
False | not localStyle ->
return []
False -> do
let packageName = unPackageName (pkgName $ elabPkgSourceId package)
unitId = unUnitId (elabUnitId 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 [( unitId
, interfacePath
, Hidden
)]
False -> do
warn verbosity
("haddocks of "
++ show unitId
++ " not found in the store")
return []
--
-- generate index, content, etc.
--
let flags' = flags
{ haddockProjectDir = Flag outputDir
, haddockProjectInterfaces = Flag
[ ( interfacePath
, Just name
, Just name
, visibility
)
| (name, interfacePath, visibility) <- packageInfos
]
}
createHaddockIndex verbosity
(pkgConfigCompilerProgs sharedConfig')
(pkgConfigCompiler sharedConfig')
(pkgConfigPlatform sharedConfig')
flags'
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 =
let hackage = fromFlagOrDefault False (haddockProjectHackage flags)
location = fromFlagOrDefault False (const True <$> haddockProjectHtmlLocation flags)
in not hackage && not location
reportTargetProblems :: Show x => [x] -> IO a
reportTargetProblems =
die' verbosity . unlines . map show
-- TODO: this is just a sketch
selectPackageTargets :: TargetSelector
-> [AvailableTarget k]
-> Either (TargetProblem ()) [k]
selectPackageTargets _ ts = Right $
mapMaybe
(\t -> case availableTargetStatus t of
TargetBuildable k _ | availableTargetLocalToProject t
-> Just k
_ -> Nothing)
ts
matchingPackages :: ElaboratedInstallPlan
-> [Either InstalledPackageInfo ElaboratedConfiguredPackage]
matchingPackages =
fmap (foldPlanPackage Left Right)
. InstallPlan.toList