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
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"
let haddockFlags :: HaddockFlags
haddockFlags = HaddockFlags
defaultHaddockFlags
{ haddockHtml = Flag True
, 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 }
}
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
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)
(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
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
NixStyleFlags ClientHaddockFlags
-> [String] -> GlobalFlags -> IO ()
CmdHaddock.haddockAction
NixStyleFlags ClientHaddockFlags
nixFlags
[String
"all"]
GlobalFlags
globalFlags
[(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
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
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 []
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)
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
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