{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Client.Manpage
-- Copyright   :  (c) Maciek Makowski 2015
-- License     :  BSD-like
--
-- Maintainer  :  cabal-devel@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- Functions for building the manual page.

module Distribution.Client.Manpage
  ( -- * Manual page generation
    manpage
  , manpageCmd
  , ManpageFlags
  , defaultManpageFlags
  , manpageOptions
  ) where

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

import Distribution.Client.Init.Utils   (trim)
import Distribution.Client.ManpageFlags
import Distribution.Client.Setup        (globalCommand)
import Distribution.Simple.Command
import Distribution.Simple.Flag         (fromFlagOrDefault)
import Distribution.Simple.Utils
  ( IOData(..), IODataMode(..), createProcessWithEnv, ignoreSigPipe, rawSystemStdInOut )
import qualified Distribution.Verbosity as Verbosity
import System.IO                        (hClose, hPutStr)
import System.Environment               (lookupEnv)
import System.FilePath                  (takeFileName)

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 :: [FileInfo]
files =
  [ (String -> String -> FileInfo
FileInfo String
"~/.cabal/config" String
"The defaults that can be overridden with command-line options.")
  ]

manpageCmd :: String -> [CommandSpec a] -> ManpageFlags -> IO ()
manpageCmd :: String -> [CommandSpec a] -> ManpageFlags -> IO ()
manpageCmd String
pname [CommandSpec a]
commands ManpageFlags
flags
    | Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (ManpageFlags -> Flag Bool
manpageRaw ManpageFlags
flags)
    = String -> IO ()
putStrLn String
contents
    | Bool
otherwise
    = IO () -> IO ()
ignoreSigPipe (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        -- 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@
        (String
formatted, String
_errors, ExitCode
ec1) <- Verbosity
-> String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> Maybe IOData
-> IODataMode String
-> IO (String, String, ExitCode)
forall mode.
KnownIODataMode mode =>
Verbosity
-> String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> Maybe IOData
-> IODataMode mode
-> IO (mode, String, ExitCode)
rawSystemStdInOut
          Verbosity
Verbosity.normal
          String
"nroff"
          [ String
"-man", String
"/dev/stdin" ]
          Maybe String
forall a. Maybe a
Nothing  -- Inherit working directory
          Maybe [(String, String)]
forall a. Maybe a
Nothing  -- Inherit environment
          (IOData -> Maybe IOData
forall a. a -> Maybe a
Just (IOData -> Maybe IOData) -> IOData -> Maybe IOData
forall a b. (a -> b) -> a -> b
$ String -> IOData
IODataText String
contents)
          IODataMode String
IODataModeText

        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ExitCode
ec1 ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith ExitCode
ec1

        String
pager <- String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"less" (Maybe String -> String) -> IO (Maybe String) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"PAGER"
        -- 'less' is borked with color sequences otherwise
        let pagerArgs :: [String]
pagerArgs = if String -> String
takeFileName String
pager String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"less" then [String
"-R"] else []
        -- Pipe output of @nroff@ into @less@
        (Just Handle
inLess, Maybe Handle
_, Maybe Handle
_, ProcessHandle
procLess) <- Verbosity
-> String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> StdStream
-> StdStream
-> StdStream
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcessWithEnv
          Verbosity
Verbosity.normal
          String
pager
          [String]
pagerArgs
          Maybe String
forall a. Maybe a
Nothing  -- Inherit working directory
          Maybe [(String, String)]
forall a. Maybe a
Nothing  -- Inherit environment
          StdStream
Process.CreatePipe  -- in
          StdStream
Process.Inherit     -- out
          StdStream
Process.Inherit     -- err

        Handle -> String -> IO ()
hPutStr Handle
inLess String
formatted
        Handle -> IO ()
hClose  Handle
inLess
        ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO ()) -> IO ExitCode -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ProcessHandle -> IO ExitCode
Process.waitForProcess ProcessHandle
procLess
  where
    contents :: String
    contents :: String
contents = String -> [CommandSpec a] -> String
forall a. String -> [CommandSpec a] -> String
manpage String
pname [CommandSpec a]
commands

-- | Produces a manual page with @troff@ markup.
manpage :: String -> [CommandSpec a] -> String
manpage :: String -> [CommandSpec a] -> String
manpage String
pname [CommandSpec a]
commands = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
  [ String
".TH " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper String
pname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 1"
  , String
".SH NAME"
  , String
pname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" \\- a system for building and packaging Haskell libraries and programs"
  , String
".SH SYNOPSIS"
  , String
".B " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pname
  , String
".I command"
  , String
".RI < arguments |[ options ]>..."
  , String
""
  , String
"Where the"
  , String
".I commands"
  , String
"are"
  , String
""
  ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
  (CommandSpec a -> [String]) -> [CommandSpec a] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String -> CommandSpec a -> [String]
forall action. String -> CommandSpec action -> [String]
commandSynopsisLines String
pname) [CommandSpec a]
commands [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
  [ String
".SH DESCRIPTION"
  , String
"Cabal is the standard package system for Haskell software. It helps people to configure, "
  , String
"build and install Haskell software and to distribute it easily to other users and developers."
  , String
""
  , String
"The command line " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" tool (also referred to as cabal-install) helps with "
  , String
"installing existing packages and developing new packages. "
  , String
"It can be used to work with local packages or to install packages from online package archives, "
  , String
"including automatically installing dependencies. By default it is configured to use Hackage, "
  , String
"which is Haskell's central package archive that contains thousands of libraries and applications "
  , String
"in the Cabal package format."
  , String
".SH OPTIONS"
  , String
"Global options:"
  , String
""
  ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
  CommandUI GlobalFlags -> [String]
forall flags. CommandUI flags -> [String]
optionsLines ([Command Any] -> CommandUI GlobalFlags
forall action. [Command action] -> CommandUI GlobalFlags
globalCommand []) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
  [ String
".SH COMMANDS"
  ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
  (CommandSpec a -> [String]) -> [CommandSpec a] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String -> CommandSpec a -> [String]
forall action. String -> CommandSpec action -> [String]
commandDetailsLines String
pname) [CommandSpec a]
commands [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
  [ String
".SH FILES"
  ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
  (FileInfo -> [String]) -> [FileInfo] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap FileInfo -> [String]
fileLines [FileInfo]
files [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
  [ String
".SH BUGS"
  , String
"To browse the list of known issues or report a new one please see "
  , String
"https://github.com/haskell/cabal/labels/cabal-install."
  ]

commandSynopsisLines :: String -> CommandSpec action -> [String]
commandSynopsisLines :: String -> CommandSpec action -> [String]
commandSynopsisLines String
pname (CommandSpec CommandUI flags
ui CommandUI flags -> Command action
_ CommandType
NormalCommand) =
  [ String
".B " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (CommandUI flags -> String
forall flags. CommandUI flags -> String
commandName CommandUI flags
ui)
  , String
"- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CommandUI flags -> String
forall flags. CommandUI flags -> String
commandSynopsis CommandUI flags
ui
  , String
".br"
  ]
commandSynopsisLines String
_ (CommandSpec CommandUI flags
_ CommandUI flags -> Command action
_ CommandType
HiddenCommand) = []

commandDetailsLines :: String -> CommandSpec action -> [String]
commandDetailsLines :: String -> CommandSpec action -> [String]
commandDetailsLines String
pname (CommandSpec CommandUI flags
ui CommandUI flags -> Command action
_ CommandType
NormalCommand) =
  [ String
".B " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (CommandUI flags -> String
forall flags. CommandUI flags -> String
commandName CommandUI flags
ui)
  , String
""
  , CommandUI flags -> String -> String
forall flags. CommandUI flags -> String -> String
commandUsage CommandUI flags
ui String
pname
  , String
""
  ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
  (String -> String)
-> (CommandUI flags -> Maybe (String -> String)) -> [String]
forall t.
(t -> String)
-> (CommandUI flags -> Maybe (String -> t)) -> [String]
optional String -> String
removeLineBreaks CommandUI flags -> Maybe (String -> String)
forall flags. CommandUI flags -> Maybe (String -> String)
commandDescription [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
  (String -> String)
-> (CommandUI flags -> Maybe (String -> String)) -> [String]
forall t.
(t -> String)
-> (CommandUI flags -> Maybe (String -> t)) -> [String]
optional String -> String
forall a. a -> a
id CommandUI flags -> Maybe (String -> String)
forall flags. CommandUI flags -> Maybe (String -> String)
commandNotes [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
  [ String
"Flags:"
  , String
".RS"
  ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
  CommandUI flags -> [String]
forall flags. CommandUI flags -> [String]
optionsLines CommandUI flags
ui [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
  [ String
".RE"
  , String
""
  ]
  where
    optional :: (t -> String)
-> (CommandUI flags -> Maybe (String -> t)) -> [String]
optional t -> String
f CommandUI flags -> Maybe (String -> t)
field =
      case CommandUI flags -> Maybe (String -> t)
field CommandUI flags
ui of
        Just String -> t
text -> [ t -> String
f (t -> String) -> t -> String
forall a b. (a -> b) -> a -> b
$ String -> t
text String
pname, String
"" ]
        Maybe (String -> t)
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 :: String -> String
removeLineBreaks
      = [String] -> String
unlines
      ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty String -> [String]) -> [NonEmpty String] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap NonEmpty String -> [String]
unwordsNonEmpty
      ([NonEmpty String] -> [String])
-> (String -> [NonEmpty String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [NonEmpty String]
forall (f :: * -> *) b a.
(Foldable f, Eq b) =>
(a -> b) -> f a -> [NonEmpty a]
List1.groupWith String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null
      ([String] -> [NonEmpty String])
-> (String -> [String]) -> String -> [NonEmpty String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
trim
      ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
    unwordsNonEmpty :: List1.NonEmpty String -> [String]
    unwordsNonEmpty :: NonEmpty String -> [String]
unwordsNonEmpty NonEmpty String
ls1 = if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (NonEmpty String -> String
forall a. NonEmpty a -> a
List1.head NonEmpty String
ls1) then [String]
ls else [[String] -> String
unwords [String]
ls]
      where ls :: [String]
ls = NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
List1.toList NonEmpty String
ls1

commandDetailsLines String
_ (CommandSpec CommandUI flags
_ CommandUI flags -> Command action
_ CommandType
HiddenCommand) = []

optionsLines :: CommandUI flags -> [String]
optionsLines :: CommandUI flags -> [String]
optionsLines CommandUI flags
command = (OptDescr flags -> [String]) -> [OptDescr flags] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap OptDescr flags -> [String]
forall flags. OptDescr flags -> [String]
optionLines ((OptionField flags -> [OptDescr flags])
-> [OptionField flags] -> [OptDescr flags]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap OptionField flags -> [OptDescr flags]
forall a. OptionField a -> [OptDescr a]
optionDescr (CommandUI flags -> ShowOrParseArgs -> [OptionField flags]
forall flags.
CommandUI flags -> ShowOrParseArgs -> [OptionField flags]
commandOptions CommandUI flags
command ShowOrParseArgs
ParseArgs))

data ArgumentRequired = Optional | Required
type OptionArg = (ArgumentRequired, ArgPlaceHolder)

optionLines :: OptDescr flags -> [String]
optionLines :: OptDescr flags -> [String]
optionLines (ReqArg String
description (String
optionChars, [String]
optionStrings) String
placeHolder ReadE (flags -> flags)
_ flags -> [String]
_) =
  String -> String -> [String] -> OptionArg -> [String]
argOptionLines String
description String
optionChars [String]
optionStrings (ArgumentRequired
Required, String
placeHolder)
optionLines (OptArg String
description (String
optionChars, [String]
optionStrings) String
placeHolder ReadE (flags -> flags)
_ flags -> flags
_ flags -> [Maybe String]
_) =
  String -> String -> [String] -> OptionArg -> [String]
argOptionLines String
description String
optionChars [String]
optionStrings (ArgumentRequired
Optional, String
placeHolder)
optionLines (BoolOpt String
description (String
trueChars, [String]
trueStrings) (String
falseChars, [String]
falseStrings) Bool -> flags -> flags
_ flags -> Maybe Bool
_) =
  String -> [String] -> [String]
optionLinesIfPresent String
trueChars [String]
trueStrings [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
  String -> [String] -> [String]
optionLinesIfPresent String
falseChars [String]
falseStrings [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
  String -> [String]
optionDescriptionLines String
description
optionLines (ChoiceOpt [(String, (String, [String]), flags -> flags, flags -> Bool)]
options) =
  ((String, (String, [String]), flags -> flags, flags -> Bool)
 -> [String])
-> [(String, (String, [String]), flags -> flags, flags -> Bool)]
-> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String, (String, [String]), flags -> flags, flags -> Bool)
-> [String]
forall c d. (String, (String, [String]), c, d) -> [String]
choiceLines [(String, (String, [String]), flags -> flags, flags -> Bool)]
options
  where
    choiceLines :: (String, (String, [String]), c, d) -> [String]
choiceLines (String
description, (String
optionChars, [String]
optionStrings), c
_, d
_) =
      [ String -> [String] -> String
optionsLine String
optionChars [String]
optionStrings ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
      String -> [String]
optionDescriptionLines String
description

argOptionLines :: String -> [Char] -> [String] -> OptionArg -> [String]
argOptionLines :: String -> String -> [String] -> OptionArg -> [String]
argOptionLines String
description String
optionChars [String]
optionStrings OptionArg
arg =
  [ String -> [String] -> String
optionsLine String
optionChars [String]
optionStrings
  , OptionArg -> String
optionArgLine OptionArg
arg
  ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
  String -> [String]
optionDescriptionLines String
description

optionLinesIfPresent :: [Char] -> [String] -> [String]
optionLinesIfPresent :: String -> [String] -> [String]
optionLinesIfPresent String
optionChars [String]
optionStrings =
  if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
optionChars Bool -> Bool -> Bool
&& [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
optionStrings then []
  else                                           [ String -> [String] -> String
optionsLine String
optionChars [String]
optionStrings, String
".br" ]

optionDescriptionLines :: String -> [String]
optionDescriptionLines :: String -> [String]
optionDescriptionLines String
description =
  [ String
".RS"
  , String
description
  , String
".RE"
  , String
""
  ]

optionsLine :: [Char] -> [String] -> String
optionsLine :: String -> [String] -> String
optionsLine String
optionChars [String]
optionStrings =
  String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " (String -> [String]
shortOptions String
optionChars [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String] -> [String]
longOptions [String]
optionStrings)

shortOptions :: [Char] -> [String]
shortOptions :: String -> [String]
shortOptions = (Char -> String) -> String -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> String
"\\-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
c])

longOptions :: [String] -> [String]
longOptions :: [String] -> [String]
longOptions = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\String
s -> String
"\\-\\-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)

optionArgLine :: OptionArg -> String
optionArgLine :: OptionArg -> String
optionArgLine (ArgumentRequired
Required, String
placeHolder) = String
".I " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
placeHolder
optionArgLine (ArgumentRequired
Optional, String
placeHolder) = String
".RI [ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
placeHolder String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ]"

fileLines :: FileInfo -> [String]
fileLines :: FileInfo -> [String]
fileLines (FileInfo String
path String
description) =
  [ String
path
  , String
".RS"
  , String
description
  , String
".RE"
  , String
""
  ]