Skip to content

Commit

Permalink
Fix haskell#7714: use nroff -man | less as backend for cabal man
Browse files Browse the repository at this point in the history
Directly piping into `man -l -` does not work as BSD-`man` does not
understand option `-l`.  More standardized are the building blocks
`nroff` and `less`.

`cabal man` now should behave as pipeline
```
cabal man --raw | nroff -man /dev/stdin | less
```

Also fixed output of `cabal man --raw` so that it does not produce
warnings.

- `.R` removed.  Was warning:
  ```
  `R' is a string (producing the registered sign), not a macro.
  ```

- No quoted 'new-FOO' should appear at beginning of line.  Was
  warning:
  ```
  warning: macro `new-FOO'' not defined (probably missing space after `ne')
  ```

Added to `cabal-testsuite/PackageTests/Man/cabal.test.hs` a check that
the `stderr` output of `nroff -man /dev/stdin` is empty (no warnings).

Remaining problem:

Unfortunately, after quitting `less` with `q` the following error is
displayed:
```
fd:NNN: commitBuffer: resource vanished (Broken pipe)
```
Not sure how to fix this (my attempts failed).
  • Loading branch information
andreasabel committed Jan 20, 2022
1 parent 96ea35d commit e5b148b
Show file tree
Hide file tree
Showing 3 changed files with 81 additions and 24 deletions.
2 changes: 1 addition & 1 deletion cabal-install/main/Main.hs
Original file line number Diff line number Diff line change
Expand Up @@ -972,7 +972,7 @@ 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
die' verbosity $ "'man' doesn't take any extra arguments: " ++ unwords extraArgs
pname <- getProgName
let cabalCmd = if takeExtension pname == ".exe"
then dropExtension pname
Expand Down
87 changes: 64 additions & 23 deletions cabal-install/src/Distribution/Client/Manpage.hs
Original file line number Diff line number Diff line change
Expand Up @@ -22,12 +22,17 @@ module Distribution.Client.Manpage

import Distribution.Client.Compat.Prelude
import Prelude ()
import qualified Data.List.NonEmpty as List1

import Distribution.Client.Init.Utils (trim)
-- TODO #7744: move 'trim' to a more canonical place
import Distribution.Client.ManpageFlags
import Distribution.Client.Setup (globalCommand)
import Distribution.Compat.Process (createProcess)
import Distribution.Simple.Command
import Distribution.Simple.Flag (fromFlagOrDefault)
import Distribution.Simple.Utils
( IOData(..), IODataMode(..), createProcessWithEnv, rawSystemStdInOut )
import qualified Distribution.Verbosity as Verbosity
import System.IO (hClose, hPutStr)

import qualified System.Process as Process
Expand All @@ -50,23 +55,43 @@ manpageCmd pname commands 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
-- 2021-10-08, issue #7714
-- @cabal man --raw | man -l -@ does not work on macOS/BSD,
-- because BSD-man does not support option @-l@, rather would
-- accept directly a file argument, e.g. @man /dev/stdin@.
-- The following works both on macOS and Linux
-- (but not on Windows out-of-the-box):
--
-- cabal man --raw | nroff -man /dev/stdin | less
--
-- So let us simulate this!

-- Feed contents into @nroff -man /dev/stdin@
(formatted, _errors, ec1) <- rawSystemStdInOut
Verbosity.normal
"nroff"
[ "-man", "/dev/stdin" ]
Nothing -- Inherit working directory
Nothing -- Inherit environment
(Just $ IODataText contents)
IODataModeText

unless (ec1 == ExitSuccess) $ exitWith ec1

-- Pipe output of @nroff@ into @less@
(Just inLess, _, _, procLess) <- createProcessWithEnv
Verbosity.normal
"less"
[]
Nothing -- Inherit working directory
Nothing -- Inherit environment
Process.CreatePipe -- in
Process.Inherit -- out
Process.Inherit -- err

hPutStr inLess formatted
hClose inLess
exitWith =<< Process.waitForProcess procLess
where
contents :: String
contents = manpage pname commands
Expand Down Expand Up @@ -117,7 +142,7 @@ manpage pname commands = unlines $
commandSynopsisLines :: String -> CommandSpec action -> [String]
commandSynopsisLines pname (CommandSpec ui _ NormalCommand) =
[ ".B " ++ pname ++ " " ++ (commandName ui)
, ".R - " ++ commandSynopsis ui
, "- " ++ commandSynopsis ui
, ".br"
]
commandSynopsisLines _ (CommandSpec _ _ HiddenCommand) = []
Expand All @@ -129,8 +154,8 @@ commandDetailsLines pname (CommandSpec ui _ NormalCommand) =
, commandUsage ui pname
, ""
] ++
optional commandDescription ++
optional commandNotes ++
optional removeLineBreaks commandDescription ++
optional id commandNotes ++
[ "Flags:"
, ".RS"
] ++
Expand All @@ -139,10 +164,26 @@ commandDetailsLines pname (CommandSpec ui _ NormalCommand) =
, ""
]
where
optional field =
optional f field =
case field ui of
Just text -> [text pname, ""]
Just text -> [ f $ text pname, "" ]
Nothing -> []
-- 2021-10-12, https://github.com/haskell/cabal/issues/7714#issuecomment-940842905
-- Line breaks just before e.g. 'new-build' cause weird @nroff@ warnings.
-- Thus:
-- Remove line breaks but preserve paragraph breaks.
-- We group lines by empty/non-empty and then 'unwords'
-- blocks consisting of non-empty lines.
removeLineBreaks
= unlines
. concatMap unwordsNonEmpty
. List1.groupWith null
. map trim
. lines
unwordsNonEmpty :: List1.NonEmpty String -> [String]
unwordsNonEmpty ls1 = if null (List1.head ls1) then ls else [unwords ls]
where ls = List1.toList ls1

commandDetailsLines _ (CommandSpec _ _ HiddenCommand) = []

optionsLines :: CommandUI flags -> [String]
Expand Down
16 changes: 16 additions & 0 deletions cabal-testsuite/PackageTests/Manpage/cabal.test.hs
Original file line number Diff line number Diff line change
@@ -1,5 +1,21 @@
import System.Process
import Test.Cabal.Prelude


main = cabalTest $ do
r <- cabal' "man" ["--raw"]
assertOutputContains ".B cabal install" r
assertOutputDoesNotContain ".B cabal manpage" r

-- Check that output of `cabal man --raw` can be passed through `nroff -man`
-- without producing any warnings (which are printed to stderr).
--
-- NB: runM is not suitable as it mixes stdout and stderr
-- r2 <- runM "nroff" ["-man", "/dev/stdin"] $ Just $ resultOutput r
(ec, _output, errors) <- liftIO $
readProcessWithExitCode "nroff" ["-man", "/dev/stdin"] $ resultOutput r
unless (null errors) $
assertFailure $ unlines
[ "Error: unexpected warnings produced by `nroff -man`:"
, errors
]

0 comments on commit e5b148b

Please sign in to comment.