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

import Prelude ()
import Data.Bool (bool)
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.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(..)
        , flagElim
        , flagToList
        , 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 forall a b. (a -> b) -> a -> b
$ forall a. WithCallStack (Flag a -> a)
fromFlag (HaddockProjectFlags -> Flag String
haddockProjectDir HaddockProjectFlags
flags)
    Verbosity -> Bool -> String -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True String
outputDir

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Int
2::Int) forall a. Ord a => a -> a -> Bool
<=
            ( forall b a. b -> (a -> b) -> Flag a -> b
flagElim Int
0 (forall a. a -> a -> Bool -> a
bool Int
0 Int
1) (HaddockProjectFlags -> Flag Bool
haddockProjectHackage HaddockProjectFlags
flags)
            forall a. Num a => a -> a -> a
+ forall b a. b -> (a -> b) -> Flag a -> b
flagElim Int
0 (forall a. a -> a -> Bool -> a
bool Int
0 Int
1) (HaddockProjectFlags -> Flag Bool
haddockProjectLocal HaddockProjectFlags
flags)
            forall a. Num a => a -> a -> a
+ forall b a. b -> (a -> b) -> Flag a -> b
flagElim Int
0 (forall a b. a -> b -> a
const Int
1)  (HaddockProjectFlags -> Flag String
haddockProjectHtmlLocation HaddockProjectFlags
flags)
            )) forall a b. (a -> b) -> a -> b
$
      forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity String
"Options `--local`, `--hackage` and `--html-location` are mutually exclusive`"

    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 Bool
haddockHtml         = forall a. a -> Flag a
Flag Bool
True
          -- one can either use `--haddock-base-url` or
          -- `--haddock-html-location`.
          , haddockBaseUrl :: Flag String
haddockBaseUrl      = if Bool
localStyle
                                  then forall a. a -> Flag a
Flag String
".."
                                  else forall a. Flag a
NoFlag
          , haddockProgramPaths :: [(String, String)]
haddockProgramPaths = HaddockProjectFlags -> [(String, String)]
haddockProjectProgramPaths  HaddockProjectFlags
flags
          , haddockProgramArgs :: [(String, [String])]
haddockProgramArgs  = HaddockProjectFlags -> [(String, [String])]
haddockProjectProgramArgs   HaddockProjectFlags
flags
          , haddockHtmlLocation :: Flag String
haddockHtmlLocation = if forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (HaddockProjectFlags -> Flag Bool
haddockProjectHackage HaddockProjectFlags
flags)
                                  then forall a. a -> Flag a
Flag String
"https://hackage.haskell.org/package/$pkg-$version/docs"
                                  else HaddockProjectFlags -> Flag String
haddockProjectHtmlLocation HaddockProjectFlags
flags
          , haddockHoogle :: Flag Bool
haddockHoogle       = HaddockProjectFlags -> Flag Bool
haddockProjectHoogle        HaddockProjectFlags
flags
          , haddockExecutables :: Flag Bool
haddockExecutables  = HaddockProjectFlags -> Flag Bool
haddockProjectExecutables   HaddockProjectFlags
flags
          , haddockTestSuites :: Flag Bool
haddockTestSuites   = HaddockProjectFlags -> Flag Bool
haddockProjectTestSuites    HaddockProjectFlags
flags
          , haddockBenchmarks :: Flag Bool
haddockBenchmarks   = HaddockProjectFlags -> Flag Bool
haddockProjectBenchmarks    HaddockProjectFlags
flags
          , haddockForeignLibs :: Flag Bool
haddockForeignLibs  = HaddockProjectFlags -> Flag Bool
haddockProjectForeignLibs   HaddockProjectFlags
flags
          , haddockInternal :: Flag Bool
haddockInternal     = HaddockProjectFlags -> Flag Bool
haddockProjectInternal      HaddockProjectFlags
flags
          , haddockCss :: Flag String
haddockCss          = HaddockProjectFlags -> Flag String
haddockProjectCss           HaddockProjectFlags
flags
          , haddockLinkedSource :: Flag Bool
haddockLinkedSource = if Bool
localOrHackage
                                  then forall a. a -> Flag a
Flag Bool
True
                                  else HaddockProjectFlags -> Flag Bool
haddockProjectLinkedSource HaddockProjectFlags
flags
          , haddockQuickJump :: Flag Bool
haddockQuickJump    = if Bool
localOrHackage
                                  then forall a. a -> Flag a
Flag Bool
True
                                  else HaddockProjectFlags -> Flag Bool
haddockProjectQuickJump HaddockProjectFlags
flags
          , haddockHscolourCss :: Flag String
haddockHscolourCss  = HaddockProjectFlags -> Flag String
haddockProjectHscolourCss    HaddockProjectFlags
flags
          , haddockContents :: Flag PathTemplate
haddockContents     = if Bool
localStyle then forall a. a -> Flag a
Flag (String -> PathTemplate
toPathTemplate String
"../index.html")
                                                else forall a. Flag a
NoFlag
          , haddockIndex :: Flag PathTemplate
haddockIndex        = if Bool
localStyle then forall a. a -> Flag a
Flag (String -> PathTemplate
toPathTemplate String
"../doc-index.html")
                                                else forall a. Flag a
NoFlag
          , haddockKeepTempFiles :: Flag Bool
haddockKeepTempFiles= HaddockProjectFlags -> Flag Bool
haddockProjectKeepTempFiles HaddockProjectFlags
flags
          , haddockVerbosity :: Flag Verbosity
haddockVerbosity    = HaddockProjectFlags -> Flag Verbosity
haddockProjectVerbosity     HaddockProjectFlags
flags
          , haddockLib :: Flag String
haddockLib          = HaddockProjectFlags -> Flag String
haddockProjectLib           HaddockProjectFlags
flags
          }
        nixFlags :: NixStyleFlags ClientHaddockFlags
nixFlags = (forall flags. CommandUI flags -> flags
commandDefaultFlags CommandUI (NixStyleFlags ClientHaddockFlags)
CmdHaddock.haddockCommand)
                   { haddockFlags :: HaddockFlags
NixStyleOptions.haddockFlags = HaddockFlags
haddockFlags
                   , configFlags :: ConfigFlags
NixStyleOptions.configFlags  =
                       (forall a. NixStyleFlags a -> ConfigFlags
NixStyleOptions.configFlags (forall flags. CommandUI flags -> flags
commandDefaultFlags CommandUI (NixStyleFlags BuildFlags)
CmdBuild.buildCommand))
                       { configVerbosity :: Flag Verbosity
configVerbosity = HaddockProjectFlags -> Flag Verbosity
haddockProjectVerbosity HaddockProjectFlags
flags }
                   }

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

    forall a b.
AcceptNoTargets
-> Maybe ComponentKind
-> NixStyleFlags a
-> [String]
-> GlobalFlags
-> CurrentCommand
-> (TargetContext
    -> ProjectBaseContext -> [TargetSelector] -> IO b)
-> IO b
withContextAndSelectors AcceptNoTargets
RejectNoTargets forall a. Maybe a
Nothing NixStyleFlags ClientHaddockFlags
nixFlags [String
"all"] GlobalFlags
globalFlags CurrentCommand
HaddockCommand forall a b. (a -> b) -> a -> b
$ \TargetContext
targetCtx ProjectBaseContext
ctx [TargetSelector]
targetSelectors -> do
      ProjectBaseContext
baseCtx <- case TargetContext
targetCtx of
        TargetContext
ProjectContext             -> forall (m :: * -> *) a. Monad m => a -> m a
return ProjectBaseContext
ctx
        TargetContext
GlobalContext              -> 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 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 <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall x a. Show x => [x] -> IO a
reportTargetProblems forall (m :: * -> *) a. Monad m => a -> m a
return
                       forall a b. (a -> b) -> a -> b
$ 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
                           forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem ()) [k]
selectPackageTargets
                           forall k a.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem a) k
selectComponentTargetBasic
                           ElaboratedInstallPlan
elaboratedPlan
                           forall a. Maybe a
Nothing
                           [TargetSelector]
targetSelectors

              let elaboratedPlan' :: ElaboratedInstallPlan
elaboratedPlan' = TargetAction
-> TargetsMap -> ElaboratedInstallPlan -> ElaboratedInstallPlan
pruneInstallPlanToTargets
                                      TargetAction
TargetActionBuild
                                      TargetsMap
targets
                                      ElaboratedInstallPlan
elaboratedPlan
              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
             forall b c a. (b -> c) -> (a -> b) -> a -> c
. Program -> ProgramDb -> ProgramDb
addKnownProgram Program
haddockProgram
             forall b c a. (b -> c) -> (a -> b) -> a -> c
. ElaboratedSharedConfig -> ProgramDb
pkgConfigCompilerProgs
             forall a b. (a -> b) -> a -> b
$ ElaboratedSharedConfig
sharedConfig
      let sharedConfig' :: ElaboratedSharedConfig
sharedConfig' = ElaboratedSharedConfig
sharedConfig { pkgConfigCompilerProgs :: ProgramDb
pkgConfigCompilerProgs = ProgramDb
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 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 <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Eq a => [a] -> [a]
nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Either InstalledPackageInfo ElaboratedConfiguredPackage]
pkgs forall a b. (a -> b) -> a -> b
$ \Either InstalledPackageInfo ElaboratedConfiguredPackage
pkg ->
        case Either InstalledPackageInfo ElaboratedConfiguredPackage
pkg of
          Left InstalledPackageInfo
_ | Bool -> Bool
not Bool
localStyle ->
            forall (m :: * -> *) a. Monad m => a -> m a
return []
          Left InstalledPackageInfo
package -> do
            let packageName :: String
packageName = PackageName -> String
unPackageName (PackageIdentifier -> PackageName
pkgName forall a b. (a -> b) -> a -> b
$ InstalledPackageInfo -> PackageIdentifier
sourcePackageId InstalledPackageInfo
package)
                destDir :: String
destDir = String
outputDir String -> String -> String
</> String
packageName
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (InstalledPackageInfo -> [String]
haddockInterfaces InstalledPackageInfo
package) 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
                     forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just ( String
packageName
                                     , String
interfacePath
                                     , Visibility
Hidden
                                     ))
                Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return 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
                    buildDir :: String
buildDir = DistDirLayout -> DistDirParams -> String
distBuildDirectory DistDirLayout
distLayout DistDirParams
distDirParams
                    packageName :: String
packageName = PackageName -> String
unPackageName (PackageIdentifier -> PackageName
pkgName 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
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
                        forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return [( String
packageName
                                   , String
interfacePath
                                   , Visibility
Visible
                                   )]
                  Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return []
              Bool
False | Bool -> Bool
not Bool
localStyle ->
                forall (m :: * -> *) a. Monad m => a -> m a
return []
              Bool
False -> do
                let packageName :: String
packageName = PackageName -> String
unPackageName (PackageIdentifier -> PackageName
pkgName forall a b. (a -> b) -> a -> b
$ ElaboratedConfiguredPackage -> PackageIdentifier
elabPkgSourceId 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
                        forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return [( String
packageName
                                   , String
interfacePath
                                   , Visibility
Hidden
                                   )]
                  Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return []

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

      let flags' :: HaddockProjectFlags
flags' = HaddockProjectFlags
flags
            { haddockProjectDir :: Flag String
haddockProjectDir         = forall a. a -> Flag a
Flag String
outputDir
            , haddockProjectGenIndex :: Flag Bool
haddockProjectGenIndex    = if Bool
localOrHackage
                                          then forall a. a -> Flag a
Flag Bool
True
                                          else HaddockProjectFlags -> Flag Bool
haddockProjectGenIndex HaddockProjectFlags
flags
            , haddockProjectGenContents :: Flag Bool
haddockProjectGenContents = if Bool
localOrHackage
                                          then forall a. a -> Flag a
Flag Bool
True
                                          else HaddockProjectFlags -> Flag Bool
haddockProjectGenContents HaddockProjectFlags
flags
            , haddockProjectQuickJump :: Flag Bool
haddockProjectQuickJump   = if Bool
localOrHackage
                                          then forall a. a -> Flag a
Flag Bool
True
                                          else HaddockProjectFlags -> Flag Bool
haddockProjectQuickJump HaddockProjectFlags
flags
            , haddockProjectLinkedSource :: Flag Bool
haddockProjectLinkedSource = HaddockFlags -> Flag Bool
haddockLinkedSource HaddockFlags
haddockFlags
            , haddockProjectInterfaces :: Flag [(String, Maybe String, Maybe String, Visibility)]
haddockProjectInterfaces  = forall a. a -> Flag a
Flag
                [ ( String
interfacePath
                  , forall a. a -> Maybe a
Just String
packageName
                  , forall a. a -> Maybe a
Just String
packageName
                  , Visibility
visibility
                  )
                | (String
packageName, String
interfacePath, Visibility
visibility) <- [(String, String, 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 = 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 local :: Bool
local    = forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (HaddockProjectFlags -> Flag Bool
haddockProjectLocal HaddockProjectFlags
flags)
          hackage :: Bool
hackage  = forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (HaddockProjectFlags -> Flag Bool
haddockProjectHackage HaddockProjectFlags
flags)
          location :: Bool
location = forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (forall a b. a -> b -> a
const Bool
True forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HaddockProjectFlags -> Flag String
haddockProjectHtmlLocation HaddockProjectFlags
flags)
      in        Bool
local Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
hackage Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
location
         -- or if none of the flags is given set `localStyle` to `True`
         Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
local Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
hackage Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
location


    localOrHackage :: Bool
localOrHackage =
      forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a. Flag a -> [a]
flagToList (HaddockProjectFlags -> Flag Bool
haddockProjectLocal HaddockProjectFlags
flags)
            forall a. [a] -> [a] -> [a]
++ forall a. Flag a -> [a]
flagToList (HaddockProjectFlags -> Flag Bool
haddockProjectHackage HaddockProjectFlags
flags)

    reportTargetProblems :: Show x => [x] -> IO a
    reportTargetProblems :: forall x a. Show x => [x] -> IO a
reportTargetProblems =
        forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map 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 = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$
      forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
        (\AvailableTarget k
t -> case forall k. AvailableTarget k -> AvailableTargetStatus k
availableTargetStatus AvailableTarget k
t of
            TargetBuildable k
k TargetRequested
_ | forall k. AvailableTarget k -> Bool
availableTargetLocalToProject AvailableTarget k
t
                                -> forall a. a -> Maybe a
Just k
k
            AvailableTargetStatus k
_                   -> forall a. Maybe a
Nothing)
        [AvailableTarget k]
ts

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