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

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

    -- build all packages with appropriate haddock flags
    let haddockFlags :: HaddockFlags
haddockFlags = 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 :: 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))
                       { configVerbosity = haddockProjectVerbosity flags }
                   }

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

    AcceptNoTargets
-> Maybe ComponentKind
-> NixStyleFlags BuildFlags
-> [String]
-> GlobalFlags
-> CurrentCommand
-> (TargetContext
    -> ProjectBaseContext -> [TargetSelector] -> IO ())
-> IO ()
forall a b.
AcceptNoTargets
-> Maybe ComponentKind
-> NixStyleFlags a
-> [String]
-> 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) [String
"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 String
path Executable
exemeta -> ProjectBaseContext -> String -> Executable -> IO ProjectBaseContext
updateContextAndWriteProjectFile ProjectBaseContext
ctx String
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)

      Verbosity -> ProjectBaseContext -> ProjectBuildContext -> IO ()
printPlan Verbosity
verbosity ProjectBaseContext
baseCtx ProjectBuildContext
buildCtx

      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
-> [(String, String)]
-> [(String, [String])]
-> ProgramDb
-> IO ProgramDb
reconfigurePrograms Verbosity
verbosity
                 (HaddockProjectFlags -> [(String, String)]
haddockProjectProgramPaths HaddockProjectFlags
flags)
                 (HaddockProjectFlags -> [(String, [String])]
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 -> [String] -> GlobalFlags -> IO ()
CmdBuild.buildAction
          (CommandUI (NixStyleFlags BuildFlags) -> NixStyleFlags BuildFlags
forall flags. CommandUI flags -> flags
commandDefaultFlags CommandUI (NixStyleFlags BuildFlags)
CmdBuild.buildCommand)
          [String
"all"]
          GlobalFlags
globalFlags
      --
      -- Build haddocks of each components
      --

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

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

      [(String, String, Visibility)]
packageInfos <- ([[(String, String, Visibility)]]
 -> [(String, String, Visibility)])
-> IO [[(String, String, Visibility)]]
-> IO [(String, String, Visibility)]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(String, String, Visibility)] -> [(String, String, Visibility)]
forall a. Eq a => [a] -> [a]
nub ([(String, String, Visibility)] -> [(String, String, Visibility)])
-> ([[(String, String, Visibility)]]
    -> [(String, String, Visibility)])
-> [[(String, String, Visibility)]]
-> [(String, String, Visibility)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(String, String, Visibility)]] -> [(String, String, Visibility)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) (IO [[(String, String, Visibility)]]
 -> IO [(String, String, Visibility)])
-> IO [[(String, String, Visibility)]]
-> IO [(String, String, Visibility)]
forall a b. (a -> b) -> a -> b
$ [Either InstalledPackageInfo ElaboratedConfiguredPackage]
-> (Either InstalledPackageInfo ElaboratedConfiguredPackage
    -> IO [(String, String, Visibility)])
-> IO [[(String, String, 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 [(String, String, Visibility)])
 -> IO [[(String, String, Visibility)]])
-> (Either InstalledPackageInfo ElaboratedConfiguredPackage
    -> IO [(String, String, Visibility)])
-> IO [[(String, String, Visibility)]]
forall a b. (a -> b) -> a -> b
$ \Either InstalledPackageInfo ElaboratedConfiguredPackage
pkg ->
        case Either InstalledPackageInfo ElaboratedConfiguredPackage
pkg of
          Left InstalledPackageInfo
_ | Bool -> Bool
not Bool
localStyle ->
            [(String, String, Visibility)] -> IO [(String, String, Visibility)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
          Left InstalledPackageInfo
package -> do
            -- TODO: this might not work for public packages with sublibraries.
            -- Issue #9026.
            let packageName :: String
packageName = PackageName -> String
unPackageName (PackageIdentifier -> PackageName
pkgName (PackageIdentifier -> PackageName)
-> PackageIdentifier -> PackageName
forall a b. (a -> b) -> a -> b
$ InstalledPackageInfo -> PackageIdentifier
sourcePackageId InstalledPackageInfo
package)
                destDir :: String
destDir = String
outputDir String -> String -> String
</> String
packageName
            ([Maybe (String, String, Visibility)]
 -> [(String, String, Visibility)])
-> IO [Maybe (String, String, Visibility)]
-> IO [(String, String, Visibility)]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe (String, String, Visibility)]
-> [(String, String, Visibility)]
forall a. [Maybe a] -> [a]
catMaybes (IO [Maybe (String, String, Visibility)]
 -> IO [(String, String, Visibility)])
-> IO [Maybe (String, String, Visibility)]
-> IO [(String, String, Visibility)]
forall a b. (a -> b) -> a -> b
$ [String]
-> (String -> IO (Maybe (String, String, Visibility)))
-> IO [Maybe (String, String, Visibility)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (InstalledPackageInfo -> [String]
haddockInterfaces InstalledPackageInfo
package) ((String -> IO (Maybe (String, String, Visibility)))
 -> IO [Maybe (String, String, Visibility)])
-> (String -> IO (Maybe (String, String, Visibility)))
-> IO [Maybe (String, String, Visibility)]
forall a b. (a -> b) -> a -> b
$ \String
interfacePath -> do
              let docDir :: String
docDir = String -> String
takeDirectory String
interfacePath
              Bool
a <- String -> IO Bool
doesFileExist String
interfacePath
              case Bool
a of
                Bool
True -> Verbosity -> String -> String -> IO ()
copyDirectoryRecursive Verbosity
verbosity String
docDir String
destDir
                     IO ()
-> IO (Maybe (String, String, Visibility))
-> IO (Maybe (String, String, Visibility))
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (String, String, Visibility)
-> IO (Maybe (String, String, Visibility))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((String, String, Visibility) -> Maybe (String, String, Visibility)
forall a. a -> Maybe a
Just ( String
packageName
                                     , String
interfacePath
                                     , Visibility
Hidden
                                     ))
                Bool
False -> Maybe (String, String, Visibility)
-> IO (Maybe (String, String, Visibility))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (String, String, Visibility)
forall a. Maybe a
Nothing

          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
                    unitId :: String
unitId = UnitId -> String
unUnitId (ElaboratedConfiguredPackage -> UnitId
elabUnitId ElaboratedConfiguredPackage
package)
                    buildDir :: String
buildDir = DistDirLayout -> DistDirParams -> String
distBuildDirectory DistDirLayout
distLayout DistDirParams
distDirParams
                    packageName :: String
packageName = PackageName -> String
unPackageName (PackageIdentifier -> PackageName
pkgName (PackageIdentifier -> PackageName)
-> PackageIdentifier -> PackageName
forall a b. (a -> b) -> a -> b
$ ElaboratedConfiguredPackage -> PackageIdentifier
elabPkgSourceId ElaboratedConfiguredPackage
package)
                let docDir :: String
docDir = String
buildDir
                         String -> String -> String
</> String
"doc" String -> String -> String
</> String
"html"
                         String -> String -> String
</> String
packageName
                    destDir :: String
destDir = String
outputDir String -> String -> String
</> String
unitId
                    interfacePath :: String
interfacePath = String
destDir
                                String -> String -> String
</> String
packageName String -> String -> String
<.> String
"haddock"
                Bool
a <- String -> IO Bool
doesDirectoryExist String
docDir
                case Bool
a of
                  Bool
True  -> Verbosity -> String -> String -> IO ()
copyDirectoryRecursive Verbosity
verbosity String
docDir String
destDir
                        IO ()
-> IO [(String, String, Visibility)]
-> IO [(String, String, Visibility)]
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [(String, String, Visibility)] -> IO [(String, String, Visibility)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [( String
packageName
                                   , String
interfacePath
                                   , Visibility
Visible
                                   )]
                  Bool
False -> do
                    Verbosity -> String -> IO ()
warn Verbosity
verbosity
                         (String
"haddocks of "
                          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
unitId
                          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not found in the store")
                    [(String, String, Visibility)] -> IO [(String, String, Visibility)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
              Bool
False | Bool -> Bool
not Bool
localStyle ->
                [(String, String, Visibility)] -> IO [(String, String, Visibility)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
              Bool
False -> do
                let packageName :: String
packageName = PackageName -> String
unPackageName (PackageIdentifier -> PackageName
pkgName (PackageIdentifier -> PackageName)
-> PackageIdentifier -> PackageName
forall a b. (a -> b) -> a -> b
$ ElaboratedConfiguredPackage -> PackageIdentifier
elabPkgSourceId ElaboratedConfiguredPackage
package)
                    unitId :: String
unitId = UnitId -> String
unUnitId (ElaboratedConfiguredPackage -> UnitId
elabUnitId ElaboratedConfiguredPackage
package)
                    packageDir :: String
packageDir = StoreDirLayout -> CompilerId -> UnitId -> String
storePackageDirectory (CabalDirLayout -> StoreDirLayout
cabalStoreDirLayout CabalDirLayout
cabalLayout)
                                   (Compiler -> CompilerId
compilerId (ElaboratedSharedConfig -> Compiler
pkgConfigCompiler ElaboratedSharedConfig
sharedConfig'))
                                   (ElaboratedConfiguredPackage -> UnitId
elabUnitId ElaboratedConfiguredPackage
package)
                    docDir :: String
docDir = String
packageDir String -> String -> String
</> String
"share" String -> String -> String
</> String
"doc" String -> String -> String
</> String
"html"
                    destDir :: String
destDir = String
outputDir String -> String -> String
</> String
packageName
                    interfacePath :: String
interfacePath = String
destDir
                                String -> String -> String
</> String
packageName String -> String -> String
<.> String
"haddock"
                Bool
a <- String -> IO Bool
doesDirectoryExist String
docDir
                case Bool
a of
                  Bool
True  -> Verbosity -> String -> String -> IO ()
copyDirectoryRecursive Verbosity
verbosity String
docDir String
destDir
                        -- non local packages will be hidden in haddock's
                        -- generated contents page
                        IO ()
-> IO [(String, String, Visibility)]
-> IO [(String, String, Visibility)]
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [(String, String, Visibility)] -> IO [(String, String, Visibility)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [( String
unitId
                                   , String
interfacePath
                                   , Visibility
Hidden
                                   )]
                  Bool
False -> do
                    Verbosity -> String -> IO ()
warn Verbosity
verbosity
                         (String
"haddocks of "
                          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
unitId
                          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not found in the store")
                    [(String, String, Visibility)] -> IO [(String, String, Visibility)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []

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

      let flags' :: HaddockProjectFlags
flags' = HaddockProjectFlags
flags
            { haddockProjectDir         = Flag outputDir
            , haddockProjectInterfaces  = Flag
                [ ( interfacePath
                  , Just name
                  , Just name
                  , visibility
                  )
                | (name, interfacePath, visibility) <- packageInfos
                ]
            }
      Verbosity
-> ProgramDb
-> Compiler
-> Platform
-> HaddockProjectFlags
-> IO ()
createHaddockIndex Verbosity
verbosity
                         (ElaboratedSharedConfig -> ProgramDb
pkgConfigCompilerProgs ElaboratedSharedConfig
sharedConfig')
                         (ElaboratedSharedConfig -> Compiler
pkgConfigCompiler ElaboratedSharedConfig
sharedConfig')
                         (ElaboratedSharedConfig -> Platform
pkgConfigPlatform ElaboratedSharedConfig
sharedConfig')
                         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 -> String -> Bool
forall a b. a -> b -> a
const Bool
True (String -> Bool) -> Flag String -> Flag Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HaddockProjectFlags -> Flag String
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 -> String -> IO a
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO a) -> ([x] -> String) -> [x] -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> String) -> ([x] -> [String]) -> [x] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (x -> String) -> [x] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map x -> String
forall a. Show a => a -> String
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