cabal-install/src/Distribution/Client/Manpage.hs

   1 {-# LANGUAGE CPP #-}
   2
   3 -----------------------------------------------------------------------------
   4
   5 -- |
   6 -- Module      :  Distribution.Client.Manpage
   7 -- Copyright   :  (c) Maciek Makowski 2015
   8 -- License     :  BSD-like
   9 --
  10 -- Maintainer  :  cabal-devel@haskell.org
  11 -- Stability   :  provisional
  12 -- Portability :  portable
  13 --
  14 -- Functions for building the manual page.
  15 module Distribution.Client.Manpage
  16   ( -- * Manual page generation
  17     manpage
  18   , manpageCmd
  19   , ManpageFlags
  20   , defaultManpageFlags
  21   , manpageOptions
  22   ) where
  23
  24 import qualified Data.List.NonEmpty as List1
  25 import Distribution.Client.Compat.Prelude
  26 import Prelude ()
  27
  28 import Distribution.Client.Errors
  29 import Distribution.Client.Init.Utils (trim)
  30 import Distribution.Client.ManpageFlags
  31 import Distribution.Client.Setup (globalCommand)
  32 import Distribution.Compat.Process (proc)
  33 import Distribution.Simple.Command
  34 import Distribution.Simple.Flag (fromFlag, fromFlagOrDefault)
  35 import Distribution.Simple.Utils
  36   ( IOData (..)
  37   , IODataMode (..)
  38   , dieWithException
  39   , fromCreatePipe
  40   , ignoreSigPipe
  41   , rawSystemProcAction
  42   , rawSystemStdInOut
  43   )
  44 import System.Environment (lookupEnv)
  45 import System.IO (hClose, hPutStr)
  46 import qualified System.Process as Process
  47
  48 data FileInfo
  49   = -- | path, description
  50     FileInfo String String
  51
  52 -------------------------------------------------------------------------------
  53 --
  54 -------------------------------------------------------------------------------
  55
  56 -- | A list of files that should be documented in the manual page.
  57 files :: [FileInfo]
  58 files =
  59   [ (FileInfo "~/.config/cabal/config" "The defaults that can be overridden with command-line options.")
  60   ]
  61
  62 manpageCmd :: String -> [CommandSpec a] -> ManpageFlags -> IO ()
  63 manpageCmd pname commands flags
  64   | fromFlagOrDefault False (manpageRaw flags) =
  65       putStrLn contents
  66   | otherwise =
  67       ignoreSigPipe $ do
  68         -- 2021-10-08, issue #7714
  69         -- @cabal man --raw | man -l -@ does not work on macOS/BSD,
  70         -- because BSD-man does not support option @-l@, rather would
  71         -- accept directly a file argument, e.g. @man /dev/stdin@.
  72         -- The following works both on macOS and Linux
  73         -- (but not on Windows out-of-the-box):
  74         --
  75         --   cabal man --raw | nroff -man /dev/stdin | less
  76         --
  77         -- So let us simulate this!
  78
  79         -- Feed contents into @nroff -man /dev/stdin@
  80         (formatted, _errors, ec1) <-
  81           rawSystemStdInOut
  82             verbosity
  83             "nroff"
  84             ["-man", "/dev/stdin"]
  85             Nothing -- Inherit working directory
  86             Nothing -- Inherit environment
  87             (Just $ IODataText contents)
  88             IODataModeText
  89
  90         unless (ec1 == ExitSuccess) $ exitWith ec1
  91
  92         pagerAndArgs <- fromMaybe "less -R" <$> lookupEnv "PAGER"
  93         -- 'less' is borked with color sequences otherwise, hence -R
  94         (pager, pagerArgs) <- case words pagerAndArgs of
  95           [] -> dieWithException verbosity EmptyValuePagerEnvVariable
  96           (p : pa) -> pure (p, pa)
  97         -- Pipe output of @nroff@ into @less@
  98         (ec2, _) <- rawSystemProcAction
  99           verbosity
 100           (proc pager pagerArgs){Process.std_in = Process.CreatePipe}
 101           $ \mIn _ _ -> do
 102             let wIn = fromCreatePipe mIn
 103             hPutStr wIn formatted
 104             hClose wIn
 105         exitWith ec2
 106   where
 107     contents :: String
 108     contents = manpage pname commands
 109     verbosity = fromFlag $ manpageVerbosity flags
 110
 111 -- | Produces a manual page with @troff@ markup.
 112 manpage :: String -> [CommandSpec a] -> String
 113 manpage pname commands =
 114   unlines $
 115     [ ".TH " ++ map toUpper pname ++ " 1"
 116     , ".SH NAME"
 117     , pname ++ " \\- a system for building and packaging Haskell libraries and programs"
 118     , ".SH SYNOPSIS"
 119     , ".B " ++ pname
 120     , ".I command"
 121     , ".RI < arguments |[ options ]>..."
 122     , ""
 123     , "Where the"
 124     , ".I commands"
 125     , "are"
 126     , ""
 127     ]
 128       ++ concatMap (commandSynopsisLines pname) commands
 129       ++ [ ".SH DESCRIPTION"
 130          , "Cabal is the standard package system for Haskell software. It helps people to configure, "
 131          , "build and install Haskell software and to distribute it easily to other users and developers."
 132          , ""
 133          , "The command line " ++ pname ++ " tool (also referred to as cabal-install) helps with "
 134          , "installing existing packages and developing new packages. "
 135          , "It can be used to work with local packages or to install packages from online package archives, "
 136          , "including automatically installing dependencies. By default it is configured to use Hackage, "
 137          , "which is Haskell's central package archive that contains thousands of libraries and applications "
 138          , "in the Cabal package format."
 139          , ".SH OPTIONS"
 140          , "Global options:"
 141          , ""
 142          ]
 143       ++ optionsLines (globalCommand [])
 144       ++ [ ".SH COMMANDS"
 145          ]
 146       ++ concatMap (commandDetailsLines pname) commands
 147       ++ [ ".SH FILES"
 148          ]
 149       ++ concatMap fileLines files
 150       ++ [ ".SH BUGS"
 151          , "To browse the list of known issues or report a new one please see "
 152          , "https://github.com/haskell/cabal/labels/cabal-install."
 153          ]
 154
 155 commandSynopsisLines :: String -> CommandSpec action -> [String]
 156 commandSynopsisLines pname (CommandSpec ui _ NormalCommand) =
 157   [ ".B " ++ pname ++ " " ++ (commandName ui)
 158   , "- " ++ commandSynopsis ui
 159   , ".br"
 160   ]
 161 commandSynopsisLines _ (CommandSpec _ _ HiddenCommand) = []
 162
 163 commandDetailsLines :: String -> CommandSpec action -> [String]
 164 commandDetailsLines pname (CommandSpec ui _ NormalCommand) =
 165   [ ".B " ++ pname ++ " " ++ (commandName ui)
 166   , ""
 167   , commandUsage ui pname
 168   , ""
 169   ]
 170     ++ optional removeLineBreaks commandDescription
 171     ++ optional id commandNotes
 172     ++ [ "Flags:"
 173        , ".RS"
 174        ]
 175     ++ optionsLines ui
 176     ++ [ ".RE"
 177        , ""
 178        ]
 179   where
 180     optional f field =
 181       case field ui of
 182         Just text -> [f $ text pname, ""]
 183         Nothing -> []
 184     -- 2021-10-12, https://github.com/haskell/cabal/issues/7714#issuecomment-940842905
 185     -- Line breaks just before e.g. 'new-build' cause weird @nroff@ warnings.
 186     -- Thus:
 187     -- Remove line breaks but preserve paragraph breaks.
 188     -- We group lines by empty/non-empty and then 'unwords'
 189     -- blocks consisting of non-empty lines.
 190     removeLineBreaks =
 191       unlines
 192         . concatMap unwordsNonEmpty
 193         . List1.groupWith null
 194         . map trim
 195         . lines
 196     unwordsNonEmpty :: List1.NonEmpty String -> [String]
 197     unwordsNonEmpty ls1 = if null (List1.head ls1) then ls else [unwords ls]
 198       where
 199         ls = List1.toList ls1
 200 commandDetailsLines _ (CommandSpec _ _ HiddenCommand) = []
 201
 202 optionsLines :: CommandUI flags -> [String]
 203 optionsLines command = concatMap optionLines (concatMap optionDescr (commandOptions command ParseArgs))
 204
 205 data ArgumentRequired = Optional | Required
 206 type OptionArg = (ArgumentRequired, ArgPlaceHolder)
 207
 208 optionLines :: OptDescr flags -> [String]
 209 optionLines (ReqArg description (optionChars, optionStrings) placeHolder _ _) =
 210   argOptionLines description optionChars optionStrings (Required, placeHolder)
 211 optionLines (OptArg description (optionChars, optionStrings) placeHolder _ _ _) =
 212   argOptionLines description optionChars optionStrings (Optional, placeHolder)
 213 optionLines (BoolOpt description (trueChars, trueStrings) (falseChars, falseStrings) _ _) =
 214   optionLinesIfPresent trueChars trueStrings
 215     ++ optionLinesIfPresent falseChars falseStrings
 216     ++ optionDescriptionLines description
 217 optionLines (ChoiceOpt options) =
 218   concatMap choiceLines options
 219   where
 220     choiceLines (description, (optionChars, optionStrings), _, _) =
 221       [optionsLine optionChars optionStrings]
 222         ++ optionDescriptionLines description
 223
 224 argOptionLines :: String -> [Char] -> [String] -> OptionArg -> [String]
 225 argOptionLines description optionChars optionStrings arg =
 226   [ optionsLine optionChars optionStrings
 227   , optionArgLine arg
 228   ]
 229     ++ optionDescriptionLines description
 230
 231 optionLinesIfPresent :: [Char] -> [String] -> [String]
 232 optionLinesIfPresent optionChars optionStrings =
 233   if null optionChars && null optionStrings
 234     then []
 235     else [optionsLine optionChars optionStrings, ".br"]
 236
 237 optionDescriptionLines :: String -> [String]
 238 optionDescriptionLines description =
 239   [ ".RS"
 240   , description
 241   , ".RE"
 242   , ""
 243   ]
 244
 245 optionsLine :: [Char] -> [String] -> String
 246 optionsLine optionChars optionStrings =
 247   intercalate ", " (shortOptions optionChars ++ longOptions optionStrings)
 248
 249 shortOptions :: [Char] -> [String]
 250 shortOptions = map (\c -> "\\-" ++ [c])
 251
 252 longOptions :: [String] -> [String]
 253 longOptions = map (\s -> "\\-\\-" ++ s)
 254
 255 optionArgLine :: OptionArg -> String
 256 optionArgLine (Required, placeHolder) = ".I " ++ placeHolder
 257 optionArgLine (Optional, placeHolder) = ".RI [ " ++ placeHolder ++ " ]"
 258
 259 fileLines :: FileInfo -> [String]
 260 fileLines (FileInfo path description) =
 261   [ path
 262   , ".RS"
 263   , description
 264   , ".RE"
 265   , ""
 266   ]