-- |
-- 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 qualified Data.List.NonEmpty as List1
import Distribution.Client.Compat.Prelude
import Prelude ()

import Distribution.Client.Errors
import Distribution.Client.Init.Utils (trim)
import Distribution.Client.ManpageFlags
import Distribution.Client.Setup (globalCommand)
import Distribution.Compat.Process (proc)
import Distribution.Simple.Command
import Distribution.Simple.Flag (fromFlag, fromFlagOrDefault)
import Distribution.Simple.Utils
  ( IOData (..)
  , IODataMode (..)
  , dieWithException
  , fromCreatePipe
  , ignoreSigPipe
  , rawSystemProcAction
  , rawSystemStdInOut
  )
import System.Environment (lookupEnv)
import System.IO (hClose, hPutStr)
import qualified System.Process as Process

data FileInfo
  = -- | path, description
    FileInfo String String

-------------------------------------------------------------------------------
--
-------------------------------------------------------------------------------

-- | A list of files that should be documented in the manual page.
files :: [FileInfo]
files :: [FileInfo]
files =
  [ (String -> String -> FileInfo
FileInfo String
"~/.config/cabal/config" String
"The defaults that can be overridden with command-line options.")
  ]

manpageCmd :: String -> [CommandSpec a] -> ManpageFlags -> IO ()
manpageCmd :: forall a. 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
            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
pagerAndArgs <- String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"less -R" (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, hence -R
        (String
pager, [String]
pagerArgs) <- case String -> [String]
words String
pagerAndArgs of
          [] -> Verbosity -> CabalInstallException -> IO (String, [String])
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalInstallException
EmptyValuePagerEnvVariable
          (String
p : [String]
pa) -> (String, [String]) -> IO (String, [String])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
p, [String]
pa)
        -- Pipe output of @nroff@ into @less@
        (ExitCode
ec2, ()
_) <- Verbosity
-> CreateProcess
-> (Maybe Handle -> Maybe Handle -> Maybe Handle -> IO ())
-> IO (ExitCode, ())
forall a.
Verbosity
-> CreateProcess
-> (Maybe Handle -> Maybe Handle -> Maybe Handle -> IO a)
-> IO (ExitCode, a)
rawSystemProcAction
          Verbosity
verbosity
          (String -> [String] -> CreateProcess
proc String
pager [String]
pagerArgs){Process.std_in = Process.CreatePipe}
          ((Maybe Handle -> Maybe Handle -> Maybe Handle -> IO ())
 -> IO (ExitCode, ()))
-> (Maybe Handle -> Maybe Handle -> Maybe Handle -> IO ())
-> IO (ExitCode, ())
forall a b. (a -> b) -> a -> b
$ \Maybe Handle
mIn Maybe Handle
_ Maybe Handle
_ -> do
            let wIn :: Handle
wIn = Maybe Handle -> Handle
fromCreatePipe Maybe Handle
mIn
            Handle -> String -> IO ()
hPutStr Handle
wIn String
formatted
            Handle -> IO ()
hClose Handle
wIn
        ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith ExitCode
ec2
  where
    contents :: String
    contents :: String
contents = String -> [CommandSpec a] -> String
forall a. String -> [CommandSpec a] -> String
manpage String
pname [CommandSpec a]
commands
    verbosity :: Verbosity
verbosity = Flag Verbosity -> Verbosity
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag Verbosity -> Verbosity) -> Flag Verbosity -> Verbosity
forall a b. (a -> b) -> a -> b
$ ManpageFlags -> Flag Verbosity
manpageVerbosity ManpageFlags
flags

-- | Produces a manual page with @troff@ markup.
manpage :: String -> [CommandSpec a] -> String
manpage :: forall a. 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 :: forall action. 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 :: forall action. 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 {a}.
(a -> String)
-> (CommandUI flags -> Maybe (String -> a)) -> [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 {a}.
(a -> String)
-> (CommandUI flags -> Maybe (String -> a)) -> [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 :: (a -> String)
-> (CommandUI flags -> Maybe (String -> a)) -> [String]
optional a -> String
f CommandUI flags -> Maybe (String -> a)
field =
      case CommandUI flags -> Maybe (String -> a)
field CommandUI flags
ui of
        Just String -> a
text -> [a -> String
f (a -> String) -> a -> String
forall a b. (a -> b) -> a -> b
$ String -> a
text String
pname, String
""]
        Maybe (String -> a)
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 a. [a] -> 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 a. [a] -> 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 :: forall flags. 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 :: forall flags. 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)
_ (String, 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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
optionChars Bool -> Bool -> Bool
&& [String] -> Bool
forall a. [a] -> 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
""
  ]