module Distribution.Client.CmdHaddockProject
  ( haddockProjectCommand
  , haddockProjectAction
  ) where

import Control.Monad (mapM)
import Distribution.Client.Compat.Prelude hiding (get)
import Prelude ()

import qualified Distribution.Client.CmdBuild as CmdBuild
import qualified Distribution.Client.CmdHaddock as CmdHaddock

import Distribution.Client.DistDirLayout
  ( CabalDirLayout (..)
  , StoreDirLayout (..)
  , distBuildDirectory
  )
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 (..)
  , pruneInstallPlanToTargets
  , resolveTargets
  , runProjectPreBuildPhase
  , selectComponentTargetBasic
  )
import Distribution.Client.ProjectPlanning
  ( ElaboratedConfiguredPackage (..)
  , ElaboratedInstallPlan
  , ElaboratedSharedConfig (..)
  , TargetAction (..)
  )
import Distribution.Client.ProjectPlanning.Types
  ( elabDistDirParams
  )
import Distribution.Client.ScriptUtils
  ( AcceptNoTargets (..)
  , TargetContext (..)
  , updateContextAndWriteProjectFile
  , withContextAndSelectors
  )
import Distribution.Client.Setup
  ( CommonSetupFlags (setupVerbosity)
  , ConfigFlags (..)
  , GlobalFlags (..)
  )
import Distribution.Client.TargetProblem (TargetProblem (..))

import Distribution.Simple.BuildPaths
  ( haddockBenchmarkDirPath
  , haddockDirName
  , haddockLibraryDirPath
  , haddockLibraryPath
  , haddockPath
  , haddockTestDirPath
  )
import Distribution.Simple.Command
  ( CommandUI (..)
  )
import Distribution.Simple.Flag
  ( Flag (..)
  , fromFlag
  , fromFlagOrDefault
  )
import Distribution.Simple.Haddock (createHaddockIndex)
import Distribution.Simple.InstallDirs
  ( toPathTemplate
  )
import Distribution.Simple.Program.Builtin
  ( haddockProgram
  )
import Distribution.Simple.Program.Db
  ( addKnownProgram
  , reconfigurePrograms
  , requireProgramVersion
  )
import Distribution.Simple.Setup
  ( HaddockFlags (..)
  , HaddockProjectFlags (..)
  , HaddockTarget (..)
  , Visibility (..)
  , defaultCommonSetupFlags
  , defaultHaddockFlags
  , haddockProjectCommand
  )
import Distribution.Simple.Utils
  ( copyDirectoryRecursive
  , createDirectoryIfMissingVerbose
  , dieWithException
  , info
  , warn
  )
import Distribution.Types.InstalledPackageInfo (InstalledPackageInfo (..))
import Distribution.Types.PackageDescription (PackageDescription (benchmarks, subLibraries, testSuites))
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.Verbosity as Verbosity
  ( normal
  )

import Distribution.Client.Errors
import System.Directory (doesDirectoryExist, doesFileExist)
import System.FilePath (normalise, takeDirectory, (</>))

haddockProjectAction :: HaddockProjectFlags -> [String] -> GlobalFlags -> IO ()
haddockProjectAction :: HaddockProjectFlags -> [FilePath] -> GlobalFlags -> IO ()
haddockProjectAction HaddockProjectFlags
flags [FilePath]
_extraArgs GlobalFlags
globalFlags = do
  -- create destination directory if it does not exist
  let outputDir :: FilePath
outputDir = FilePath -> FilePath
normalise (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ Flag FilePath -> FilePath
forall a. WithCallStack (Flag a -> a)
fromFlag (HaddockProjectFlags -> Flag FilePath
haddockProjectDir HaddockProjectFlags
flags)
  Verbosity -> Bool -> FilePath -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True FilePath
outputDir

  Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity FilePath
"haddock-project command is experimental, it might break in the future"

  -- build all packages with appropriate haddock flags
  let commonFlags :: CommonSetupFlags
commonFlags =
        CommonSetupFlags
defaultCommonSetupFlags
          { setupVerbosity = haddockProjectVerbosity flags
          }
      haddockFlags :: HaddockFlags
haddockFlags =
        HaddockFlags
defaultHaddockFlags
          { haddockCommonFlags = commonFlags
          , 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
          , haddockResourcesDir = haddockProjectResourcesDir flags
          , haddockUseUnicode = haddockProjectUseUnicode flags
          -- NOTE: we don't pass `haddockOutputDir`. If we do, we'll need to
          -- make sure `InstalledPackageInfo` contains the right path to
          -- haddock interfaces.  Instead we build documentation inside
          -- `dist-newstyle` directory and copy it to the output directory.
          }
      nixFlags :: NixStyleFlags ClientHaddockFlags
nixFlags =
        (CommandUI (NixStyleFlags ClientHaddockFlags)
-> NixStyleFlags ClientHaddockFlags
forall flags. CommandUI flags -> flags
commandDefaultFlags CommandUI (NixStyleFlags ClientHaddockFlags)
CmdHaddock.haddockCommand)
          { NixStyleOptions.haddockFlags = haddockFlags
          , NixStyleOptions.configFlags =
              (NixStyleOptions.configFlags (commandDefaultFlags CmdBuild.buildCommand))
                { configCommonFlags = commonFlags
                }
          }

  --
  -- Construct the build plan and infer the list of packages which haddocks
  -- we need.
  --

  AcceptNoTargets
-> Maybe ComponentKind
-> NixStyleFlags BuildFlags
-> [FilePath]
-> GlobalFlags
-> CurrentCommand
-> (TargetContext
    -> ProjectBaseContext -> [TargetSelector] -> IO ())
-> IO ()
forall a b.
AcceptNoTargets
-> Maybe ComponentKind
-> NixStyleFlags a
-> [FilePath]
-> GlobalFlags
-> CurrentCommand
-> (TargetContext
    -> ProjectBaseContext -> [TargetSelector] -> IO b)
-> IO b
withContextAndSelectors
    AcceptNoTargets
RejectNoTargets
    Maybe ComponentKind
forall a. Maybe a
Nothing
    (CommandUI (NixStyleFlags BuildFlags) -> NixStyleFlags BuildFlags
forall flags. CommandUI flags -> flags
commandDefaultFlags CommandUI (NixStyleFlags BuildFlags)
CmdBuild.buildCommand)
    [FilePath
"all"]
    GlobalFlags
globalFlags
    CurrentCommand
HaddockCommand
    ((TargetContext -> ProjectBaseContext -> [TargetSelector] -> IO ())
 -> IO ())
-> (TargetContext
    -> ProjectBaseContext -> [TargetSelector] -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \TargetContext
targetCtx ProjectBaseContext
ctx [TargetSelector]
targetSelectors -> do
      ProjectBaseContext
baseCtx <- case TargetContext
targetCtx of
        TargetContext
ProjectContext -> ProjectBaseContext -> IO ProjectBaseContext
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ProjectBaseContext
ctx
        TargetContext
GlobalContext -> ProjectBaseContext -> IO ProjectBaseContext
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ProjectBaseContext
ctx
        ScriptContext FilePath
path Executable
exemeta -> ProjectBaseContext
-> FilePath -> Executable -> IO ProjectBaseContext
updateContextAndWriteProjectFile ProjectBaseContext
ctx FilePath
path Executable
exemeta
      let distLayout :: DistDirLayout
distLayout = ProjectBaseContext -> DistDirLayout
distDirLayout ProjectBaseContext
baseCtx
          cabalLayout :: CabalDirLayout
cabalLayout = ProjectBaseContext -> CabalDirLayout
cabalDirLayout ProjectBaseContext
baseCtx
      ProjectBuildContext
buildCtx <-
        Verbosity
-> ProjectBaseContext
-> (ElaboratedInstallPlan
    -> IO (ElaboratedInstallPlan, TargetsMap))
-> IO ProjectBuildContext
runProjectPreBuildPhase Verbosity
verbosity ProjectBaseContext
baseCtx ((ElaboratedInstallPlan -> IO (ElaboratedInstallPlan, TargetsMap))
 -> IO ProjectBuildContext)
-> (ElaboratedInstallPlan
    -> IO (ElaboratedInstallPlan, TargetsMap))
-> IO ProjectBuildContext
forall a b. (a -> b) -> a -> b
$ \ElaboratedInstallPlan
elaboratedPlan -> do
          -- Interpret the targets on the command line as build targets
          -- (as opposed to say repl or haddock targets).
          TargetsMap
targets <-
            ([TargetProblem ()] -> IO TargetsMap)
-> (TargetsMap -> IO TargetsMap)
-> Either [TargetProblem ()] TargetsMap
-> IO TargetsMap
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [TargetProblem ()] -> IO TargetsMap
forall x a. Show x => [x] -> IO a
reportTargetProblems TargetsMap -> IO TargetsMap
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [TargetProblem ()] TargetsMap -> IO TargetsMap)
-> Either [TargetProblem ()] TargetsMap -> IO TargetsMap
forall a b. (a -> b) -> a -> b
$
              (forall k.
 TargetSelector
 -> [AvailableTarget k] -> Either (TargetProblem ()) [k])
-> (forall k.
    SubComponentTarget
    -> AvailableTarget k -> Either (TargetProblem ()) k)
-> ElaboratedInstallPlan
-> Maybe SourcePackageDb
-> [TargetSelector]
-> Either [TargetProblem ()] TargetsMap
forall err.
(forall k.
 TargetSelector
 -> [AvailableTarget k] -> Either (TargetProblem err) [k])
-> (forall k.
    SubComponentTarget
    -> AvailableTarget k -> Either (TargetProblem err) k)
-> ElaboratedInstallPlan
-> Maybe SourcePackageDb
-> [TargetSelector]
-> Either [TargetProblem err] TargetsMap
resolveTargets
                TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem ()) [k]
forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem ()) [k]
selectPackageTargets
                SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem ()) k
forall k.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem ()) k
forall k a.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem a) k
selectComponentTargetBasic
                ElaboratedInstallPlan
elaboratedPlan
                Maybe SourcePackageDb
forall a. Maybe a
Nothing
                [TargetSelector]
targetSelectors

          let elaboratedPlan' :: ElaboratedInstallPlan
elaboratedPlan' =
                TargetAction
-> TargetsMap -> ElaboratedInstallPlan -> ElaboratedInstallPlan
pruneInstallPlanToTargets
                  TargetAction
TargetActionBuild
                  TargetsMap
targets
                  ElaboratedInstallPlan
elaboratedPlan
          (ElaboratedInstallPlan, TargetsMap)
-> IO (ElaboratedInstallPlan, TargetsMap)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ElaboratedInstallPlan
elaboratedPlan', TargetsMap
targets)

      let elaboratedPlan :: ElaboratedInstallPlan
          elaboratedPlan :: ElaboratedInstallPlan
elaboratedPlan = ProjectBuildContext -> ElaboratedInstallPlan
elaboratedPlanOriginal ProjectBuildContext
buildCtx

          sharedConfig :: ElaboratedSharedConfig
          sharedConfig :: ElaboratedSharedConfig
sharedConfig = ProjectBuildContext -> ElaboratedSharedConfig
elaboratedShared ProjectBuildContext
buildCtx

          pkgs :: [Either InstalledPackageInfo ElaboratedConfiguredPackage]
          pkgs :: [Either InstalledPackageInfo ElaboratedConfiguredPackage]
pkgs = ElaboratedInstallPlan
-> [Either InstalledPackageInfo ElaboratedConfiguredPackage]
matchingPackages ElaboratedInstallPlan
elaboratedPlan

      ProgramDb
progs <-
        Verbosity
-> [(FilePath, FilePath)]
-> [(FilePath, [FilePath])]
-> ProgramDb
-> IO ProgramDb
reconfigurePrograms
          Verbosity
verbosity
          (HaddockProjectFlags -> [(FilePath, FilePath)]
haddockProjectProgramPaths HaddockProjectFlags
flags)
          (HaddockProjectFlags -> [(FilePath, [FilePath])]
haddockProjectProgramArgs HaddockProjectFlags
flags)
          -- we need to insert 'haddockProgram' before we reconfigure it,
          -- otherwise 'set
          (ProgramDb -> IO ProgramDb)
-> (ElaboratedSharedConfig -> ProgramDb)
-> ElaboratedSharedConfig
-> IO ProgramDb
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Program -> ProgramDb -> ProgramDb
addKnownProgram Program
haddockProgram
          (ProgramDb -> ProgramDb)
-> (ElaboratedSharedConfig -> ProgramDb)
-> ElaboratedSharedConfig
-> ProgramDb
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ElaboratedSharedConfig -> ProgramDb
pkgConfigCompilerProgs
          (ElaboratedSharedConfig -> IO ProgramDb)
-> ElaboratedSharedConfig -> IO ProgramDb
forall a b. (a -> b) -> a -> b
$ ElaboratedSharedConfig
sharedConfig
      let sharedConfig' :: ElaboratedSharedConfig
sharedConfig' = ElaboratedSharedConfig
sharedConfig{pkgConfigCompilerProgs = progs}

      (ConfiguredProgram, Version, ProgramDb)
_ <-
        Verbosity
-> Program
-> VersionRange
-> ProgramDb
-> IO (ConfiguredProgram, Version, ProgramDb)
requireProgramVersion
          Verbosity
verbosity
          Program
haddockProgram
          (Version -> VersionRange
orLaterVersion ([Int] -> Version
mkVersion [Int
2, Int
26, Int
1]))
          ProgramDb
progs

      --
      -- Build project; we need to build dependencies.
      -- Issue #8958.
      --

      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
localStyle (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        NixStyleFlags BuildFlags -> [FilePath] -> GlobalFlags -> IO ()
CmdBuild.buildAction
          (CommandUI (NixStyleFlags BuildFlags) -> NixStyleFlags BuildFlags
forall flags. CommandUI flags -> flags
commandDefaultFlags CommandUI (NixStyleFlags BuildFlags)
CmdBuild.buildCommand)
          [FilePath
"all"]
          GlobalFlags
globalFlags

      --
      -- Build haddocks of each components
      --

      NixStyleFlags ClientHaddockFlags
-> [FilePath] -> GlobalFlags -> IO ()
CmdHaddock.haddockAction
        NixStyleFlags ClientHaddockFlags
nixFlags
        [FilePath
"all"]
        GlobalFlags
globalFlags

      --
      -- Copy haddocks to the destination folder
      --

      [Either FilePath (FilePath, FilePath, Visibility)]
packageInfos <- ([[Either FilePath (FilePath, FilePath, Visibility)]]
 -> [Either FilePath (FilePath, FilePath, Visibility)])
-> IO [[Either FilePath (FilePath, FilePath, Visibility)]]
-> IO [Either FilePath (FilePath, FilePath, Visibility)]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Either FilePath (FilePath, FilePath, Visibility)]
-> [Either FilePath (FilePath, FilePath, Visibility)]
forall a. Eq a => [a] -> [a]
nub ([Either FilePath (FilePath, FilePath, Visibility)]
 -> [Either FilePath (FilePath, FilePath, Visibility)])
-> ([[Either FilePath (FilePath, FilePath, Visibility)]]
    -> [Either FilePath (FilePath, FilePath, Visibility)])
-> [[Either FilePath (FilePath, FilePath, Visibility)]]
-> [Either FilePath (FilePath, FilePath, Visibility)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Either FilePath (FilePath, FilePath, Visibility)]]
-> [Either FilePath (FilePath, FilePath, Visibility)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) (IO [[Either FilePath (FilePath, FilePath, Visibility)]]
 -> IO [Either FilePath (FilePath, FilePath, Visibility)])
-> IO [[Either FilePath (FilePath, FilePath, Visibility)]]
-> IO [Either FilePath (FilePath, FilePath, Visibility)]
forall a b. (a -> b) -> a -> b
$ [Either InstalledPackageInfo ElaboratedConfiguredPackage]
-> (Either InstalledPackageInfo ElaboratedConfiguredPackage
    -> IO [Either FilePath (FilePath, FilePath, Visibility)])
-> IO [[Either FilePath (FilePath, FilePath, Visibility)]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Either InstalledPackageInfo ElaboratedConfiguredPackage]
pkgs ((Either InstalledPackageInfo ElaboratedConfiguredPackage
  -> IO [Either FilePath (FilePath, FilePath, Visibility)])
 -> IO [[Either FilePath (FilePath, FilePath, Visibility)]])
-> (Either InstalledPackageInfo ElaboratedConfiguredPackage
    -> IO [Either FilePath (FilePath, FilePath, Visibility)])
-> IO [[Either FilePath (FilePath, FilePath, Visibility)]]
forall a b. (a -> b) -> a -> b
$ \Either InstalledPackageInfo ElaboratedConfiguredPackage
pkg ->
        case Either InstalledPackageInfo ElaboratedConfiguredPackage
pkg of
          Left InstalledPackageInfo
package | Bool
localStyle -> do
            let packageName :: FilePath
packageName = PackageName -> FilePath
unPackageName (PackageIdentifier -> PackageName
pkgName (PackageIdentifier -> PackageName)
-> PackageIdentifier -> PackageName
forall a b. (a -> b) -> a -> b
$ InstalledPackageInfo -> PackageIdentifier
sourcePackageId InstalledPackageInfo
package)
                destDir :: FilePath
destDir = FilePath
outputDir FilePath -> FilePath -> FilePath
</> FilePath
packageName
            ([Maybe (Either FilePath (FilePath, FilePath, Visibility))]
 -> [Either FilePath (FilePath, FilePath, Visibility)])
-> IO [Maybe (Either FilePath (FilePath, FilePath, Visibility))]
-> IO [Either FilePath (FilePath, FilePath, Visibility)]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe (Either FilePath (FilePath, FilePath, Visibility))]
-> [Either FilePath (FilePath, FilePath, Visibility)]
forall a. [Maybe a] -> [a]
catMaybes (IO [Maybe (Either FilePath (FilePath, FilePath, Visibility))]
 -> IO [Either FilePath (FilePath, FilePath, Visibility)])
-> IO [Maybe (Either FilePath (FilePath, FilePath, Visibility))]
-> IO [Either FilePath (FilePath, FilePath, Visibility)]
forall a b. (a -> b) -> a -> b
$ [FilePath]
-> (FilePath
    -> IO (Maybe (Either FilePath (FilePath, FilePath, Visibility))))
-> IO [Maybe (Either FilePath (FilePath, FilePath, Visibility))]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (InstalledPackageInfo -> [FilePath]
haddockInterfaces InstalledPackageInfo
package) ((FilePath
  -> IO (Maybe (Either FilePath (FilePath, FilePath, Visibility))))
 -> IO [Maybe (Either FilePath (FilePath, FilePath, Visibility))])
-> (FilePath
    -> IO (Maybe (Either FilePath (FilePath, FilePath, Visibility))))
-> IO [Maybe (Either FilePath (FilePath, FilePath, Visibility))]
forall a b. (a -> b) -> a -> b
$ \FilePath
interfacePath -> do
              let docDir :: FilePath
docDir = FilePath -> FilePath
takeDirectory FilePath
interfacePath
              Bool
a <- FilePath -> IO Bool
doesFileExist FilePath
interfacePath
              case Bool
a of
                Bool
True -> do
                  Verbosity -> FilePath -> FilePath -> IO ()
copyDirectoryRecursive Verbosity
verbosity FilePath
docDir FilePath
destDir
                  Maybe (Either FilePath (FilePath, FilePath, Visibility))
-> IO (Maybe (Either FilePath (FilePath, FilePath, Visibility)))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Either FilePath (FilePath, FilePath, Visibility))
 -> IO (Maybe (Either FilePath (FilePath, FilePath, Visibility))))
-> Maybe (Either FilePath (FilePath, FilePath, Visibility))
-> IO (Maybe (Either FilePath (FilePath, FilePath, Visibility)))
forall a b. (a -> b) -> a -> b
$ Either FilePath (FilePath, FilePath, Visibility)
-> Maybe (Either FilePath (FilePath, FilePath, Visibility))
forall a. a -> Maybe a
Just (Either FilePath (FilePath, FilePath, Visibility)
 -> Maybe (Either FilePath (FilePath, FilePath, Visibility)))
-> Either FilePath (FilePath, FilePath, Visibility)
-> Maybe (Either FilePath (FilePath, FilePath, Visibility))
forall a b. (a -> b) -> a -> b
$ (FilePath, FilePath, Visibility)
-> Either FilePath (FilePath, FilePath, Visibility)
forall a b. b -> Either a b
Right (FilePath
packageName, FilePath
interfacePath, Visibility
Hidden)
                Bool
False -> Maybe (Either FilePath (FilePath, FilePath, Visibility))
-> IO (Maybe (Either FilePath (FilePath, FilePath, Visibility)))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Either FilePath (FilePath, FilePath, Visibility))
forall a. Maybe a
Nothing
          Left InstalledPackageInfo
_ -> [Either FilePath (FilePath, FilePath, Visibility)]
-> IO [Either FilePath (FilePath, FilePath, Visibility)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
          Right ElaboratedConfiguredPackage
package ->
            case ElaboratedConfiguredPackage -> Bool
elabLocalToProject ElaboratedConfiguredPackage
package of
              Bool
True -> do
                let distDirParams :: DistDirParams
distDirParams = ElaboratedSharedConfig
-> ElaboratedConfiguredPackage -> DistDirParams
elabDistDirParams ElaboratedSharedConfig
sharedConfig' ElaboratedConfiguredPackage
package
                    pkg_descr :: PackageDescription
pkg_descr = ElaboratedConfiguredPackage -> PackageDescription
elabPkgDescription ElaboratedConfiguredPackage
package

                    packageName :: PackageName
packageName = PackageIdentifier -> PackageName
pkgName (PackageIdentifier -> PackageName)
-> PackageIdentifier -> PackageName
forall a b. (a -> b) -> a -> b
$ ElaboratedConfiguredPackage -> PackageIdentifier
elabPkgSourceId ElaboratedConfiguredPackage
package
                    unitId :: UnitId
unitId = ElaboratedConfiguredPackage -> UnitId
elabUnitId ElaboratedConfiguredPackage
package
                    packageDir :: FilePath
packageDir = HaddockTarget -> PackageDescription -> FilePath
haddockDirName HaddockTarget
ForDevelopment PackageDescription
pkg_descr
                    destDir :: FilePath
destDir = FilePath
outputDir FilePath -> FilePath -> FilePath
</> FilePath
packageDir
                    interfacePath :: FilePath
interfacePath = FilePath
destDir FilePath -> FilePath -> FilePath
</> PackageDescription -> FilePath
haddockPath PackageDescription
pkg_descr

                    buildDir :: FilePath
buildDir = DistDirLayout -> DistDirParams -> FilePath
distBuildDirectory DistDirLayout
distLayout DistDirParams
distDirParams
                    docDir :: FilePath
docDir =
                      FilePath
buildDir
                        FilePath -> FilePath -> FilePath
</> FilePath
"doc"
                        FilePath -> FilePath -> FilePath
</> FilePath
"html"
                        FilePath -> FilePath -> FilePath
</> FilePath
packageDir

                Bool
a <- FilePath -> IO Bool
doesDirectoryExist FilePath
docDir
                if Bool
a
                  then do
                    Verbosity -> FilePath -> FilePath -> IO ()
copyDirectoryRecursive Verbosity
verbosity FilePath
docDir FilePath
destDir
                    let infos :: [(String, FilePath, Visibility)]
                        infos :: [(FilePath, FilePath, Visibility)]
infos =
                          (PackageName -> FilePath
unPackageName PackageName
packageName, FilePath
interfacePath, Visibility
Visible)
                            (FilePath, FilePath, Visibility)
-> [(FilePath, FilePath, Visibility)]
-> [(FilePath, FilePath, Visibility)]
forall a. a -> [a] -> [a]
: [ (FilePath
sublibDirPath, FilePath
sublibInterfacePath, Visibility
Visible)
                              | Library
lib <- PackageDescription -> [Library]
subLibraries PackageDescription
pkg_descr
                              , let sublibDirPath :: FilePath
sublibDirPath = HaddockTarget -> PackageDescription -> Library -> FilePath
haddockLibraryDirPath HaddockTarget
ForDevelopment PackageDescription
pkg_descr Library
lib
                                    sublibInterfacePath :: FilePath
sublibInterfacePath =
                                      FilePath
outputDir
                                        FilePath -> FilePath -> FilePath
</> FilePath
sublibDirPath
                                        FilePath -> FilePath -> FilePath
</> PackageDescription -> Library -> FilePath
haddockLibraryPath PackageDescription
pkg_descr Library
lib
                              ]
                            [(FilePath, FilePath, Visibility)]
-> [(FilePath, FilePath, Visibility)]
-> [(FilePath, FilePath, Visibility)]
forall a. [a] -> [a] -> [a]
++ [ (FilePath
testPath, FilePath
testInterfacePath, Visibility
Visible)
                               | TestSuite
test <- PackageDescription -> [TestSuite]
testSuites PackageDescription
pkg_descr
                               , let testPath :: FilePath
testPath = HaddockTarget -> PackageDescription -> TestSuite -> FilePath
haddockTestDirPath HaddockTarget
ForDevelopment PackageDescription
pkg_descr TestSuite
test
                                     testInterfacePath :: FilePath
testInterfacePath =
                                      FilePath
outputDir
                                        FilePath -> FilePath -> FilePath
</> FilePath
testPath
                                        FilePath -> FilePath -> FilePath
</> PackageDescription -> FilePath
haddockPath PackageDescription
pkg_descr
                               ]
                            [(FilePath, FilePath, Visibility)]
-> [(FilePath, FilePath, Visibility)]
-> [(FilePath, FilePath, Visibility)]
forall a. [a] -> [a] -> [a]
++ [ (FilePath
benchPath, FilePath
benchInterfacePath, Visibility
Visible)
                               | Benchmark
bench <- PackageDescription -> [Benchmark]
benchmarks PackageDescription
pkg_descr
                               , let benchPath :: FilePath
benchPath = HaddockTarget -> PackageDescription -> Benchmark -> FilePath
haddockBenchmarkDirPath HaddockTarget
ForDevelopment PackageDescription
pkg_descr Benchmark
bench
                                     benchInterfacePath :: FilePath
benchInterfacePath =
                                      FilePath
outputDir
                                        FilePath -> FilePath -> FilePath
</> FilePath
benchPath
                                        FilePath -> FilePath -> FilePath
</> PackageDescription -> FilePath
haddockPath PackageDescription
pkg_descr
                               ]
                    [Either FilePath (FilePath, FilePath, Visibility)]
infos' <-
                      ((FilePath, FilePath, Visibility)
 -> IO (Either FilePath (FilePath, FilePath, Visibility)))
-> [(FilePath, FilePath, Visibility)]
-> IO [Either FilePath (FilePath, FilePath, Visibility)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM
                        ( \x :: (FilePath, FilePath, Visibility)
x@(FilePath
_, FilePath
path, Visibility
_) -> do
                            Bool
e <- FilePath -> IO Bool
doesFileExist FilePath
path
                            Either FilePath (FilePath, FilePath, Visibility)
-> IO (Either FilePath (FilePath, FilePath, Visibility))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either FilePath (FilePath, FilePath, Visibility)
 -> IO (Either FilePath (FilePath, FilePath, Visibility)))
-> Either FilePath (FilePath, FilePath, Visibility)
-> IO (Either FilePath (FilePath, FilePath, Visibility))
forall a b. (a -> b) -> a -> b
$
                              if Bool
e
                                then (FilePath, FilePath, Visibility)
-> Either FilePath (FilePath, FilePath, Visibility)
forall a b. b -> Either a b
Right (FilePath, FilePath, Visibility)
x
                                else FilePath -> Either FilePath (FilePath, FilePath, Visibility)
forall a b. a -> Either a b
Left FilePath
path
                        )
                        [(FilePath, FilePath, Visibility)]
infos
                    [Either FilePath (FilePath, FilePath, Visibility)]
-> IO [Either FilePath (FilePath, FilePath, Visibility)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Either FilePath (FilePath, FilePath, Visibility)]
infos'
                  else do
                    Verbosity -> FilePath -> IO ()
warn
                      Verbosity
verbosity
                      ( FilePath
"haddocks of "
                          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ UnitId -> FilePath
unUnitId UnitId
unitId
                          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" not found in the store"
                      )
                    [Either FilePath (FilePath, FilePath, Visibility)]
-> IO [Either FilePath (FilePath, FilePath, Visibility)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
              Bool
False
                | Bool -> Bool
not Bool
localStyle ->
                    [Either FilePath (FilePath, FilePath, Visibility)]
-> IO [Either FilePath (FilePath, FilePath, Visibility)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
              Bool
False -> do
                let pkg_descr :: PackageDescription
pkg_descr = ElaboratedConfiguredPackage -> PackageDescription
elabPkgDescription ElaboratedConfiguredPackage
package
                    unitId :: FilePath
unitId = UnitId -> FilePath
unUnitId (ElaboratedConfiguredPackage -> UnitId
elabUnitId ElaboratedConfiguredPackage
package)
                    packageDir :: FilePath
packageDir =
                      StoreDirLayout -> Compiler -> UnitId -> FilePath
storePackageDirectory
                        (CabalDirLayout -> StoreDirLayout
cabalStoreDirLayout CabalDirLayout
cabalLayout)
                        (ElaboratedSharedConfig -> Compiler
pkgConfigCompiler ElaboratedSharedConfig
sharedConfig')
                        (ElaboratedConfiguredPackage -> UnitId
elabUnitId ElaboratedConfiguredPackage
package)
                    -- TODO: use `InstallDirTemplates`
                    docDir :: FilePath
docDir = FilePath
packageDir FilePath -> FilePath -> FilePath
</> FilePath
"share" FilePath -> FilePath -> FilePath
</> FilePath
"doc" FilePath -> FilePath -> FilePath
</> FilePath
"html"
                    destDir :: FilePath
destDir = FilePath
outputDir FilePath -> FilePath -> FilePath
</> HaddockTarget -> PackageDescription -> FilePath
haddockDirName HaddockTarget
ForDevelopment PackageDescription
pkg_descr
                    interfacePath :: FilePath
interfacePath = FilePath
destDir FilePath -> FilePath -> FilePath
</> PackageDescription -> FilePath
haddockPath PackageDescription
pkg_descr
                Bool
a <- FilePath -> IO Bool
doesDirectoryExist FilePath
docDir
                case Bool
a of
                  Bool
True -> do
                    Verbosity -> FilePath -> FilePath -> IO ()
copyDirectoryRecursive Verbosity
verbosity FilePath
docDir FilePath
destDir
                    -- non local packages will be hidden in haddock's
                    -- generated contents page
                    [Either FilePath (FilePath, FilePath, Visibility)]
-> IO [Either FilePath (FilePath, FilePath, Visibility)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(FilePath, FilePath, Visibility)
-> Either FilePath (FilePath, FilePath, Visibility)
forall a b. b -> Either a b
Right (FilePath
unitId, FilePath
interfacePath, Visibility
Hidden)]
                  Bool
False -> do
                    [Either FilePath (FilePath, FilePath, Visibility)]
-> IO [Either FilePath (FilePath, FilePath, Visibility)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath -> Either FilePath (FilePath, FilePath, Visibility)
forall a b. a -> Either a b
Left FilePath
unitId]

      --
      -- generate index, content, etc.
      --

      let ([FilePath]
missingHaddocks, [(FilePath, FilePath, Visibility)]
packageInfos') = [Either FilePath (FilePath, FilePath, Visibility)]
-> ([FilePath], [(FilePath, FilePath, Visibility)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either FilePath (FilePath, FilePath, Visibility)]
packageInfos
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
missingHaddocks)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity FilePath
"missing haddocks for some packages from the store"
        -- Show the package list if `-v1` is passed; it's usually a long list.
        -- One needs to add `package` stantza in `cabal.project` file for
        -- `cabal` to include a version which has haddocks (or set
        -- `documentation: True` in the global config).
        Verbosity -> FilePath -> IO ()
info Verbosity
verbosity (FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"\n" [FilePath]
missingHaddocks)

      let flags' :: HaddockProjectFlags
flags' =
            HaddockProjectFlags
flags
              { haddockProjectDir = Flag outputDir
              , haddockProjectInterfaces =
                  Flag
                    [ ( interfacePath
                      , Just url
                      , Just url
                      , visibility
                      )
                    | (url, interfacePath, visibility) <- packageInfos'
                    ]
              , haddockProjectUseUnicode = NoFlag
              }
      Verbosity
-> ProgramDb
-> Compiler
-> Platform
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> HaddockProjectFlags
-> IO ()
createHaddockIndex
        Verbosity
verbosity
        (ElaboratedSharedConfig -> ProgramDb
pkgConfigCompilerProgs ElaboratedSharedConfig
sharedConfig')
        (ElaboratedSharedConfig -> Compiler
pkgConfigCompiler ElaboratedSharedConfig
sharedConfig')
        (ElaboratedSharedConfig -> Platform
pkgConfigPlatform ElaboratedSharedConfig
sharedConfig')
        Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Maybe a
Nothing
        HaddockProjectFlags
flags'
  where
    verbosity :: Verbosity
verbosity = Verbosity -> Flag Verbosity -> Verbosity
forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal (HaddockProjectFlags -> Flag Verbosity
haddockProjectVerbosity HaddockProjectFlags
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 :: Bool
localStyle =
      let hackage :: Bool
hackage = Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (HaddockProjectFlags -> Flag Bool
haddockProjectHackage HaddockProjectFlags
flags)
          location :: Bool
location = Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (Bool -> FilePath -> Bool
forall a b. a -> b -> a
const Bool
True (FilePath -> Bool) -> Flag FilePath -> Flag Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HaddockProjectFlags -> Flag FilePath
haddockProjectHtmlLocation HaddockProjectFlags
flags)
       in Bool -> Bool
not Bool
hackage Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
location

    reportTargetProblems :: Show x => [x] -> IO a
    reportTargetProblems :: forall x a. Show x => [x] -> IO a
reportTargetProblems =
      Verbosity -> CabalInstallException -> IO a
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO a)
-> ([x] -> CabalInstallException) -> [x] -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> CabalInstallException
CmdHaddockReportTargetProblems ([FilePath] -> CabalInstallException)
-> ([x] -> [FilePath]) -> [x] -> CabalInstallException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (x -> FilePath) -> [x] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map x -> FilePath
forall a. Show a => a -> FilePath
show

    -- TODO: this is just a sketch
    selectPackageTargets
      :: TargetSelector
      -> [AvailableTarget k]
      -> Either (TargetProblem ()) [k]
    selectPackageTargets :: forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem ()) [k]
selectPackageTargets TargetSelector
_ [AvailableTarget k]
ts =
      [k] -> Either (TargetProblem ()) [k]
forall a b. b -> Either a b
Right ([k] -> Either (TargetProblem ()) [k])
-> [k] -> Either (TargetProblem ()) [k]
forall a b. (a -> b) -> a -> b
$
        (AvailableTarget k -> Maybe k) -> [AvailableTarget k] -> [k]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
          ( \AvailableTarget k
t -> case AvailableTarget k -> AvailableTargetStatus k
forall k. AvailableTarget k -> AvailableTargetStatus k
availableTargetStatus AvailableTarget k
t of
              TargetBuildable k
k TargetRequested
_
                | AvailableTarget k -> Bool
forall k. AvailableTarget k -> Bool
availableTargetLocalToProject AvailableTarget k
t ->
                    k -> Maybe k
forall a. a -> Maybe a
Just k
k
              AvailableTargetStatus k
_ -> Maybe k
forall a. Maybe a
Nothing
          )
          [AvailableTarget k]
ts

    matchingPackages
      :: ElaboratedInstallPlan
      -> [Either InstalledPackageInfo ElaboratedConfiguredPackage]
    matchingPackages :: ElaboratedInstallPlan
-> [Either InstalledPackageInfo ElaboratedConfiguredPackage]
matchingPackages =
      (GenericPlanPackage
   InstalledPackageInfo ElaboratedConfiguredPackage
 -> Either InstalledPackageInfo ElaboratedConfiguredPackage)
-> [GenericPlanPackage
      InstalledPackageInfo ElaboratedConfiguredPackage]
-> [Either InstalledPackageInfo ElaboratedConfiguredPackage]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((InstalledPackageInfo
 -> Either InstalledPackageInfo ElaboratedConfiguredPackage)
-> (ElaboratedConfiguredPackage
    -> Either InstalledPackageInfo ElaboratedConfiguredPackage)
-> GenericPlanPackage
     InstalledPackageInfo ElaboratedConfiguredPackage
-> Either InstalledPackageInfo ElaboratedConfiguredPackage
forall ipkg a srcpkg.
(ipkg -> a) -> (srcpkg -> a) -> GenericPlanPackage ipkg srcpkg -> a
foldPlanPackage InstalledPackageInfo
-> Either InstalledPackageInfo ElaboratedConfiguredPackage
forall a b. a -> Either a b
Left ElaboratedConfiguredPackage
-> Either InstalledPackageInfo ElaboratedConfiguredPackage
forall a b. b -> Either a b
Right)
        ([GenericPlanPackage
    InstalledPackageInfo ElaboratedConfiguredPackage]
 -> [Either InstalledPackageInfo ElaboratedConfiguredPackage])
-> (ElaboratedInstallPlan
    -> [GenericPlanPackage
          InstalledPackageInfo ElaboratedConfiguredPackage])
-> ElaboratedInstallPlan
-> [Either InstalledPackageInfo ElaboratedConfiguredPackage]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ElaboratedInstallPlan
-> [GenericPlanPackage
      InstalledPackageInfo ElaboratedConfiguredPackage]
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.toList