Commit d1b72558 authored by Maciek Makowski's avatar Maciek Makowski

Manual page generation.

parent 97ccac0b
{-# LANGUAGE CPP, ExistentialQuantification #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Manpage
-- Copyright : (c) Maciek Makowski 2015
-- License : BSD-like
--
-- Maintainer : cabal-devel@haskell.org
-- Stability : provisional
-- Portability : non-portable (ExistentialQuantification)
--
-- Functions and types for building the manual page.
module Distribution.Client.Manpage
( -- * Command list
CommandVisibility (..)
, CommandSpec (..)
, commandFromSpec
-- * Manual page generation
, manpage
) where
import Distribution.Simple.Command
import Distribution.Client.Setup (globalCommand)
import Data.Char (toUpper)
import Data.List (intercalate)
data CommandVisibility = Visible | Hidden
-- | wraps a @CommandUI@ together with a function that turns it into a @Command@.
-- By hiding the type of flags for the UI allows construction of a list of all UIs at the
-- top level of the program. That list can then be used for generation of manual page
-- as well as for executing the selected command.
data CommandSpec action
= forall flags. CommandSpec (CommandUI flags) (CommandUI flags -> Command action) CommandVisibility
commandFromSpec :: CommandSpec a -> Command a
commandFromSpec (CommandSpec ui action _) = action ui
data FileInfo = FileInfo String String -- ^ path, description
-- | A list of files that should be documented in the manual page.
files :: [FileInfo]
files =
[ (FileInfo "~/.cabal/config" "The defaults that can be overridden with command-line options.")
, (FileInfo "~/.cabal/world" "A list of all packages whose installation has been explicitly requested.")
]
-- | Produces a manual page with @troff@ markup.
manpage :: String -> [CommandSpec a] -> String
manpage pname commands = unlines $
[ ".TH " ++ map toUpper pname ++ " 1"
, ".SH NAME"
, pname ++ " \\- a system for building and packaging Haskell libraries and programs"
, ".SH SYNOPSIS"
, ".B " ++ pname
, ".I command"
, ".RI < arguments |[ options ]>..."
, ""
, "Where the"
, ".I commands"
, "are"
, ""
] ++
concatMap (commandSynopsisLines pname) commands ++
[ ".SH DESCRIPTION"
, "Cabal is the standard package system for Haskell software. It helps people to configure, "
, "build and install Haskell software and to distribute it easily to other users and developers."
, ""
, "The command line " ++ pname ++ " tool (also referred to as cabal-install) helps with "
, "installing existing packages and developing new packages. "
, "It can be used to work with local packages or to install packages from online package archives, "
, "including automatically installing dependencies. By default it is configured to use Hackage, "
, "which is Haskell’s central package archive that contains thousands of libraries and applications "
, "in the Cabal package format."
, ".SH OPTIONS"
, "Global options:"
, ""
] ++
optionsLines (globalCommand []) ++
[ ".SH COMMANDS"
] ++
concatMap (commandDetailsLines pname) commands ++
[ ".SH FILES"
] ++
concatMap fileLines files ++
[ ".SH BUGS"
, "To browse the list of known issues or report a new one please see "
, "https://github.com/haskell/cabal/labels/cabal-install."
]
commandSynopsisLines :: String -> CommandSpec action -> [String]
commandSynopsisLines pname (CommandSpec ui _ Visible) =
[ ".B " ++ pname ++ " " ++ (commandName ui)
, ".R - " ++ commandSynopsis ui
, ".br"
]
commandSynopsisLines _ (CommandSpec _ _ Hidden) = []
commandDetailsLines :: String -> CommandSpec action -> [String]
commandDetailsLines pname (CommandSpec ui _ Visible) =
[ ".B " ++ pname ++ " " ++ (commandName ui)
, ""
, commandUsage ui pname
, ""
] ++
optional commandDescription ++
optional commandNotes ++
[ "Flags:"
, ".RS"
] ++
optionsLines ui ++
[ ".RE"
, ""
]
where
optional field =
case field ui of
Just text -> [text pname, ""]
Nothing -> []
commandDetailsLines _ (CommandSpec _ _ Hidden) = []
optionsLines :: CommandUI flags -> [String]
optionsLines command = concatMap optionLines (concatMap optionDescr (commandOptions command ParseArgs))
data ArgumentRequired = Optional | Required
type OptionArg = (ArgumentRequired, ArgPlaceHolder)
optionLines :: OptDescr flags -> [String]
optionLines (ReqArg description (optionChars, optionStrings) placeHolder _ _) =
argOptionLines description optionChars optionStrings (Required, placeHolder)
optionLines (OptArg description (optionChars, optionStrings) placeHolder _ _ _) =
argOptionLines description optionChars optionStrings (Optional, placeHolder)
optionLines (BoolOpt description (trueChars, trueStrings) (falseChars, falseStrings) _ _) =
optionLinesIfPresent trueChars trueStrings ++
optionLinesIfPresent falseChars falseStrings ++
optionDescriptionLines description
optionLines (ChoiceOpt options) =
concatMap choiceLines options
where
choiceLines (description, (optionChars, optionStrings), _, _) =
[ optionsLine optionChars optionStrings ] ++
optionDescriptionLines description
argOptionLines :: String -> [Char] -> [String] -> OptionArg -> [String]
argOptionLines description optionChars optionStrings arg =
[ optionsLine optionChars optionStrings
, optionArgLine arg
] ++
optionDescriptionLines description
optionLinesIfPresent :: [Char] -> [String] -> [String]
optionLinesIfPresent optionChars optionStrings =
if null optionChars && null optionStrings then []
else [ optionsLine optionChars optionStrings, ".br" ]
optionDescriptionLines :: String -> [String]
optionDescriptionLines description =
[ ".RS"
, description
, ".RE"
, ""
]
optionsLine :: [Char] -> [String] -> String
optionsLine optionChars optionStrings =
intercalate ", " (shortOptions optionChars ++ longOptions optionStrings)
shortOptions :: [Char] -> [String]
shortOptions = map (\c -> "\\-" ++ [c])
longOptions :: [String] -> [String]
longOptions = map (\s -> "\\-\\-" ++ s)
optionArgLine :: OptionArg -> String
optionArgLine (Required, placeHolder) = ".I " ++ placeHolder
optionArgLine (Optional, placeHolder) = ".RI [ " ++ placeHolder ++ " ]"
fileLines :: FileInfo -> [String]
fileLines (FileInfo path description) =
[ path
, ".RS"
, description
, ".RE"
, ""
]
......@@ -39,6 +39,7 @@ module Distribution.Client.Setup
, sandboxCommand, defaultSandboxLocation, SandboxFlags(..)
, execCommand, ExecFlags(..)
, userConfigCommand, UserConfigFlags(..)
, manpageCommand
, parsePackageArgs
--TODO: stop exporting these:
......@@ -878,6 +879,18 @@ uninstallCommand = CommandUI {
commandOptions = \_ -> []
}
manpageCommand :: CommandUI (Flag Verbosity)
manpageCommand = CommandUI {
commandName = "manpage",
commandSynopsis = "Outputs manpage source.",
commandDescription = Just $ \_ ->
"Output manpage source to STDOUT.\n",
commandNotes = Nothing,
commandUsage = usageFlags "manpage",
commandDefaultFlags = toFlag normal,
commandOptions = \_ -> [optionVerbosity id const]
}
runCommand :: CommandUI (BuildFlags, BuildExFlags)
runCommand = CommandUI {
commandName = "run",
......
......@@ -42,6 +42,7 @@ import Distribution.Client.Setup
, ExecFlags(..), execCommand
, UserConfigFlags(..), userConfigCommand
, reportCommand
, manpageCommand
)
import Distribution.Simple.Setup
( HaddockFlags(..), haddockCommand, defaultHaddockFlags
......@@ -109,6 +110,10 @@ import Distribution.Client.Sandbox.Timestamp (maybeAddCompilerTimestampRecord)
import Distribution.Client.Sandbox.Types (UseSandbox(..), whenUsingSandbox)
import Distribution.Client.Types (Password (..))
import Distribution.Client.Init (initCabal)
import Distribution.Client.Manpage (CommandVisibility(..)
,CommandSpec(..)
,commandFromSpec
,manpage)
import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade
import Distribution.Client.Utils (determineNumJobs
#if defined(mingw32_HOST_OS)
......@@ -229,55 +234,57 @@ mainWorker args = topHandler $
++ display cabalVersion
++ " of the Cabal library "
commands =
[installCommand `commandAddAction` installAction
,updateCommand `commandAddAction` updateAction
,listCommand `commandAddAction` listAction
,infoCommand `commandAddAction` infoAction
,fetchCommand `commandAddAction` fetchAction
,freezeCommand `commandAddAction` freezeAction
,getCommand `commandAddAction` getAction
,hiddenCommand $
unpackCommand `commandAddAction` unpackAction
,checkCommand `commandAddAction` checkAction
,sdistCommand `commandAddAction` sdistAction
,uploadCommand `commandAddAction` uploadAction
,reportCommand `commandAddAction` reportAction
,runCommand `commandAddAction` runAction
,initCommand `commandAddAction` initAction
,configureExCommand `commandAddAction` configureAction
,buildCommand `commandAddAction` buildAction
,replCommand `commandAddAction` replAction
,sandboxCommand `commandAddAction` sandboxAction
,haddockCommand `commandAddAction` haddockAction
,execCommand `commandAddAction` execAction
,userConfigCommand `commandAddAction` userConfigAction
,cleanCommand `commandAddAction` cleanAction
,wrapperAction copyCommand
copyVerbosity copyDistPref
,wrapperAction hscolourCommand
hscolourVerbosity hscolourDistPref
,wrapperAction registerCommand
regVerbosity regDistPref
,testCommand `commandAddAction` testAction
,benchmarkCommand `commandAddAction` benchmarkAction
,hiddenCommand $
uninstallCommand `commandAddAction` uninstallAction
,hiddenCommand $
formatCommand `commandAddAction` formatAction
,hiddenCommand $
upgradeCommand `commandAddAction` upgradeAction
,hiddenCommand $
win32SelfUpgradeCommand`commandAddAction` win32SelfUpgradeAction
,hiddenCommand $
actAsSetupCommand`commandAddAction` actAsSetupAction
commands = map commandFromSpec commandSpecs
commandSpecs =
[ regularCmd installCommand installAction
, regularCmd updateCommand updateAction
, regularCmd listCommand listAction
, regularCmd infoCommand infoAction
, regularCmd fetchCommand fetchAction
, regularCmd freezeCommand freezeAction
, regularCmd getCommand getAction
, hiddenCmd unpackCommand unpackAction
, regularCmd checkCommand checkAction
, regularCmd sdistCommand sdistAction
, regularCmd uploadCommand uploadAction
, regularCmd reportCommand reportAction
, regularCmd runCommand runAction
, regularCmd initCommand initAction
, regularCmd configureExCommand configureAction
, regularCmd buildCommand buildAction
, regularCmd replCommand replAction
, regularCmd sandboxCommand sandboxAction
, regularCmd haddockCommand haddockAction
, regularCmd execCommand execAction
, regularCmd userConfigCommand userConfigAction
, regularCmd cleanCommand cleanAction
, wrapperCmd copyCommand copyVerbosity copyDistPref
, wrapperCmd hscolourCommand hscolourVerbosity hscolourDistPref
, wrapperCmd registerCommand regVerbosity regDistPref
, regularCmd testCommand testAction
, regularCmd benchmarkCommand benchmarkAction
, hiddenCmd uninstallCommand uninstallAction
, hiddenCmd formatCommand formatAction
, hiddenCmd upgradeCommand upgradeAction
, hiddenCmd win32SelfUpgradeCommand win32SelfUpgradeAction
, hiddenCmd actAsSetupCommand actAsSetupAction
, hiddenCmd manpageCommand (manpageAction commandSpecs)
]
type Action = GlobalFlags -> IO ()
regularCmd :: CommandUI flags -> (flags -> [String] -> action) -> CommandSpec action
regularCmd ui action = CommandSpec ui ((flip commandAddAction) action) Visible
hiddenCmd :: CommandUI flags -> (flags -> [String] -> action) -> CommandSpec action
hiddenCmd ui action = CommandSpec ui (\ui' -> hiddenCommand (commandAddAction ui' action)) Hidden
wrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Flag Verbosity) -> (flags -> Flag String) -> CommandSpec Action
wrapperCmd ui verbosity distPref = CommandSpec ui (\ui' -> wrapperAction ui' verbosity distPref) Visible
wrapperAction :: Monoid flags
=> CommandUI flags
-> (flags -> Flag Verbosity)
-> (flags -> Flag String)
-> Command (GlobalFlags -> IO ())
-> Command Action
wrapperAction command verbosityFlag distPrefFlag =
commandAddAction command
{ commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do
......@@ -289,7 +296,7 @@ wrapperAction command verbosityFlag distPrefFlag =
command (const flags) extraArgs
configureAction :: (ConfigFlags, ConfigExFlags)
-> [String] -> GlobalFlags -> IO ()
-> [String] -> Action
configureAction (configFlags, configExFlags) extraArgs globalFlags = do
let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
......@@ -325,7 +332,7 @@ configureAction (configFlags, configExFlags) extraArgs globalFlags = do
(globalRepos globalFlags')
comp platform conf configFlags'' configExFlags' extraArgs
buildAction :: (BuildFlags, BuildExFlags) -> [String] -> GlobalFlags -> IO ()
buildAction :: (BuildFlags, BuildExFlags) -> [String] -> Action
buildAction (buildFlags, buildExFlags) extraArgs globalFlags = do
let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags)
noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck
......@@ -379,7 +386,7 @@ filterBuildFlags version config buildFlags
numJobsCmdLineFlag = buildNumJobs buildFlags
replAction :: (ReplFlags, BuildExFlags) -> [String] -> GlobalFlags -> IO ()
replAction :: (ReplFlags, BuildExFlags) -> [String] -> Action
replAction (replFlags, buildExFlags) extraArgs globalFlags = do
cwd <- getCurrentDirectory
pkgDesc <- findPackageDesc cwd
......@@ -657,7 +664,7 @@ reconfigure verbosity flagDistPref addConfigFlags extraArgs globalFlags
++ configureManually
installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
-> [String] -> GlobalFlags -> IO ()
-> [String] -> Action
installAction (configFlags, _, installFlags, _) _ globalFlags
| fromFlagOrDefault False (installOnly installFlags) = do
let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
......@@ -844,7 +851,7 @@ benchmarkAction (benchmarkFlags, buildFlags, buildExFlags)
setupWrapper verbosity setupOptions Nothing
Cabal.benchmarkCommand (const benchmarkFlags') extraArgs'
haddockAction :: HaddockFlags -> [String] -> GlobalFlags -> IO ()
haddockAction :: HaddockFlags -> [String] -> Action
haddockAction haddockFlags extraArgs globalFlags = do
let verbosity = fromFlag (haddockVerbosity haddockFlags)
(_useSandbox, config, distPref) <-
......@@ -858,7 +865,7 @@ haddockAction haddockFlags extraArgs globalFlags = do
setupWrapper verbosity setupScriptOptions Nothing
haddockCommand (const haddockFlags') extraArgs
cleanAction :: CleanFlags -> [String] -> GlobalFlags -> IO ()
cleanAction :: CleanFlags -> [String] -> Action
cleanAction cleanFlags extraArgs globalFlags = do
(_, config) <- loadConfigOrSandboxConfig verbosity globalFlags
distPref <- findSavedDistPref config (cleanDistPref cleanFlags)
......@@ -872,7 +879,7 @@ cleanAction cleanFlags extraArgs globalFlags = do
where
verbosity = fromFlagOrDefault normal (cleanVerbosity cleanFlags)
listAction :: ListFlags -> [String] -> GlobalFlags -> IO ()
listAction :: ListFlags -> [String] -> Action
listAction listFlags extraArgs globalFlags = do
let verbosity = fromFlag (listVerbosity listFlags)
(_useSandbox, config) <- loadConfigOrSandboxConfig verbosity
......@@ -892,7 +899,7 @@ listAction listFlags extraArgs globalFlags = do
listFlags
extraArgs
infoAction :: InfoFlags -> [String] -> GlobalFlags -> IO ()
infoAction :: InfoFlags -> [String] -> Action
infoAction infoFlags extraArgs globalFlags = do
let verbosity = fromFlag (infoVerbosity infoFlags)
targets <- readUserTargets verbosity extraArgs
......@@ -914,7 +921,7 @@ infoAction infoFlags extraArgs globalFlags = do
infoFlags
targets
updateAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO ()
updateAction :: Flag Verbosity -> [String] -> Action
updateAction verbosityFlag extraArgs globalFlags = do
unless (null extraArgs) $
die $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs
......@@ -926,7 +933,7 @@ updateAction verbosityFlag extraArgs globalFlags = do
update transport verbosity (globalRepos globalFlags')
upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
-> [String] -> GlobalFlags -> IO ()
-> [String] -> Action
upgradeAction _ _ _ = die $
"Use the 'cabal install' command instead of 'cabal upgrade'.\n"
++ "You can install the latest version of a package using 'cabal install'. "
......@@ -940,7 +947,7 @@ upgradeAction _ _ _ = die $
++ "--upgrade-dependencies, it is recommended that you do not upgrade core "
++ "packages (e.g. by using appropriate --constraint= flags)."
fetchAction :: FetchFlags -> [String] -> GlobalFlags -> IO ()
fetchAction :: FetchFlags -> [String] -> Action
fetchAction fetchFlags extraArgs globalFlags = do
let verbosity = fromFlag (fetchVerbosity fetchFlags)
targets <- readUserTargets verbosity extraArgs
......@@ -954,7 +961,7 @@ fetchAction fetchFlags extraArgs globalFlags = do
comp platform conf globalFlags' fetchFlags
targets
freezeAction :: FreezeFlags -> [String] -> GlobalFlags -> IO ()
freezeAction :: FreezeFlags -> [String] -> Action
freezeAction freezeFlags _extraArgs globalFlags = do
let verbosity = fromFlag (freezeVerbosity freezeFlags)
(useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags
......@@ -972,7 +979,7 @@ freezeAction freezeFlags _extraArgs globalFlags = do
mSandboxPkgInfo
globalFlags' freezeFlags
uploadAction :: UploadFlags -> [String] -> GlobalFlags -> IO ()
uploadAction :: UploadFlags -> [String] -> Action
uploadAction uploadFlags extraArgs globalFlags = do
let verbosity = fromFlag (uploadVerbosity uploadFlags)
config <- loadConfig verbosity (globalConfigFile globalFlags)
......@@ -1012,14 +1019,14 @@ uploadAction uploadFlags extraArgs globalFlags = do
(file', ".gz") -> takeExtension file' == ".tar"
_ -> False
checkAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO ()
checkAction :: Flag Verbosity -> [String] -> Action
checkAction verbosityFlag extraArgs _globalFlags = do
unless (null extraArgs) $
die $ "'check' doesn't take any extra arguments: " ++ unwords extraArgs
allOk <- Check.check (fromFlag verbosityFlag)
unless allOk exitFailure
formatAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO ()
formatAction :: Flag Verbosity -> [String] -> Action
formatAction verbosityFlag extraArgs _globalFlags = do
let verbosity = fromFlag verbosityFlag
path <- case extraArgs of
......@@ -1030,7 +1037,7 @@ formatAction verbosityFlag extraArgs _globalFlags = do
-- Uses 'writeFileAtomic' under the hood.
writeGenericPackageDescription path pkgDesc
uninstallAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO ()
uninstallAction :: Flag Verbosity -> [String] -> Action
uninstallAction _verbosityFlag extraArgs _globalFlags = do
let package = case extraArgs of
p:_ -> p
......@@ -1041,7 +1048,7 @@ uninstallAction _verbosityFlag extraArgs _globalFlags = do
++ "'cabal sandbox hc-pkg -- unregister " ++ package ++ "'."
sdistAction :: (SDistFlags, SDistExFlags) -> [String] -> GlobalFlags -> IO ()
sdistAction :: (SDistFlags, SDistExFlags) -> [String] -> Action
sdistAction (sdistFlags, sdistExFlags) extraArgs globalFlags = do
unless (null extraArgs) $
die $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs
......@@ -1051,7 +1058,7 @@ sdistAction (sdistFlags, sdistExFlags) extraArgs globalFlags = do
let sdistFlags' = sdistFlags { sDistDistPref = toFlag distPref }
sdist sdistFlags' sdistExFlags
reportAction :: ReportFlags -> [String] -> GlobalFlags -> IO ()
reportAction :: ReportFlags -> [String] -> Action
reportAction reportFlags extraArgs globalFlags = do
unless (null extraArgs) $
die $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs
......@@ -1065,7 +1072,7 @@ reportAction reportFlags extraArgs globalFlags = do
(flagToMaybe $ reportUsername reportFlags')
(flagToMaybe $ reportPassword reportFlags')
runAction :: (BuildFlags, BuildExFlags) -> [String] -> GlobalFlags -> IO ()
runAction :: (BuildFlags, BuildExFlags) -> [String] -> Action
runAction (buildFlags, buildExFlags) extraArgs globalFlags = do
let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags)
let noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck
......@@ -1087,7 +1094,7 @@ runAction (buildFlags, buildExFlags) extraArgs globalFlags = do
maybeWithSandboxDirOnSearchPath useSandbox $
run verbosity lbi exe exeArgs
getAction :: GetFlags -> [String] -> GlobalFlags -> IO ()
getAction :: GetFlags -> [String] -> Action
getAction getFlags extraArgs globalFlags = do
let verbosity = fromFlag (getVerbosity getFlags)
targets <- readUserTargets verbosity extraArgs
......@@ -1100,11 +1107,11 @@ getAction getFlags extraArgs globalFlags = do
getFlags
targets
unpackAction :: GetFlags -> [String] -> GlobalFlags -> IO ()
unpackAction :: GetFlags -> [String] -> Action
unpackAction getFlags extraArgs globalFlags = do
getAction getFlags extraArgs globalFlags
initAction :: InitFlags -> [String] -> GlobalFlags -> IO ()
initAction :: InitFlags -> [String] -> Action
initAction initFlags _extraArgs globalFlags = do
let verbosity = fromFlag (initVerbosity initFlags)
(_useSandbox, config) <- loadConfigOrSandboxConfig verbosity
......@@ -1119,7 +1126,7 @@ initAction initFlags _extraArgs globalFlags = do
conf
initFlags
sandboxAction :: SandboxFlags -> [String] -> GlobalFlags -> IO ()
sandboxAction :: SandboxFlags -> [String] -> Action
sandboxAction sandboxFlags extraArgs globalFlags = do
let verbosity = fromFlag (sandboxVerbosity sandboxFlags)
case extraArgs of
......@@ -1154,7 +1161,7 @@ sandboxAction sandboxFlags extraArgs globalFlags = do
where
noExtraArgs = (<1) . length
execAction :: ExecFlags -> [String] -> GlobalFlags -> IO ()
execAction :: ExecFlags -> [String] -> Action
execAction execFlags extraArgs globalFlags = do
let verbosity = fromFlag (execVerbosity execFlags)
(useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags
......@@ -1162,7 +1169,7 @@ execAction execFlags extraArgs globalFlags = do
(comp, platform, conf) <- getPersistOrConfigCompiler configFlags
exec verbosity useSandbox comp platform conf extraArgs
userConfigAction :: UserConfigFlags -> [String] -> GlobalFlags -> IO ()
userConfigAction :: UserConfigFlags -> [String] -> Action
userConfigAction ucflags extraArgs globalFlags = do
let verbosity = fromFlag (userConfigVerbosity ucflags)
case extraArgs of
......@@ -1175,8 +1182,7 @@ userConfigAction ucflags extraArgs globalFlags = do
-- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details.
--
win32SelfUpgradeAction :: Win32SelfUpgradeFlags -> [String] -> GlobalFlags
-> IO ()
win32SelfUpgradeAction :: Win32SelfUpgradeFlags -> [String] -> Action
win32SelfUpgradeAction selfUpgradeFlags (pid:path:_extraArgs) _globalFlags = do
let verbosity = fromFlag (win32SelfUpgradeVerbosity selfUpgradeFlags)
Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path
......@@ -1185,7 +1191,7 @@ win32SelfUpgradeAction _ _ _ = return ()
-- | Used as an entry point when cabal-install needs to invoke itself
-- as a setup script. This can happen e.g. when doing parallel builds.
--
actAsSetupAction :: ActAsSetupFlags -> [String] -> GlobalFlags -> IO ()
actAsSetupAction :: ActAsSetupFlags -> [String] -> Action
actAsSetupAction actAsSetupFlags args _globalFlags =
let bt = fromFlag (actAsSetupBuildType actAsSetupFlags)
in case bt of
......@@ -1195,3 +1201,10 @@ actAsSetupAction actAsSetupFlags args _globalFlags =
Make -> Make.defaultMainArgs args
Custom -> error "actAsSetupAction Custom"
(UnknownBuildType _) -> error "actAsSetupAction UnknownBuildType"
manpageAction :: [CommandSpec action] -> Flag Verbosity -> [String] -> Action
manpageAction commands _ extraArgs _ = do
unless (null extraArgs) $
die $ "'manpage' doesn't take any extra arguments: " ++ unwords extraArgs
pname <- getProgName
putStrLn (manpage pname commands)
import Distribution.Simple
main = defaultMain
import Distribution.PackageDescription ( PackageDescription )
import Distribution.Simple ( UserHooks
, defaultMainWithHooks
, simpleUserHooks
, postBuild
, postCopy
, postInst
)
import Distribution.Simple.InstallDirs ( mandir
, CopyDest (NoCopyDest)
)
import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..)
, absoluteInstallDirs
)
import Distribution.Simple.Utils ( copyFiles
, notice )
import Distribution.Simple.Setup ( buildVerbosity
, copyDest
, copyVerbosity
, fromFlag
, installVerbosity
)
import Distribution.Verbosity ( Verbosity )
import System.IO ( openFile
, IOMode (WriteMode)
)
import System.Process ( runProcess )
import System.FilePath ( (</>) )
main :: IO ()
main = defaultMainWithHooks $ simpleUserHooks
{ postBuild = \ _ flags _ lbi ->
buildManpage lbi (fromFlag $ buildVerbosity flags)
, postCopy = \ _ flags pkg lbi ->
installManpage pkg lbi (fromFlag $ copyVerbosity flags) (fromFlag $ copyDest flags)
, postInst = \ _ flags pkg lbi ->
installManpage pkg lbi (fromFlag $ installVerbosity flags) NoCopyDest
}
buildManpage :: LocalBuildInfo -> Verbosity -> IO ()
buildManpage lbi verbosity = do
let cabal = buildDir lbi </> "cabal/cabal"
manpage = buildDir lbi </> "cabal/cabal.1"
manpageHandle <- openFile manpage WriteMode
notice verbosity ("Generating manual page " ++ manpage ++ " ...")
runProcess cabal ["manpage"] Nothing Nothing Nothing (Just manpageHandle) Nothing
return ()
installManpage :: PackageDescription -> LocalBuildInfo -> Verbosity -> CopyDest -> IO ()
installManpage pkg lbi verbosity copy = do
let destDir = mandir (absoluteInstallDirs pkg lbi copy) </> "man1"
copyFiles verbosity destDir [(buildDir lbi </> "cabal", "cabal.1")]
......@@ -28,15 +28,15 @@ Extra-Source-Files: