core-program-0.2.5.0: lib/Core/Program/Arguments.hs
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE StrictData #-}
{-# OPTIONS_HADDOCK prune #-}
-- |
-- Invoking a command-line program (be it tool or daemon) consists of listing
-- the name of its binary, optionally supplying various options to adjust the
-- behaviour of the program, and then supplying mandatory arguments, if any
-- are specified.
--
-- On startup, we parse any arguments passed in from the shell into
-- @name,value@ pairs and incorporated into the resultant configuration stored
-- in the program's Context.
--
-- Additionally, this module allows you to specify environment variables that,
-- if present, will be incorporated into the stored configuration.
module Core.Program.Arguments
( -- * Setup
Config,
blank,
simple,
complex,
baselineOptions,
Parameters (..),
ParameterValue (..),
-- * Options and Arguments
LongName (..),
ShortName,
Description,
Options (..),
-- * Programs with Commands
Commands (..),
-- * Internals
parseCommandLine,
extractValidEnvironments,
InvalidCommandLine (..),
buildUsage,
buildVersion,
)
where
import Control.Exception.Safe (Exception (displayException))
import Core.Data.Structures
import Core.Program.Metadata
import Core.System.Base
import Core.Text.Rope
import Core.Text.Utilities
import Data.Hashable (Hashable)
import qualified Data.List as List
import Data.Maybe (fromMaybe)
import Data.String
import Data.Text.Prettyprint.Doc
( Doc,
Pretty (..),
align,
emptyDoc,
fillBreak,
fillCat,
fillSep,
hardline,
indent,
nest,
softline,
(<+>),
)
import Data.Text.Prettyprint.Doc.Util (reflow)
import System.Environment (getProgName)
-- |
-- Single letter "short" options (omitting the "@-@" prefix, obviously).
type ShortName = Char
-- |
-- The description of an option, command, or environment variable (for use
-- when rendering usage information in response to @--help@ on the
-- command-line).
type Description = Rope
-- |
-- The name of an option, command, or agument (omitting the "@--@" prefix in
-- the case of options). This identifier will be used to generate usage text
-- in response to @--help@ and by you later when retreiving the values of the
-- supplied parameters after the program has initialized.
--
-- Turn on __@OverloadedStrings@__ when specifying configurations, obviously.
newtype LongName = LongName String
deriving (Show, IsString, Eq, Hashable, Ord)
instance Key LongName
instance Pretty LongName where
pretty (LongName name) = pretty name
instance Textual LongName where
intoRope (LongName str) = intoRope str
fromRope = LongName . fromRope
-- |
-- The setup for parsing the command-line arguments of your program. You build
-- a @Config@ with 'simple' or 'complex', and pass it to
-- 'Core.Program.Context.configure'.
data Config
= Blank
| Simple [Options]
| Complex [Commands]
--
-- Those constructors are not exposed [and functions wrapping them are] partly
-- for documentation convenience, partly for aesthetics (after a point too many
-- constructors got a bit hard to differentiate betwen), and mostly so that if
-- configure's argument turns into a monad like RequestBuilder we have
-- somewhere to make that change.
--
-- |
-- A completely empty configuration, without the default debugging and logging
-- options. Your program won't process any command-line options or arguments,
-- which would be weird in most cases. Prefer 'simple'.
blank :: Config
blank = Blank
-- |
-- Declare a simple (as in normal) configuration for a program with any number
-- of optional parameters and mandatory arguments. For example:
--
-- @
-- main :: 'IO' ()
-- main = do
-- context <- 'Core.Program.Execute.configure' \"1.0\" 'Core.Program.Execute.None' ('simple'
-- [ 'Option' "host" ('Just' \'h\') 'Empty' ['quote'|
-- Specify an alternate host to connect to when performing the
-- frobnication. The default is \"localhost\".
-- |]
-- , 'Option' "port" ('Just' \'p\') 'Empty' ['quote'|
-- Specify an alternate port to connect to when frobnicating.
-- |]
-- , 'Option' "dry-run" 'Nothing' ('Value' \"TIME\") ['quote'|
-- Perform a trial run at the specified time but don't actually
-- do anything.
-- |]
-- , 'Option' "quiet" ('Just' \'q\') 'Empty' ['quote'|
-- Supress normal output.
-- |]
-- , 'Argument' "filename" ['quote'|
-- The file you want to frobnicate.
-- |]
-- ])
--
-- 'Core.Program.Execute.executeWith' context program
-- @
--
-- which, if you build that into an executable called @snippet@ and invoke it
-- with @--help@, would result in:
--
-- @
-- \$ __./snippet --help__
-- Usage:
--
-- snippet [OPTIONS] filename
--
-- Available options:
--
-- -h, --host Specify an alternate host to connect to when performing the
-- frobnication. The default is \"localhost\".
-- -p, --port Specify an alternate port to connect to when frobnicating.
-- --dry-run=TIME
-- Perform a trial run at the specified time but don't
-- actually do anything.
-- -q, --quiet Supress normal output.
-- -v, --verbose Turn on event tracing. By default the logging stream will go
-- to standard output on your terminal.
-- --debug Turn on debug level logging. Implies --verbose.
--
-- Required arguments:
--
-- filename The file you want to frobnicate.
-- \$ __|__
-- @
--
-- For information on how to use the multi-line string literals shown here,
-- see 'quote' in "Core.Text.Utilities".
simple :: [Options] -> Config
simple options = Simple (options ++ baselineOptions)
-- |
-- Declare a complex configuration (implying a larger tool with various
-- "[sub]commands" or "modes"} for a program. You can specify global options
-- applicable to all commands, a list of commands, and environment variables
-- that will be honoured by the program. Each command can have a list of local
-- options and arguments as needed. For example:
--
-- @
-- program :: 'Core.Program.Execute.Program' MusicAppStatus ()
-- program = ...
--
-- main :: 'IO' ()
-- main = do
-- context <- 'Core.Program.Execute.configure' ('Core.Program.Execute.fromPackage' version) 'mempty' ('complex'
-- [ 'Global'
-- [ 'Option' "station-name" 'Nothing' ('Value' \"NAME\") ['quote'|
-- Specify an alternate radio station to connect to when performing
-- actions. The default is \"BBC Radio 1\".
-- |]
-- , 'Variable' \"PLAYER_FORCE_HEADPHONES\" ['quote'|
-- If set to @1@, override the audio subsystem to force output
-- to go to the user's headphone jack.
-- |]
-- ]
-- , 'Command' \"play\" \"Play the music.\"
-- [ 'Option' "repeat" 'Nothing' 'Empty' ['quote'|
-- Request that they play the same song over and over and over
-- again, simulating the effect of listening to a Top 40 radio
-- station.
-- |]
-- ]
-- , 'Command' \"rate\" \"Vote on whether you like the song or not.\"
-- [ 'Option' "academic" 'Nothing' 'Empty' ['quote'|
-- The rating you wish to apply, from A+ to F. This is the
-- default, so there is no reason whatsoever to specify this.
-- But some people are obsessive, compulsive, and have time on
-- their hands.
-- |]
-- , 'Option' "numeric" 'Nothing' 'Empty' ['quote'|
-- Specify a score as a number from 0 to 100 instead of an
-- academic style letter grade. Note that negative values are
-- not valid scores, despite how vicerally satisfying that
-- would be for music produced in the 1970s.
-- |]
-- , 'Option' "unicode" ('Just' \'c\') 'Empty' ['quote'|
-- Instead of a score, indicate your rating with a single
-- character. This allows you to use emoji, so that you can
-- rate a piece \'💩\', as so many songs deserve.
-- |]
-- , 'Argument' "score" ['quote'|
-- The rating you wish to apply.
-- |]
-- ]
-- ])
--
-- 'Core.Program.Execute.executeWith' context program
-- @
--
-- is a program with one global option (in addition to the default ones) [and
-- an environment variable] and two commands: @play@, with one option; and
-- @rate@, with two options and a required argument. It also is set up to
-- carry its top-level application state around in a type called
-- @MusicAppStatus@ (implementing 'Monoid' and so initialized here with
-- 'mempty'. This is a good pattern to use given we are so early in the
-- program's lifetime).
--
-- The resultant program could be invoked as in these examples:
--
-- @
-- \$ __./player --station-name=\"KBBL-FM 102.5\" play__
-- \$
-- @
--
-- @
-- \$ __./player -v rate --numeric 76__
-- \$
-- @
--
-- For information on how to use the multi-line string literals shown here,
-- see 'quote' in "Core.Text.Utilities".
complex :: [Commands] -> Config
complex commands = Complex (commands ++ [Global baselineOptions])
-- |
-- Description of the command-line structure of a program which has
-- \"commands\" (sometimes referred to as \"subcommands\") representing
-- different modes of operation. This is familiar from tools like /git/
-- and /docker/.
data Commands
= Global [Options]
| Command LongName Description [Options]
-- |
-- Declaration of an optional switch or mandatory argument expected by a
-- program.
--
-- 'Option' takes a long name for the option, a short single character
-- abbreviation if offered for convenience, whether or not the option takes a
-- value (and what label to show in help output) and a description for use
-- when displaying usage via @--help@.
--
-- 'Argument' indicates a mandatory argument and takes the long name used
-- to identify the parsed value from the command-line, and likewise a
-- description for @--help@ output.
--
-- By convention option and argument names are both /lower case/. If the
-- identifier is two or more words they are joined with a hyphen. Examples:
--
-- @
-- [ 'Option' \"quiet\" ('Just' \'q'\) 'Empty' \"Keep the noise to a minimum.\"
-- , 'Option' \"dry-run\" 'Nothing' ('Value' \"TIME\") \"Run a simulation of what would happen at the specified time.\"
-- , 'Argument' \"username\" \"The user to delete from the system.\"
-- ]
-- @
--
-- By convention a /description/ is one or more complete sentences each of
-- which ends with a full stop. For options that take values, use /upper case/
-- when specifying the label to be used in help output.
--
-- 'Variable' declares an /environment variable/ that, if present, will be
-- read by the program and stored in its runtime context. By convention these
-- are /upper case/. If the identifier is two or more words they are joined
-- with an underscore:
--
-- @
-- [ ...
-- , 'Variable' \"CRAZY_MODE\" "Specify how many crazies to activate."
-- , ...
-- ]
-- @
data Options
= Option LongName (Maybe ShortName) ParameterValue Description
| Argument LongName Description
| Variable LongName Description
-- |
-- Individual parameters read in off the command-line can either have a value
-- (in the case of arguments and options taking a value) or be empty (in the
-- case of options that are just flags).
data ParameterValue
= Value String
| Empty
deriving (Show, Eq)
instance IsString ParameterValue where
fromString x = Value x
-- |
-- Result of having processed the command-line and the environment. You get at
-- the parsed command-line options and arguments by calling
-- 'Core.Program.Execute.getCommandLine' within a
-- 'Core.Program.Execute.Program' block.
--
-- Each option and mandatory argument parsed from the command-line is either
-- standalone (in the case of switches and flags, such as @--quiet@) or has an
-- associated value. In the case of options the key is the name of the option,
-- and for arguments it is the implicit name specified when setting up the
-- program. For example, in:
--
-- @
-- \$ ./submit --username=gbmh GraceHopper_Resume.pdf
-- @
--
-- the option has parameter name \"@username@\" and value \"@gmbh@\"; the
-- argument has parameter name \"filename\" (assuming that is what was
-- declared in the 'Argument' entry) and a value being the Admiral's CV. This
-- would be returned as:
--
-- @
-- 'Parameters' 'Nothing' [("username","gbmh"), ("filename","GraceHopper_Resume.pdf")] []
-- @
--
-- The case of a complex command such as /git/ or /stack/, you get the specific
-- mode chosen by the user returned in the first position:
--
-- @
-- \$ missiles launch --all
-- @
--
-- would be parsed as:
--
-- @
-- 'Parameters' ('Just' \"launch\") [("all",Empty)] []
-- @
data Parameters = Parameters
{ commandNameFrom :: Maybe LongName,
parameterValuesFrom :: Map LongName ParameterValue,
environmentValuesFrom :: Map LongName ParameterValue
}
deriving (Show, Eq)
baselineOptions :: [Options]
baselineOptions =
[ Option
"verbose"
(Just 'v')
Empty
[quote|
Turn on event tracing. By default the logging stream will go to
standard output on your terminal.
|],
Option
"debug"
Nothing
Empty
[quote|
Turn on debug level logging. Implies --verbose.
|]
]
-- |
-- Different ways parsing a simple or complex command-line can fail.
data InvalidCommandLine
= -- | Something was wrong with the way the user specified [usually a short] option.
InvalidOption String
| -- | User specified an option that doesn't match any in the supplied configuration.
UnknownOption String
| -- | Arguments are mandatory, and this one is missing.
MissingArgument LongName
| -- | Arguments are present we weren't expecting.
UnexpectedArguments [String]
| -- | In a complex configuration, user specified a command that doesn't match any in the configuration.
UnknownCommand String
| -- | In a complex configuration, user didn't specify a command.
NoCommandFound
| -- | In a complex configuration, usage information was requested with @--help@, either globally or for the supplied command.
HelpRequest (Maybe LongName)
| -- | Display of the program version requested with @--version@.
VersionRequest
deriving (Show, Eq)
instance Exception InvalidCommandLine where
displayException e = case e of
InvalidOption arg ->
let one = "Option '" ++ arg ++ "' illegal.\n\n"
two =
[quote|
Options must either be long form with a double dash, for example:
--verbose
or, when available with a short version, a single dash and a single
character. They need to be listed individually:
-v -a
When an option takes a value it has to be in long form and the value
indicated with an equals sign, for example:
--tempdir=/tmp
with complex values escaped according to the rules of your shell:
--username="Ada Lovelace"
For options valid in this program, please see --help.
|]
in one ++ two
UnknownOption name -> "Sorry, option '" ++ name ++ "' not recognized."
MissingArgument (LongName name) -> "Mandatory argument '" ++ name ++ "' missing."
UnexpectedArguments args ->
let quoted = List.intercalate "', '" args
in [quote|
Unexpected trailing arguments:
|]
++ quoted
++ [quote|
For arguments expected by this program, please see --help.
|]
UnknownCommand first -> "Hm. Command '" ++ first ++ "' not recognized."
NoCommandFound ->
[quote|
No command specified.
Usage is of the form:
|]
++ programName
++ [quote| [GLOBAL OPTIONS] COMMAND [LOCAL OPTIONS] [ARGUMENTS]
See --help for details.
|]
-- handled by parent module calling back into here buildUsage
HelpRequest _ -> ""
-- handled by parent module calling back into here buildVersion
VersionRequest -> ""
programName :: String
programName = unsafePerformIO getProgName
-- |
-- Given a program configuration schema and the command-line arguments,
-- process them into key/value pairs in a Parameters object.
--
-- This results in 'InvalidCommandLine' on the left side if one of the passed
-- in options is unrecognized or if there is some other problem handling
-- options or arguments (because at that point, we want to rabbit right back
-- to the top and bail out; there's no recovering).
--
-- This isn't something you'll ever need to call directly; it's exposed for
-- testing convenience. This function is invoked when you call
-- 'Core.Program.Context.configure' or 'Core.Program.Execute.execute' (which
-- calls 'configure' with a default @Config@ when initializing).
parseCommandLine :: Config -> [String] -> Either InvalidCommandLine Parameters
parseCommandLine config argv = case config of
Blank -> return (Parameters Nothing emptyMap emptyMap)
Simple options -> do
params <- extractor Nothing options argv
return (Parameters Nothing params emptyMap)
Complex commands ->
let globalOptions = extractGlobalOptions commands
modes = extractValidModes commands
in do
(possibles, argv') <- splitCommandLine1 argv
params1 <- extractor Nothing globalOptions possibles
(first, remainingArgs) <- splitCommandLine2 argv'
(mode, localOptions) <- parseIndicatedCommand modes first
params2 <- extractor (Just mode) localOptions remainingArgs
return (Parameters (Just mode) ((<>) params1 params2) emptyMap)
where
extractor :: Maybe LongName -> [Options] -> [String] -> Either InvalidCommandLine (Map LongName ParameterValue)
extractor mode options args =
let (possibles, arguments) = List.partition isOption args
valids = extractValidNames options
shorts = extractShortNames options
needed = extractRequiredArguments options
in do
list1 <- parsePossibleOptions mode valids shorts possibles
list2 <- parseRequiredArguments needed arguments
return ((<>) (intoMap list1) (intoMap list2))
isOption :: String -> Bool
isOption arg = case arg of
('-' : _) -> True
_ -> False
parsePossibleOptions ::
Maybe LongName ->
Set LongName ->
Map ShortName LongName ->
[String] ->
Either InvalidCommandLine [(LongName, ParameterValue)]
parsePossibleOptions mode valids shorts args = mapM f args
where
f arg = case arg of
"--help" -> Left (HelpRequest mode)
"-?" -> Left (HelpRequest mode)
"--version" -> Left VersionRequest
('-' : '-' : name) -> considerLongOption name
('-' : c : []) -> considerShortOption c
_ -> Left (InvalidOption arg)
considerLongOption :: String -> Either InvalidCommandLine (LongName, ParameterValue)
considerLongOption arg =
let (name, value) = List.span (/= '=') arg
candidate = LongName name
-- lose the '='
value' = case List.uncons value of
Just (_, remainder) -> Value remainder
Nothing -> Empty
in if containsElement candidate valids
then Right (candidate, value')
else Left (UnknownOption ("--" ++ name))
considerShortOption :: Char -> Either InvalidCommandLine (LongName, ParameterValue)
considerShortOption c =
case lookupKeyValue c shorts of
Just name -> Right (name, Empty)
Nothing -> Left (UnknownOption ['-', c])
parseRequiredArguments ::
[LongName] ->
[String] ->
Either InvalidCommandLine [(LongName, ParameterValue)]
parseRequiredArguments needed argv = iter needed argv
where
iter :: [LongName] -> [String] -> Either InvalidCommandLine [(LongName, ParameterValue)]
iter [] [] = Right []
-- more arguments supplied than expected
iter [] args = Left (UnexpectedArguments args)
-- more arguments required, not satisfied
iter (name : _) [] = Left (MissingArgument name)
iter (name : names) (arg : args) =
let deeper = iter names args
in case deeper of
Left e -> Left e
Right list -> Right ((name, Value arg) : list)
parseIndicatedCommand ::
Map LongName [Options] ->
String ->
Either InvalidCommandLine (LongName, [Options])
parseIndicatedCommand modes first =
let candidate = LongName first
in case lookupKeyValue candidate modes of
Just options -> Right (candidate, options)
Nothing -> Left (UnknownCommand first)
--
-- Ok, the f,g,h,... was silly. But hey :)
--
extractValidNames :: [Options] -> Set LongName
extractValidNames options =
foldr f emptySet options
where
f :: Options -> Set LongName -> Set LongName
f (Option longname _ _ _) valids = insertElement longname valids
f _ valids = valids
extractShortNames :: [Options] -> Map ShortName LongName
extractShortNames options =
foldr g emptyMap options
where
g :: Options -> Map ShortName LongName -> Map ShortName LongName
g (Option longname shortname _ _) shorts = case shortname of
Just shortchar -> insertKeyValue shortchar longname shorts
Nothing -> shorts
g _ shorts = shorts
extractRequiredArguments :: [Options] -> [LongName]
extractRequiredArguments arguments =
foldr h [] arguments
where
h :: Options -> [LongName] -> [LongName]
h (Argument longname _) needed = longname : needed
h _ needed = needed
extractGlobalOptions :: [Commands] -> [Options]
extractGlobalOptions commands =
foldr j [] commands
where
j :: Commands -> [Options] -> [Options]
j (Global options) valids = options ++ valids
j _ valids = valids
extractValidModes :: [Commands] -> Map LongName [Options]
extractValidModes commands =
foldr k emptyMap commands
where
k :: Commands -> Map LongName [Options] -> Map LongName [Options]
k (Command longname _ options) modes = insertKeyValue longname options modes
k _ modes = modes
-- |
-- Break the command-line apart in two steps. The first peels off the global
-- options, the second below looks to see if there is a command (of fails) and
-- if so, whether it has any parameters.
--
-- We do it this way so that `parseCommandLine` can pas the global options to
-- `extractor` and thence `parsePossibleOptions` to catch --version and
-- --help.
splitCommandLine1 :: [String] -> Either InvalidCommandLine ([String], [String])
splitCommandLine1 args =
let (possibles, remainder) = List.span isOption args
in if null possibles && null remainder
then Left NoCommandFound
else Right (possibles, remainder)
splitCommandLine2 :: [String] -> Either InvalidCommandLine (String, [String])
splitCommandLine2 argv' =
let x = List.uncons argv'
in case x of
Just (mode, remainingArgs) -> Right (mode, remainingArgs)
Nothing -> Left NoCommandFound
--
-- Environment variable handling
--
extractValidEnvironments :: Maybe LongName -> Config -> Set LongName
extractValidEnvironments mode config = case config of
Blank -> emptySet
Simple options -> extractVariableNames options
Complex commands ->
let globals = extractGlobalOptions commands
variables1 = extractVariableNames globals
locals = extractLocalVariables commands (fromMaybe "" mode)
variables2 = extractVariableNames locals
in variables1 <> variables2
extractLocalVariables :: [Commands] -> LongName -> [Options]
extractLocalVariables commands mode =
foldr k [] commands
where
k :: Commands -> [Options] -> [Options]
k (Command name _ options) acc = if name == mode then options else acc
k _ acc = acc
extractVariableNames :: [Options] -> Set LongName
extractVariableNames options =
foldr f emptySet options
where
f :: Options -> Set LongName -> Set LongName
f (Variable longname _) valids = insertElement longname valids
f _ valids = valids
--
-- The code from here on is formatting code. It's fairly repetative
-- and crafted to achieve a specific aesthetic output. Rather messy.
-- I'm sure it could be done "better" but no matter; this is on the
-- path to an exit and return to user's command line.
--
buildUsage :: Config -> Maybe LongName -> Doc ann
buildUsage config mode = case config of
Blank -> emptyDoc
Simple options ->
let (o, a) = partitionParameters options
in "Usage:" <> hardline <> hardline
<> indent
4
( nest
4
( fillCat
[ pretty programName,
optionsSummary o,
argumentsSummary a
]
)
)
<> hardline
<> optionsHeading o
<> formatParameters o
<> argumentsHeading a
<> formatParameters a
Complex commands ->
let globalOptions = extractGlobalOptions commands
modes = extractValidModes commands
(oG, _) = partitionParameters globalOptions
in "Usage:" <> hardline <> hardline <> case mode of
Nothing ->
indent
2
( nest
4
( fillCat
[ pretty programName,
globalSummary oG,
commandSummary modes
]
)
)
<> hardline
<> globalHeading oG
<> formatParameters oG
<> commandHeading modes
<> formatCommands commands
Just longname ->
let (oL, aL) = case lookupKeyValue longname modes of
Just localOptions -> partitionParameters localOptions
Nothing -> error "Illegal State"
in indent
2
( nest
4
( fillCat
[ pretty programName,
globalSummary oG,
commandSummary modes,
localSummary oL,
argumentsSummary aL
]
)
)
<> hardline
<> localHeading oL
<> formatParameters oL
<> argumentsHeading aL
<> formatParameters aL
where
partitionParameters :: [Options] -> ([Options], [Options])
partitionParameters options = foldr f ([], []) options
optionsSummary :: [Options] -> Doc ann
optionsSummary os = if length os > 0 then softline <> "[OPTIONS]" else emptyDoc
optionsHeading os = if length os > 0 then hardline <> "Available options:" <> hardline else emptyDoc
globalSummary os = if length os > 0 then softline <> "[GLOBAL OPTIONS]" else emptyDoc
globalHeading os =
if length os > 0
then hardline <> "Global options:" <> hardline
else emptyDoc
localSummary os = if length os > 0 then softline <> "[LOCAL OPTIONS]" else emptyDoc
localHeading os =
if length os > 0
then hardline <> "Options to the '" <> commandName <> "' command:" <> hardline
else emptyDoc
commandName :: Doc ann
commandName = case mode of
Just (LongName name) -> pretty name
Nothing -> "COMMAND..."
argumentsSummary :: [Options] -> Doc ann
argumentsSummary as = " " <> fillSep (fmap pretty (extractRequiredArguments as))
argumentsHeading as = if length as > 0 then hardline <> "Required arguments:" <> hardline else emptyDoc
-- there is a corner case of complex config with no commands
commandSummary modes = if length modes > 0 then softline <> commandName else emptyDoc
commandHeading modes = if length modes > 0 then hardline <> "Available commands:" <> hardline else emptyDoc
f :: Options -> ([Options], [Options]) -> ([Options], [Options])
f o@(Option _ _ _ _) (opts, args) = (o : opts, args)
f a@(Argument _ _) (opts, args) = (opts, a : args)
f (Variable _ _) (opts, args) = (opts, args)
formatParameters :: [Options] -> Doc ann
formatParameters [] = emptyDoc
formatParameters options = hardline <> foldr g emptyDoc options
--
-- 16 characters width for short option, long option, and two spaces. If the
-- long option's name is wider than this the description will be moved to
-- the next line.
--
-- Arguments are aligned to the character of the short option; looks
-- pretty good and better than waiting until column 8.
--
g :: Options -> Doc ann -> Doc ann
g (Option longname shortname valued description) acc =
let s = case shortname of
Just shortchar -> " -" <> pretty shortchar <> ", --"
Nothing -> " --"
l = pretty longname
d = fromRope description
in case valued of
Empty ->
fillBreak 16 (s <> l <> " ") <+> align (reflow d) <> hardline <> acc
Value label ->
fillBreak 16 (s <> l <> "=" <> pretty label <> " ") <+> align (reflow d) <> hardline <> acc
g (Argument longname description) acc =
let l = pretty longname
d = fromRope description
in fillBreak 16 (" " <> l <> " ") <+> align (reflow d) <> hardline <> acc
g (Variable longname description) acc =
let l = pretty longname
d = fromRope description
in fillBreak 16 (" " <> l <> " ") <+> align (reflow d) <> hardline <> acc
formatCommands :: [Commands] -> Doc ann
formatCommands commands = hardline <> foldr h emptyDoc commands
h :: Commands -> Doc ann -> Doc ann
h (Command longname description _) acc =
let l = pretty longname
d = fromRope description
in fillBreak 16 (" " <> l <> " ") <+> align (reflow d) <> hardline <> acc
h _ acc = acc
buildVersion :: Version -> Doc ann
buildVersion version =
pretty (projectNameFrom version)
<+> "v"
<> pretty (versionNumberFrom version)
<> hardline