{-# 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.Compat.Process      (proc)
import Distribution.Simple.Command
import Distribution.Simple.Flag         (fromFlag, fromFlagOrDefault)
import Distribution.Simple.Utils
  ( IOData(..), IODataMode(..), ignoreSigPipe, rawSystemStdInOut, rawSystemProcAction,
    fromCreatePipe, die' )
import System.IO                        (hClose, hPutStr)
import System.Environment               (lookupEnv)
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
"~/.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
    | 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 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) <- 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" ]
          forall a. Maybe a
Nothing  -- Inherit working directory
          forall a. Maybe a
Nothing  -- Inherit environment
          (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> IOData
IODataText String
contents)
          IODataMode String
IODataModeText

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

        String
pagerAndArgs <- forall a. a -> Maybe a -> a
fromMaybe String
"less -R" 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
          []     -> forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity String
"man: empty value of the PAGER environment variable"
          (String
p:[String]
pa) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
p, [String]
pa)
        -- Pipe output of @nroff@ into @less@
        (ExitCode
ec2, ()
_) <- 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) { std_in :: StdStream
Process.std_in = StdStream
Process.CreatePipe }
              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
        forall a. ExitCode -> IO a
exitWith ExitCode
ec2
  where
    contents :: String
    contents :: String
contents = forall a. String -> [CommandSpec a] -> String
manpage String
pname [CommandSpec a]
commands
    verbosity :: Verbosity
verbosity = forall a. WithCallStack (Flag a -> a)
fromFlag 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 forall a b. (a -> b) -> a -> b
$
  [ String
".TH " forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper String
pname forall a. [a] -> [a] -> [a]
++ String
" 1"
  , String
".SH NAME"
  , String
pname forall a. [a] -> [a] -> [a]
++ String
" \\- a system for building and packaging Haskell libraries and programs"
  , String
".SH SYNOPSIS"
  , String
".B " forall a. [a] -> [a] -> [a]
++ String
pname
  , String
".I command"
  , String
".RI < arguments |[ options ]>..."
  , String
""
  , String
"Where the"
  , String
".I commands"
  , String
"are"
  , String
""
  ] forall a. [a] -> [a] -> [a]
++
  forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall action. String -> CommandSpec action -> [String]
commandSynopsisLines String
pname) [CommandSpec a]
commands 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 " forall a. [a] -> [a] -> [a]
++ String
pname 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
""
  ] forall a. [a] -> [a] -> [a]
++
  forall flags. CommandUI flags -> [String]
optionsLines (forall action. [Command action] -> CommandUI GlobalFlags
globalCommand []) forall a. [a] -> [a] -> [a]
++
  [ String
".SH COMMANDS"
  ] forall a. [a] -> [a] -> [a]
++
  forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall action. String -> CommandSpec action -> [String]
commandDetailsLines String
pname) [CommandSpec a]
commands forall a. [a] -> [a] -> [a]
++
  [ String
".SH FILES"
  ] forall a. [a] -> [a] -> [a]
++
  forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap FileInfo -> [String]
fileLines [FileInfo]
files 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 " forall a. [a] -> [a] -> [a]
++ String
pname forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ (forall flags. CommandUI flags -> String
commandName CommandUI flags
ui)
  , String
"- " forall a. [a] -> [a] -> [a]
++ 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 " forall a. [a] -> [a] -> [a]
++ String
pname forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ (forall flags. CommandUI flags -> String
commandName CommandUI flags
ui)
  , String
""
  , forall flags. CommandUI flags -> String -> String
commandUsage CommandUI flags
ui String
pname
  , String
""
  ] forall a. [a] -> [a] -> [a]
++
  forall {a}.
(a -> String)
-> (CommandUI flags -> Maybe (String -> a)) -> [String]
optional String -> String
removeLineBreaks forall flags. CommandUI flags -> Maybe (String -> String)
commandDescription forall a. [a] -> [a] -> [a]
++
  forall {a}.
(a -> String)
-> (CommandUI flags -> Maybe (String -> a)) -> [String]
optional forall a. a -> a
id forall flags. CommandUI flags -> Maybe (String -> String)
commandNotes forall a. [a] -> [a] -> [a]
++
  [ String
"Flags:"
  , String
".RS"
  ] forall a. [a] -> [a] -> [a]
++
  forall flags. CommandUI flags -> [String]
optionsLines CommandUI flags
ui 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 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
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap NonEmpty String -> [String]
unwordsNonEmpty
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) b a.
(Foldable f, Eq b) =>
(a -> b) -> f a -> [NonEmpty a]
List1.groupWith forall (t :: * -> *) a. Foldable t => t a -> Bool
null
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map String -> String
trim
      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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall a. NonEmpty a -> a
List1.head NonEmpty String
ls1) then [String]
ls else [[String] -> String
unwords [String]
ls]
      where ls :: [String]
ls = 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 = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall flags. OptDescr flags -> [String]
optionLines (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. OptionField a -> [OptDescr a]
optionDescr (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)
_ 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 forall a. [a] -> [a] -> [a]
++
  String -> [String] -> [String]
optionLinesIfPresent String
falseChars [String]
falseStrings forall a. [a] -> [a] -> [a]
++
  String -> [String]
optionDescriptionLines String
description
optionLines (ChoiceOpt [(String, (String, [String]), flags -> flags, flags -> Bool)]
options) =
  forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap 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 ] 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
  ] forall a. [a] -> [a] -> [a]
++
  String -> [String]
optionDescriptionLines String
description

optionLinesIfPresent :: [Char] -> [String] -> [String]
optionLinesIfPresent :: String -> [String] -> [String]
optionLinesIfPresent String
optionChars [String]
optionStrings =
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
optionChars Bool -> Bool -> 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 =
  forall a. [a] -> [[a]] -> [a]
intercalate String
", " (String -> [String]
shortOptions String
optionChars forall a. [a] -> [a] -> [a]
++ [String] -> [String]
longOptions [String]
optionStrings)

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

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

optionArgLine :: OptionArg -> String
optionArgLine :: OptionArg -> String
optionArgLine (ArgumentRequired
Required, String
placeHolder) = String
".I " forall a. [a] -> [a] -> [a]
++ String
placeHolder
optionArgLine (ArgumentRequired
Optional, String
placeHolder) = String
".RI [ " forall a. [a] -> [a] -> [a]
++ String
placeHolder 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
""
  ]