Commit 792e7501 authored by batterseapower's avatar batterseapower

Allow Haddock to be configured from the 'install' command

parent d5e2bafe
......@@ -84,7 +84,7 @@ import qualified Distribution.Simple.InstallDirs as InstallDirs
import qualified Distribution.Client.PackageIndex as PackageIndex
import Distribution.Client.PackageIndex (PackageIndex)
import Distribution.Simple.Setup
( haddockCommand, HaddockFlags(..), emptyHaddockFlags
( haddockCommand, HaddockFlags(..)
, buildCommand, BuildFlags(..), emptyBuildFlags
, toFlag, fromFlag, fromFlagOrDefault, flagToMaybe )
import qualified Distribution.Simple.Setup as Cabal
......@@ -146,10 +146,11 @@ install, upgrade
-> ConfigFlags
-> ConfigExFlags
-> InstallFlags
-> HaddockFlags
-> [UserTarget]
-> IO ()
install verbosity packageDBs repos comp conf
globalFlags configFlags configExFlags installFlags userTargets0 = do
globalFlags configFlags configExFlags installFlags haddockFlags userTargets0 = do
installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
sourcePkgDb <- getSourcePackages verbosity repos
......@@ -180,13 +181,13 @@ install verbosity packageDBs repos comp conf
where
context :: InstallContext
context = (packageDBs, repos, comp, conf,
globalFlags, configFlags, configExFlags, installFlags)
globalFlags, configFlags, configExFlags, installFlags, haddockFlags)
dryRun = fromFlag (installDryRun installFlags)
logMsg message rest = debug verbosity message >> rest
upgrade _ _ _ _ _ _ _ _ _ _ = die $
upgrade _ _ _ _ _ _ _ _ _ _ _ = die $
"Use the 'cabal install' command instead of 'cabal upgrade'.\n"
++ "You can install the latest version of a package using 'cabal install'. "
++ "The 'cabal upgrade' command has been removed because people found it "
......@@ -206,7 +207,8 @@ type InstallContext = ( PackageDBStack
, GlobalFlags
, ConfigFlags
, ConfigExFlags
, InstallFlags )
, InstallFlags
, HaddockFlags )
-- ------------------------------------------------------------
-- * Installation planning
......@@ -397,7 +399,7 @@ postInstallActions :: Verbosity
-> InstallPlan
-> IO ()
postInstallActions verbosity
(packageDBs, _, comp, conf, globalFlags, configFlags, _, installFlags)
(packageDBs, _, comp, conf, globalFlags, configFlags, _, installFlags, _)
targets installPlan = do
unless oneShot $
......@@ -590,7 +592,7 @@ performInstallations :: Verbosity
-> IO InstallPlan
performInstallations verbosity
(packageDBs, _, comp, conf,
globalFlags, configFlags, configExFlags, installFlags)
globalFlags, configFlags, configExFlags, installFlags, haddockFlags)
installedPkgIndex installPlan = do
executeInstallPlan installPlan $ \cpkg ->
......@@ -600,7 +602,7 @@ performInstallations verbosity
installLocalPackage verbosity (packageId pkg) src' $ \mpath ->
installUnpackedPackage verbosity
(setupScriptOptions installedPkgIndex)
miscOptions configFlags' installFlags
miscOptions configFlags' installFlags haddockFlags
compid pkg mpath useLogFile
where
......@@ -757,13 +759,14 @@ installUnpackedPackage :: Verbosity
-> InstallMisc
-> ConfigFlags
-> InstallFlags
-> HaddockFlags
-> CompilerId
-> PackageDescription
-> Maybe FilePath -- ^ Directory to change to before starting the installation.
-> Maybe (PackageIdentifier -> FilePath) -- ^ File to log output to (if any)
-> IO BuildResult
installUnpackedPackage verbosity scriptOptions miscOptions
configFlags installConfigFlags
configFlags installConfigFlags haddockFlags
compid pkg workingDir useLogFile =
-- Configure phase
......@@ -776,7 +779,7 @@ installUnpackedPackage verbosity scriptOptions miscOptions
-- Doc generation phase
docsResult <- if shouldHaddock
then (do setup haddockCommand haddockFlags
then (do setup haddockCommand haddockFlags'
return DocsOk)
`catchIO` (\_ -> return DocsFailed)
`catchExit` (\_ -> return DocsFailed)
......@@ -803,8 +806,7 @@ installUnpackedPackage verbosity scriptOptions miscOptions
buildVerbosity = toFlag verbosity'
}
shouldHaddock = fromFlag (installDocumentation installConfigFlags)
haddockFlags _ = emptyHaddockFlags {
haddockDistPref = configDistPref configFlags,
haddockFlags' _ = haddockFlags {
haddockVerbosity = toFlag verbosity'
}
installFlags _ = Cabal.emptyInstallFlags {
......
......@@ -48,9 +48,9 @@ import Distribution.Simple.Program
import Distribution.Simple.Command hiding (boolOpt)
import qualified Distribution.Simple.Command as Command
import qualified Distribution.Simple.Setup as Cabal
( configureCommand, sdistCommand )
( configureCommand, sdistCommand, haddockCommand )
import Distribution.Simple.Setup
( ConfigFlags(..), SDistFlags(..) )
( ConfigFlags(..), SDistFlags(..), HaddockFlags(..) )
import Distribution.Simple.Setup
( Flag(..), toFlag, fromFlag, flagToList, flagToMaybe
, optionVerbosity, trueArg, falseArg )
......@@ -225,7 +225,6 @@ filterConfigureFlags flags cabalLibVersion
-- older Cabal does not grok the constraints flag:
| otherwise = flags { configConstraints = [] }
-- ------------------------------------------------------------
-- * Config extra flags
-- ------------------------------------------------------------
......@@ -356,13 +355,13 @@ updateCommand = CommandUI {
commandOptions = \_ -> [optionVerbosity id const]
}
upgradeCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags)
upgradeCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
upgradeCommand = configureCommand {
commandName = "upgrade",
commandSynopsis = "(command disabled, use install instead)",
commandDescription = Nothing,
commandUsage = usagePackages "upgrade",
commandDefaultFlags = (mempty, mempty, mempty),
commandDefaultFlags = (mempty, mempty, mempty, mempty),
commandOptions = commandOptions installCommand
}
......@@ -605,7 +604,7 @@ defaultInstallFlags = InstallFlags {
where
docIndexFile = toPathTemplate ("$datadir" </> "doc" </> "index.html")
installCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags)
installCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
installCommand = CommandUI {
commandName = "install",
commandSynopsis = "Installs a list of packages.",
......@@ -624,17 +623,36 @@ installCommand = CommandUI {
++ " Specific version of a package\n"
++ " " ++ pname ++ " install 'foo < 2' "
++ " Constrained package version\n",
commandDefaultFlags = (mempty, mempty, mempty),
commandDefaultFlags = (mempty, mempty, mempty, mempty),
commandOptions = \showOrParseArgs ->
liftOptions get1 set1 (filter ((/="constraint") . optionName) $
configureOptions showOrParseArgs)
++ liftOptions get2 set2 (configureExOptions showOrParseArgs)
++ liftOptions get3 set3 (installOptions showOrParseArgs)
++ liftOptions get4 set4 (haddockOptions showOrParseArgs)
}
where
get1 (a,_,_) = a; set1 a (_,b,c) = (a,b,c)
get2 (_,b,_) = b; set2 b (a,_,c) = (a,b,c)
get3 (_,_,c) = c; set3 c (a,b,_) = (a,b,c)
get1 (a,_,_,_) = a; set1 a (_,b,c,d) = (a,b,c,d)
get2 (_,b,_,_) = b; set2 b (a,_,c,d) = (a,b,c,d)
get3 (_,_,c,_) = c; set3 c (a,b,_,d) = (a,b,c,d)
get4 (_,_,_,d) = d; set4 d (a,b,c,_) = (a,b,c,d)
haddockOptions showOrParseArgs
= [ opt { optionName = "haddock-" ++ name,
optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map ("haddock-" ++) lflags)) descr
| descr <- optionDescr opt] }
| opt <- commandOptions Cabal.haddockCommand showOrParseArgs
, let name = optionName opt
, name `elem` ["hoogle", "html", "html-location",
"executables", "internal", "css",
"hyperlink-source", "hscolour-css"]
]
fmapOptFlags :: (OptFlags -> OptFlags) -> OptDescr a -> OptDescr a
fmapOptFlags modify (ReqArg d f p r w) = ReqArg d (modify f) p r w
fmapOptFlags modify (OptArg d f p r i w) = OptArg d (modify f) p r i w
fmapOptFlags modify (ChoiceOpt xs) = ChoiceOpt [(d, modify f, i, w) | (d, f, i, w) <- xs]
fmapOptFlags modify (BoolOpt d f1 f2 r w) = BoolOpt d (modify f1) (modify f2) r w
installOptions :: ShowOrParseArgs -> [OptionField InstallFlags]
installOptions showOrParseArgs =
......
......@@ -184,15 +184,15 @@ configureAction (configFlags, configExFlags) extraArgs globalFlags = do
(configPackageDB' configFlags') (globalRepos globalFlags')
comp conf configFlags' configExFlags' extraArgs
installAction :: (ConfigFlags, ConfigExFlags, InstallFlags)
installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
-> [String] -> GlobalFlags -> IO ()
installAction (configFlags, _, installFlags) _ _globalFlags
installAction (configFlags, _, installFlags, _) _ _globalFlags
| fromFlagOrDefault False (installOnly installFlags)
= let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
in setupWrapper verbosity defaultSetupScriptOptions Nothing
installCommand (const mempty) []
installAction (configFlags, configExFlags, installFlags)
installAction (configFlags, configExFlags, installFlags, haddockFlags)
extraArgs globalFlags = do
let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
targets <- readUserTargets verbosity extraArgs
......@@ -206,7 +206,7 @@ installAction (configFlags, configExFlags, installFlags)
(comp, conf) <- configCompilerAux' configFlags'
install verbosity
(configPackageDB' configFlags') (globalRepos globalFlags')
comp conf globalFlags' configFlags' configExFlags' installFlags'
comp conf globalFlags' configFlags' configExFlags' installFlags' haddockFlags
targets
listAction :: ListFlags -> [String] -> GlobalFlags -> IO ()
......@@ -250,9 +250,9 @@ updateAction verbosityFlag extraArgs globalFlags = do
let globalFlags' = savedGlobalFlags config `mappend` globalFlags
update verbosity (globalRepos globalFlags')
upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags)
upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
-> [String] -> GlobalFlags -> IO ()
upgradeAction (configFlags, configExFlags, installFlags)
upgradeAction (configFlags, configExFlags, installFlags, haddockFlags)
extraArgs globalFlags = do
let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
targets <- readUserTargets verbosity extraArgs
......@@ -266,7 +266,7 @@ upgradeAction (configFlags, configExFlags, installFlags)
(comp, conf) <- configCompilerAux' configFlags'
upgrade verbosity
(configPackageDB' configFlags') (globalRepos globalFlags')
comp conf globalFlags' configFlags' configExFlags' installFlags'
comp conf globalFlags' configFlags' configExFlags' installFlags' haddockFlags
targets
fetchAction :: FetchFlags -> [String] -> GlobalFlags -> IO ()
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment