Commit 6cd7bb5e authored by Oleg Grenrus's avatar Oleg Grenrus

Change manpage command to man

And make it pipe output to `man -l -`.
parent f5547610
......@@ -35,6 +35,9 @@ import qualified System.Process as P
-- exception. This variant catches \"does not exist\" and
-- \"permission denied\" exceptions and turns them into
-- @ExitFailure@s.
--
-- TODO: this doesn't use 'Distrubution.Compat.Process'.
--
readProcessWithExitCode :: FilePath -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode cmd args input =
P.readProcessWithExitCode cmd args input
......
......@@ -14,16 +14,31 @@
module Distribution.Client.Manpage
( -- * Manual page generation
manpage
, manpageCmd
, ManpageFlags
, defaultManpageFlags
, manpageOptions
) where
import Distribution.Client.Compat.Prelude
import Prelude ()
import Distribution.Client.ManpageFlags
import Distribution.Client.Setup (globalCommand)
import Distribution.Compat.Process (createProcess)
import Distribution.Simple.Command
import Distribution.Client.Setup (globalCommand)
import Distribution.Simple.Flag (fromFlagOrDefault)
import System.Exit (exitWith)
import System.IO (hClose, hPutStr)
import Data.Char (toUpper)
import Data.List (intercalate)
import qualified System.Process as Process
data FileInfo = FileInfo String String -- ^ path, description
-------------------------------------------------------------------------------
--
-------------------------------------------------------------------------------
-- | A list of files that should be documented in the manual page.
files :: [FileInfo]
files =
......@@ -31,6 +46,33 @@ files =
, (FileInfo "~/.cabal/world" "A list of all packages whose installation has been explicitly requested.")
]
manpageCmd :: String -> [CommandSpec a] -> ManpageFlags -> IO ()
manpageCmd pname commands flags
| fromFlagOrDefault False (manpageRaw flags)
= putStrLn contents
| otherwise
= do
let cmd = "man"
args = ["-l", "-"]
(mb_in, _, _, ph) <- createProcess (Process.proc cmd args)
{ Process.std_in = Process.CreatePipe
, Process.std_out = Process.Inherit
, Process.std_err = Process.Inherit
}
-- put contents
for_ mb_in $ \hin -> do
hPutStr hin contents
hClose hin
-- wait for process to exit, propagate exit code
ec <- Process.waitForProcess ph
exitWith ec
where
contents :: String
contents = manpage pname commands
-- | Produces a manual page with @troff@ markup.
manpage :: String -> [CommandSpec a] -> String
manpage pname commands = unlines $
......
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
module Distribution.Client.ManpageFlags
( ManpageFlags (..)
, defaultManpageFlags
, manpageOptions,
) where
import Distribution.Client.Compat.Prelude
import Distribution.Simple.Command (OptionField (..), ShowOrParseArgs (..), option)
import Distribution.Simple.Setup (Flag (..), toFlag, trueArg, optionVerbosity)
import Distribution.Verbosity (Verbosity, normal)
data ManpageFlags = ManpageFlags
{ manpageVerbosity :: Flag Verbosity
, manpageRaw :: Flag Bool
} deriving (Eq, Show, Generic)
instance Monoid ManpageFlags where
mempty = gmempty
mappend = (<>)
instance Semigroup ManpageFlags where
(<>) = gmappend
defaultManpageFlags :: ManpageFlags
defaultManpageFlags = ManpageFlags
{ manpageVerbosity = toFlag normal
, manpageRaw = toFlag False
}
manpageOptions :: ShowOrParseArgs -> [OptionField ManpageFlags]
manpageOptions _ =
[ optionVerbosity manpageVerbosity (\v flags -> flags { manpageVerbosity = v })
, option "" ["raw"]
"Output raw troff content"
manpageRaw (\v flags -> flags { manpageRaw = v })
trueArg
]
......@@ -144,6 +144,7 @@ import Distribution.Client.GlobalFlags
( GlobalFlags(..), defaultGlobalFlags
, RepoContext(..), withRepoContext
)
import Distribution.Client.ManpageFlags (ManpageFlags, defaultManpageFlags, manpageOptions)
import Data.List
( deleteFirstsBy )
......@@ -1435,16 +1436,16 @@ uninstallCommand = CommandUI {
commandOptions = \_ -> []
}
manpageCommand :: CommandUI (Flag Verbosity)
manpageCommand :: CommandUI ManpageFlags
manpageCommand = CommandUI {
commandName = "manpage",
commandName = "man",
commandSynopsis = "Outputs manpage source.",
commandDescription = Just $ \_ ->
"Output manpage source to STDOUT.\n",
commandNotes = Nothing,
commandUsage = usageFlags "manpage",
commandDefaultFlags = toFlag normal,
commandOptions = \_ -> [optionVerbosity id const]
commandUsage = usageFlags "man",
commandDefaultFlags = defaultManpageFlags,
commandOptions = manpageOptions
}
runCommand :: CommandUI (BuildFlags, BuildExFlags)
......
......@@ -54,7 +54,7 @@ buildManpage lbi verbosity = do
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
_ <- runProcess cabal ["man","--raw"] Nothing Nothing Nothing (Just manpageHandle) Nothing
return ()
installManpage :: PackageDescription -> LocalBuildInfo -> Verbosity -> CopyDest -> IO ()
......
......@@ -218,6 +218,7 @@ executable cabal
Distribution.Client.JobControl
Distribution.Client.List
Distribution.Client.Manpage
Distribution.Client.ManpageFlags
Distribution.Client.Nix
Distribution.Client.Outdated
Distribution.Client.PackageHash
......
......@@ -150,6 +150,7 @@ Version: 3.3.0.0
Distribution.Client.JobControl
Distribution.Client.List
Distribution.Client.Manpage
Distribution.Client.ManpageFlags
Distribution.Client.Nix
Distribution.Client.Outdated
Distribution.Client.PackageHash
......
......@@ -138,7 +138,8 @@ import Distribution.Client.Sandbox.Types (UseSandbox(..), whenUsingSandbox)
import Distribution.Client.Tar (createTarGzFile)
import Distribution.Client.Types (Password (..))
import Distribution.Client.Init (initCabal)
import Distribution.Client.Manpage (manpage)
import Distribution.Client.Manpage (manpageCmd)
import Distribution.Client.ManpageFlags (ManpageFlags (..))
import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade
import Distribution.Client.Utils (determineNumJobs
,relaxEncodingErrors
......@@ -1244,13 +1245,13 @@ actAsSetupAction actAsSetupFlags args _globalFlags =
Make -> Make.defaultMainArgs args
Custom -> error "actAsSetupAction Custom"
manpageAction :: [CommandSpec action] -> Flag Verbosity -> [String] -> Action
manpageAction commands flagVerbosity extraArgs _ = do
let verbosity = fromFlag flagVerbosity
manpageAction :: [CommandSpec action] -> ManpageFlags -> [String] -> Action
manpageAction commands flags extraArgs _ = do
let verbosity = fromFlag (manpageVerbosity flags)
unless (null extraArgs) $
die' verbosity $ "'manpage' doesn't take any extra arguments: " ++ unwords extraArgs
pname <- getProgName
let cabalCmd = if takeExtension pname == ".exe"
then dropExtension pname
else pname
putStrLn $ manpage cabalCmd commands
manpageCmd cabalCmd commands flags
import Test.Cabal.Prelude
main = cabalTest $ do
r <- cabal' "manpage" []
r <- cabal' "man" ["--raw"]
assertOutputContains ".B cabal install" r
assertOutputDoesNotContain ".B cabal manpage" r
......@@ -294,7 +294,7 @@ cabalG' global_args cmd args = do
-- Sandboxes manage dist dir
| testHaveSandbox env
= install_args
| cmd `elem` ["v1-update", "outdated", "user-config", "manpage", "v1-freeze", "check"]
| cmd `elem` ["v1-update", "outdated", "user-config", "man", "v1-freeze", "check"]
= [ ]
-- new-build commands are affected by testCabalProjectFile
| cmd == "v2-sdist" = [ "--project-file", testCabalProjectFile env ]
......
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