{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# 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,
    blankConfig,
    simpleConfig,
    complexConfig,
    baselineOptions,
    Parameters (..),
    ParameterValue (..),

    -- * Options and Arguments
    LongName (..),
    ShortName,
    Description,
    Options (..),

    -- * Programs with Commands
    Commands (..),
    appendOption,

    -- * Internals
    parseCommandLine,
    extractValidEnvironments,
    InvalidCommandLine (..),
    buildUsage,
    buildVersion,
    emptyParameters,
) where

import Data.Hashable (Hashable)
import Data.List qualified as List
import Data.Maybe (fromMaybe)
import Data.String (IsString (..))
import Prettyprinter (
    Doc,
    Pretty (..),
    align,
    emptyDoc,
    fillBreak,
    fillCat,
    fillSep,
    hardline,
    indent,
    nest,
    softline,
    (<+>),
 )
import Prettyprinter.Util (reflow)
import System.Environment (getProgName)

import Core.Data.Structures
import Core.Program.Metadata
import Core.System.Base
import Core.Text.Rope
import Core.Text.Utilities

{- |
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 (Int -> LongName -> ShowS
[LongName] -> ShowS
LongName -> String
(Int -> LongName -> ShowS)
-> (LongName -> String) -> ([LongName] -> ShowS) -> Show LongName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LongName] -> ShowS
$cshowList :: [LongName] -> ShowS
show :: LongName -> String
$cshow :: LongName -> String
showsPrec :: Int -> LongName -> ShowS
$cshowsPrec :: Int -> LongName -> ShowS
Show, String -> LongName
(String -> LongName) -> IsString LongName
forall a. (String -> a) -> IsString a
fromString :: String -> LongName
$cfromString :: String -> LongName
IsString, LongName -> LongName -> Bool
(LongName -> LongName -> Bool)
-> (LongName -> LongName -> Bool) -> Eq LongName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LongName -> LongName -> Bool
$c/= :: LongName -> LongName -> Bool
== :: LongName -> LongName -> Bool
$c== :: LongName -> LongName -> Bool
Eq, Eq LongName
Eq LongName
-> (Int -> LongName -> Int)
-> (LongName -> Int)
-> Hashable LongName
Int -> LongName -> Int
LongName -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: LongName -> Int
$chash :: LongName -> Int
hashWithSalt :: Int -> LongName -> Int
$chashWithSalt :: Int -> LongName -> Int
$cp1Hashable :: Eq LongName
Hashable, Eq LongName
Eq LongName
-> (LongName -> LongName -> Ordering)
-> (LongName -> LongName -> Bool)
-> (LongName -> LongName -> Bool)
-> (LongName -> LongName -> Bool)
-> (LongName -> LongName -> Bool)
-> (LongName -> LongName -> LongName)
-> (LongName -> LongName -> LongName)
-> Ord LongName
LongName -> LongName -> Bool
LongName -> LongName -> Ordering
LongName -> LongName -> LongName
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: LongName -> LongName -> LongName
$cmin :: LongName -> LongName -> LongName
max :: LongName -> LongName -> LongName
$cmax :: LongName -> LongName -> LongName
>= :: LongName -> LongName -> Bool
$c>= :: LongName -> LongName -> Bool
> :: LongName -> LongName -> Bool
$c> :: LongName -> LongName -> Bool
<= :: LongName -> LongName -> Bool
$c<= :: LongName -> LongName -> Bool
< :: LongName -> LongName -> Bool
$c< :: LongName -> LongName -> Bool
compare :: LongName -> LongName -> Ordering
$ccompare :: LongName -> LongName -> Ordering
$cp1Ord :: Eq LongName
Ord)

instance Key LongName

instance Pretty LongName where
    pretty :: LongName -> Doc ann
pretty (LongName String
name) = String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
name

instance Textual LongName where
    intoRope :: LongName -> Rope
intoRope (LongName String
str) = String -> Rope
forall α. Textual α => α -> Rope
intoRope String
str
    fromRope :: Rope -> LongName
fromRope = String -> LongName
LongName (String -> LongName) -> (Rope -> String) -> Rope -> LongName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rope -> String
forall α. Textual α => Rope -> α
fromRope

{- |
The setup for parsing the command-line arguments of your program. You build
a @Config@ with 'simpleConfig' or 'complexConfig', 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 'simpleConfig'.

@since 0.2.9
-}
blankConfig :: Config
blankConfig :: Config
blankConfig = Config
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' ('simpleConfig'
        [ '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 informational messages. 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".

@since 0.2.9
-}
simpleConfig :: [Options] -> Config
simpleConfig :: [Options] -> Config
simpleConfig [Options]
options = [Options] -> Config
Simple ([Options]
options [Options] -> [Options] -> [Options]
forall a. [a] -> [a] -> [a]
++ [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' ('complexConfig'
        [ '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".

@since 0.2.9
-}
complexConfig :: [Commands] -> Config
complexConfig :: [Commands] -> Config
complexConfig [Commands]
commands = [Commands] -> Config
Complex ([Commands]
commands [Commands] -> [Commands] -> [Commands]
forall a. [a] -> [a] -> [a]
++ [[Options] -> Commands
Global [Options]
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.

'Remaining' is special; it indicates that you are expecting a variable number
of additional, non-mandatory arguments. This is used for programs which take a
list of files to process, for example. It'll show up in the help with the
description you supply alongside.

@
        [ ...
        , 'Remaining' "The files you wish to delete permanently."
        , ...
        ]
@

'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
    | Remaining Description
    | Variable LongName Description
    deriving (Int -> Options -> ShowS
[Options] -> ShowS
Options -> String
(Int -> Options -> ShowS)
-> (Options -> String) -> ([Options] -> ShowS) -> Show Options
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Options] -> ShowS
$cshowList :: [Options] -> ShowS
show :: Options -> String
$cshow :: Options -> String
showsPrec :: Int -> Options -> ShowS
$cshowsPrec :: Int -> Options -> ShowS
Show)

appendOption :: Options -> Config -> Config
appendOption :: Options -> Config -> Config
appendOption Options
option Config
config =
    case Config
config of
        Config
Blank -> Config
Blank
        Simple [Options]
options -> [Options] -> Config
Simple ([Options]
options [Options] -> [Options] -> [Options]
forall a. [a] -> [a] -> [a]
++ [Options
option])
        Complex [Commands]
commands -> [Commands] -> Config
Complex ([Commands]
commands [Commands] -> [Commands] -> [Commands]
forall a. [a] -> [a] -> [a]
++ [[Options] -> Commands
Global [Options
option]])

{- |
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 (Int -> ParameterValue -> ShowS
[ParameterValue] -> ShowS
ParameterValue -> String
(Int -> ParameterValue -> ShowS)
-> (ParameterValue -> String)
-> ([ParameterValue] -> ShowS)
-> Show ParameterValue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParameterValue] -> ShowS
$cshowList :: [ParameterValue] -> ShowS
show :: ParameterValue -> String
$cshow :: ParameterValue -> String
showsPrec :: Int -> ParameterValue -> ShowS
$cshowsPrec :: Int -> ParameterValue -> ShowS
Show, ParameterValue -> ParameterValue -> Bool
(ParameterValue -> ParameterValue -> Bool)
-> (ParameterValue -> ParameterValue -> Bool) -> Eq ParameterValue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParameterValue -> ParameterValue -> Bool
$c/= :: ParameterValue -> ParameterValue -> Bool
== :: ParameterValue -> ParameterValue -> Bool
$c== :: ParameterValue -> ParameterValue -> Bool
Eq)

instance IsString ParameterValue where
    fromString :: String -> ParameterValue
fromString String
x = String -> ParameterValue
Value String
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
    { Parameters -> Maybe LongName
commandNameFrom :: Maybe LongName
    , Parameters -> Map LongName ParameterValue
parameterValuesFrom :: Map LongName ParameterValue
    , Parameters -> [String]
remainingArgumentsFrom :: [String]
    , Parameters -> Map LongName ParameterValue
environmentValuesFrom :: Map LongName ParameterValue
    }
    deriving (Int -> Parameters -> ShowS
[Parameters] -> ShowS
Parameters -> String
(Int -> Parameters -> ShowS)
-> (Parameters -> String)
-> ([Parameters] -> ShowS)
-> Show Parameters
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Parameters] -> ShowS
$cshowList :: [Parameters] -> ShowS
show :: Parameters -> String
$cshow :: Parameters -> String
showsPrec :: Int -> Parameters -> ShowS
$cshowsPrec :: Int -> Parameters -> ShowS
Show, Parameters -> Parameters -> Bool
(Parameters -> Parameters -> Bool)
-> (Parameters -> Parameters -> Bool) -> Eq Parameters
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Parameters -> Parameters -> Bool
$c/= :: Parameters -> Parameters -> Bool
== :: Parameters -> Parameters -> Bool
$c== :: Parameters -> Parameters -> Bool
Eq)

emptyParameters :: Parameters
emptyParameters :: Parameters
emptyParameters =
    Parameters :: Maybe LongName
-> Map LongName ParameterValue
-> [String]
-> Map LongName ParameterValue
-> Parameters
Parameters
        { commandNameFrom :: Maybe LongName
commandNameFrom = Maybe LongName
forall a. Maybe a
Nothing
        , parameterValuesFrom :: Map LongName ParameterValue
parameterValuesFrom = Map LongName ParameterValue
forall κ ν. Map κ ν
emptyMap
        , remainingArgumentsFrom :: [String]
remainingArgumentsFrom = []
        , environmentValuesFrom :: Map LongName ParameterValue
environmentValuesFrom = Map LongName ParameterValue
forall κ ν. Map κ ν
emptyMap
        }

baselineOptions :: [Options]
baselineOptions :: [Options]
baselineOptions =
    [ LongName -> Maybe ShortName -> ParameterValue -> Rope -> Options
Option
        LongName
"verbose"
        (ShortName -> Maybe ShortName
forall a. a -> Maybe a
Just ShortName
'v')
        ParameterValue
Empty
        [quote|
        Turn on informational messages. The logging stream will go
        to standard output in your terminal.
    |]
    , LongName -> Maybe ShortName -> ParameterValue -> Rope -> Options
Option
        LongName
"debug"
        Maybe ShortName
forall a. Maybe a
Nothing
        ParameterValue
Empty
        [quote|
        Turn on debug output. 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 (Int -> InvalidCommandLine -> ShowS
[InvalidCommandLine] -> ShowS
InvalidCommandLine -> String
(Int -> InvalidCommandLine -> ShowS)
-> (InvalidCommandLine -> String)
-> ([InvalidCommandLine] -> ShowS)
-> Show InvalidCommandLine
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InvalidCommandLine] -> ShowS
$cshowList :: [InvalidCommandLine] -> ShowS
show :: InvalidCommandLine -> String
$cshow :: InvalidCommandLine -> String
showsPrec :: Int -> InvalidCommandLine -> ShowS
$cshowsPrec :: Int -> InvalidCommandLine -> ShowS
Show, InvalidCommandLine -> InvalidCommandLine -> Bool
(InvalidCommandLine -> InvalidCommandLine -> Bool)
-> (InvalidCommandLine -> InvalidCommandLine -> Bool)
-> Eq InvalidCommandLine
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InvalidCommandLine -> InvalidCommandLine -> Bool
$c/= :: InvalidCommandLine -> InvalidCommandLine -> Bool
== :: InvalidCommandLine -> InvalidCommandLine -> Bool
$c== :: InvalidCommandLine -> InvalidCommandLine -> Bool
Eq)

instance Exception InvalidCommandLine where
    displayException :: InvalidCommandLine -> String
displayException InvalidCommandLine
e = case InvalidCommandLine
e of
        InvalidOption String
arg ->
            let one :: String
one = String
"Option '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
arg String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' illegal.\n\n"
                two :: String
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 String
one String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
two
        UnknownOption String
name -> String
"Sorry, option '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' not recognized."
        MissingArgument (LongName String
name) -> String
"Mandatory argument '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' missing."
        UnexpectedArguments [String]
args ->
            let quoted :: String
quoted = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
"', '" [String]
args
             in [quote|
Unexpected trailing arguments:

|]
                    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
quoted
                    String -> ShowS
forall a. [a] -> [a] -> [a]
++ [quote|

For arguments expected by this program, please see --help.
|]
        UnknownCommand String
first -> String
"Hm. Command '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
first String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' not recognized."
        InvalidCommandLine
NoCommandFound ->
            [quote|
No command specified.
Usage is of the form:

    |]
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
programName
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ [quote| [GLOBAL OPTIONS] COMMAND [LOCAL OPTIONS] [ARGUMENTS]

See --help for details.
|]
        -- handled by parent module calling back into here buildUsage
        HelpRequest Maybe LongName
_ -> String
""
        -- handled by parent module calling back into here buildVersion
        InvalidCommandLine
VersionRequest -> String
""

programName :: String
programName :: String
programName = IO String -> String
forall a. IO a -> a
unsafePerformIO IO String
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 'Core.Program.Context.configure' with a default 'Config' when
initializing).
-}
parseCommandLine :: Config -> [String] -> Either InvalidCommandLine Parameters
parseCommandLine :: Config -> [String] -> Either InvalidCommandLine Parameters
parseCommandLine Config
config [String]
argv = case Config
config of
    Config
Blank -> Parameters -> Either InvalidCommandLine Parameters
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe LongName
-> Map LongName ParameterValue
-> [String]
-> Map LongName ParameterValue
-> Parameters
Parameters Maybe LongName
forall a. Maybe a
Nothing Map LongName ParameterValue
forall κ ν. Map κ ν
emptyMap [] Map LongName ParameterValue
forall κ ν. Map κ ν
emptyMap)
    Simple [Options]
options -> do
        (Map LongName ParameterValue
params, [String]
remainder) <- Maybe LongName
-> [Options]
-> [String]
-> Either
     InvalidCommandLine (Map LongName ParameterValue, [String])
extractor Maybe LongName
forall a. Maybe a
Nothing [Options]
options [String]
argv
        [Options] -> [String] -> Either InvalidCommandLine ()
checkRemainder [Options]
options [String]
remainder
        Parameters -> Either InvalidCommandLine Parameters
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe LongName
-> Map LongName ParameterValue
-> [String]
-> Map LongName ParameterValue
-> Parameters
Parameters Maybe LongName
forall a. Maybe a
Nothing Map LongName ParameterValue
params [String]
remainder Map LongName ParameterValue
forall κ ν. Map κ ν
emptyMap)
    Complex [Commands]
commands ->
        let globalOptions :: [Options]
globalOptions = [Commands] -> [Options]
extractGlobalOptions [Commands]
commands
            modes :: Map LongName [Options]
modes = [Commands] -> Map LongName [Options]
extractValidModes [Commands]
commands
         in do
                ([String]
possibles, [String]
argv') <- [String] -> Either InvalidCommandLine ([String], [String])
splitCommandLine1 [String]
argv
                (Map LongName ParameterValue
params1, [String]
_) <- Maybe LongName
-> [Options]
-> [String]
-> Either
     InvalidCommandLine (Map LongName ParameterValue, [String])
extractor Maybe LongName
forall a. Maybe a
Nothing [Options]
globalOptions [String]
possibles
                (String
first, [String]
moreArgs) <- [String] -> Either InvalidCommandLine (String, [String])
splitCommandLine2 [String]
argv'
                (LongName
mode, [Options]
localOptions) <- Map LongName [Options]
-> String -> Either InvalidCommandLine (LongName, [Options])
parseIndicatedCommand Map LongName [Options]
modes String
first
                (Map LongName ParameterValue
params2, [String]
remainder) <- Maybe LongName
-> [Options]
-> [String]
-> Either
     InvalidCommandLine (Map LongName ParameterValue, [String])
extractor (LongName -> Maybe LongName
forall a. a -> Maybe a
Just LongName
mode) [Options]
localOptions [String]
moreArgs
                [Options] -> [String] -> Either InvalidCommandLine ()
checkRemainder [Options]
localOptions [String]
remainder
                Parameters -> Either InvalidCommandLine Parameters
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe LongName
-> Map LongName ParameterValue
-> [String]
-> Map LongName ParameterValue
-> Parameters
Parameters (LongName -> Maybe LongName
forall a. a -> Maybe a
Just LongName
mode) (Map LongName ParameterValue
-> Map LongName ParameterValue -> Map LongName ParameterValue
forall a. Semigroup a => a -> a -> a
(<>) Map LongName ParameterValue
params1 Map LongName ParameterValue
params2) [String]
remainder Map LongName ParameterValue
forall κ ν. Map κ ν
emptyMap)
  where
    extractor :: Maybe LongName -> [Options] -> [String] -> Either InvalidCommandLine ((Map LongName ParameterValue), [String])
    extractor :: Maybe LongName
-> [Options]
-> [String]
-> Either
     InvalidCommandLine (Map LongName ParameterValue, [String])
extractor Maybe LongName
mode [Options]
options [String]
args =
        let ([String]
possibles, [String]
arguments) = (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition String -> Bool
isOption [String]
args
            valids :: Set LongName
valids = [Options] -> Set LongName
extractValidNames [Options]
options
            shorts :: Map ShortName LongName
shorts = [Options] -> Map ShortName LongName
extractShortNames [Options]
options
            needed :: [LongName]
needed = [Options] -> [LongName]
extractRequiredArguments [Options]
options
         in do
                [(LongName, ParameterValue)]
list1 <- Maybe LongName
-> Set LongName
-> Map ShortName LongName
-> [String]
-> Either InvalidCommandLine [(LongName, ParameterValue)]
parsePossibleOptions Maybe LongName
mode Set LongName
valids Map ShortName LongName
shorts [String]
possibles
                ([(LongName, ParameterValue)]
list2, [String]
arguments') <- [LongName]
-> [String]
-> Either
     InvalidCommandLine ([(LongName, ParameterValue)], [String])
parseRequiredArguments [LongName]
needed [String]
arguments
                (Map LongName ParameterValue, [String])
-> Either
     InvalidCommandLine (Map LongName ParameterValue, [String])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Map LongName ParameterValue
-> Map LongName ParameterValue -> Map LongName ParameterValue
forall a. Semigroup a => a -> a -> a
(<>) ([(LongName, ParameterValue)]
-> Map
     (K [(LongName, ParameterValue)]) (V [(LongName, ParameterValue)])
forall α. Dictionary α => α -> Map (K α) (V α)
intoMap [(LongName, ParameterValue)]
list1) ([(LongName, ParameterValue)]
-> Map
     (K [(LongName, ParameterValue)]) (V [(LongName, ParameterValue)])
forall α. Dictionary α => α -> Map (K α) (V α)
intoMap [(LongName, ParameterValue)]
list2)), [String]
arguments')

    checkRemainder :: [Options] -> [String] -> Either InvalidCommandLine ()
    checkRemainder :: [Options] -> [String] -> Either InvalidCommandLine ()
checkRemainder [Options]
options [String]
remainder =
        if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
List.null [String]
remainder
            then () -> Either InvalidCommandLine ()
forall a b. b -> Either a b
Right ()
            else
                if [Options] -> Bool
hasRemaining [Options]
options
                    then () -> Either InvalidCommandLine ()
forall a b. b -> Either a b
Right ()
                    else InvalidCommandLine -> Either InvalidCommandLine ()
forall a b. a -> Either a b
Left ([String] -> InvalidCommandLine
UnexpectedArguments [String]
remainder)

-- is one of the options Remaining?
hasRemaining :: [Options] -> Bool
hasRemaining :: [Options] -> Bool
hasRemaining [Options]
options =
    (Bool -> Options -> Bool) -> Bool -> [Options] -> Bool
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl'
        ( \Bool
acc Options
option -> case Options
option of
            Remaining Rope
_ -> Bool
True
            Options
_ -> Bool
acc
        )
        Bool
False
        [Options]
options

isOption :: String -> Bool
isOption :: String -> Bool
isOption String
arg = case String
arg of
    (ShortName
'-' : String
_) -> Bool
True
    String
_ -> Bool
False

parsePossibleOptions ::
    Maybe LongName ->
    Set LongName ->
    Map ShortName LongName ->
    [String] ->
    Either InvalidCommandLine [(LongName, ParameterValue)]
parsePossibleOptions :: Maybe LongName
-> Set LongName
-> Map ShortName LongName
-> [String]
-> Either InvalidCommandLine [(LongName, ParameterValue)]
parsePossibleOptions Maybe LongName
mode Set LongName
valids Map ShortName LongName
shorts [String]
args = (String -> Either InvalidCommandLine (LongName, ParameterValue))
-> [String]
-> Either InvalidCommandLine [(LongName, ParameterValue)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> Either InvalidCommandLine (LongName, ParameterValue)
f [String]
args
  where
    f :: String -> Either InvalidCommandLine (LongName, ParameterValue)
f String
arg = case String
arg of
        String
"--help" -> InvalidCommandLine
-> Either InvalidCommandLine (LongName, ParameterValue)
forall a b. a -> Either a b
Left (Maybe LongName -> InvalidCommandLine
HelpRequest Maybe LongName
mode)
        String
"-?" -> InvalidCommandLine
-> Either InvalidCommandLine (LongName, ParameterValue)
forall a b. a -> Either a b
Left (Maybe LongName -> InvalidCommandLine
HelpRequest Maybe LongName
mode)
        String
"--version" -> InvalidCommandLine
-> Either InvalidCommandLine (LongName, ParameterValue)
forall a b. a -> Either a b
Left InvalidCommandLine
VersionRequest
        (ShortName
'-' : ShortName
'-' : String
name) -> String -> Either InvalidCommandLine (LongName, ParameterValue)
considerLongOption String
name
        (ShortName
'-' : ShortName
c : []) -> ShortName -> Either InvalidCommandLine (LongName, ParameterValue)
considerShortOption ShortName
c
        String
_ -> InvalidCommandLine
-> Either InvalidCommandLine (LongName, ParameterValue)
forall a b. a -> Either a b
Left (String -> InvalidCommandLine
InvalidOption String
arg)

    considerLongOption :: String -> Either InvalidCommandLine (LongName, ParameterValue)
    considerLongOption :: String -> Either InvalidCommandLine (LongName, ParameterValue)
considerLongOption String
arg =
        let (String
name, String
value) = (ShortName -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.span (ShortName -> ShortName -> Bool
forall a. Eq a => a -> a -> Bool
/= ShortName
'=') String
arg
            candidate :: LongName
candidate = String -> LongName
LongName String
name
            -- lose the '='
            value' :: ParameterValue
value' = case String -> Maybe (ShortName, String)
forall a. [a] -> Maybe (a, [a])
List.uncons String
value of
                Just (ShortName
_, String
remainder) -> String -> ParameterValue
Value String
remainder
                Maybe (ShortName, String)
Nothing -> ParameterValue
Empty
         in if LongName -> Set LongName -> Bool
forall ε. Key ε => ε -> Set ε -> Bool
containsElement LongName
candidate Set LongName
valids
                then (LongName, ParameterValue)
-> Either InvalidCommandLine (LongName, ParameterValue)
forall a b. b -> Either a b
Right (LongName
candidate, ParameterValue
value')
                else InvalidCommandLine
-> Either InvalidCommandLine (LongName, ParameterValue)
forall a b. a -> Either a b
Left (String -> InvalidCommandLine
UnknownOption (String
"--" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name))

    considerShortOption :: Char -> Either InvalidCommandLine (LongName, ParameterValue)
    considerShortOption :: ShortName -> Either InvalidCommandLine (LongName, ParameterValue)
considerShortOption ShortName
c =
        case ShortName -> Map ShortName LongName -> Maybe LongName
forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue ShortName
c Map ShortName LongName
shorts of
            Just LongName
name -> (LongName, ParameterValue)
-> Either InvalidCommandLine (LongName, ParameterValue)
forall a b. b -> Either a b
Right (LongName
name, ParameterValue
Empty)
            Maybe LongName
Nothing -> InvalidCommandLine
-> Either InvalidCommandLine (LongName, ParameterValue)
forall a b. a -> Either a b
Left (String -> InvalidCommandLine
UnknownOption [ShortName
'-', ShortName
c])

parseRequiredArguments ::
    [LongName] ->
    [String] ->
    Either InvalidCommandLine ([(LongName, ParameterValue)], [String])
parseRequiredArguments :: [LongName]
-> [String]
-> Either
     InvalidCommandLine ([(LongName, ParameterValue)], [String])
parseRequiredArguments [LongName]
needed [String]
argv = [LongName]
-> [String]
-> Either
     InvalidCommandLine ([(LongName, ParameterValue)], [String])
iter [LongName]
needed [String]
argv
  where
    iter :: [LongName] -> [String] -> Either InvalidCommandLine ([(LongName, ParameterValue)], [String])
    iter :: [LongName]
-> [String]
-> Either
     InvalidCommandLine ([(LongName, ParameterValue)], [String])
iter [] [] = ([(LongName, ParameterValue)], [String])
-> Either
     InvalidCommandLine ([(LongName, ParameterValue)], [String])
forall a b. b -> Either a b
Right ([], [])
    -- more arguments supplied than expected
    iter [] [String]
args = ([(LongName, ParameterValue)], [String])
-> Either
     InvalidCommandLine ([(LongName, ParameterValue)], [String])
forall a b. b -> Either a b
Right ([], [String]
args)
    -- more arguments required, not satisfied
    iter (LongName
name : [LongName]
_) [] = InvalidCommandLine
-> Either
     InvalidCommandLine ([(LongName, ParameterValue)], [String])
forall a b. a -> Either a b
Left (LongName -> InvalidCommandLine
MissingArgument LongName
name)
    iter (LongName
name : [LongName]
names) (String
arg : [String]
args) =
        let deeper :: Either InvalidCommandLine ([(LongName, ParameterValue)], [String])
deeper = [LongName]
-> [String]
-> Either
     InvalidCommandLine ([(LongName, ParameterValue)], [String])
iter [LongName]
names [String]
args
         in case Either InvalidCommandLine ([(LongName, ParameterValue)], [String])
deeper of
                Left InvalidCommandLine
e -> InvalidCommandLine
-> Either
     InvalidCommandLine ([(LongName, ParameterValue)], [String])
forall a b. a -> Either a b
Left InvalidCommandLine
e
                Right ([(LongName, ParameterValue)]
list, [String]
remainder) -> ([(LongName, ParameterValue)], [String])
-> Either
     InvalidCommandLine ([(LongName, ParameterValue)], [String])
forall a b. b -> Either a b
Right (((LongName
name, String -> ParameterValue
Value String
arg) (LongName, ParameterValue)
-> [(LongName, ParameterValue)] -> [(LongName, ParameterValue)]
forall a. a -> [a] -> [a]
: [(LongName, ParameterValue)]
list), [String]
remainder)

parseIndicatedCommand ::
    Map LongName [Options] ->
    String ->
    Either InvalidCommandLine (LongName, [Options])
parseIndicatedCommand :: Map LongName [Options]
-> String -> Either InvalidCommandLine (LongName, [Options])
parseIndicatedCommand Map LongName [Options]
modes String
first =
    let candidate :: LongName
candidate = String -> LongName
LongName String
first
     in case LongName -> Map LongName [Options] -> Maybe [Options]
forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue LongName
candidate Map LongName [Options]
modes of
            Just [Options]
options -> (LongName, [Options])
-> Either InvalidCommandLine (LongName, [Options])
forall a b. b -> Either a b
Right (LongName
candidate, [Options]
options)
            Maybe [Options]
Nothing -> InvalidCommandLine
-> Either InvalidCommandLine (LongName, [Options])
forall a b. a -> Either a b
Left (String -> InvalidCommandLine
UnknownCommand String
first)

--
-- Ok, the f,g,h,... was silly. But hey :)
--

extractValidNames :: [Options] -> Set LongName
extractValidNames :: [Options] -> Set LongName
extractValidNames [Options]
options =
    (Options -> Set LongName -> Set LongName)
-> Set LongName -> [Options] -> Set LongName
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Options -> Set LongName -> Set LongName
f Set LongName
forall ε. Key ε => Set ε
emptySet [Options]
options
  where
    f :: Options -> Set LongName -> Set LongName
    f :: Options -> Set LongName -> Set LongName
f (Option LongName
longname Maybe ShortName
_ ParameterValue
_ Rope
_) Set LongName
valids = LongName -> Set LongName -> Set LongName
forall ε. Key ε => ε -> Set ε -> Set ε
insertElement LongName
longname Set LongName
valids
    f Options
_ Set LongName
valids = Set LongName
valids

extractShortNames :: [Options] -> Map ShortName LongName
extractShortNames :: [Options] -> Map ShortName LongName
extractShortNames [Options]
options =
    (Options -> Map ShortName LongName -> Map ShortName LongName)
-> Map ShortName LongName -> [Options] -> Map ShortName LongName
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Options -> Map ShortName LongName -> Map ShortName LongName
g Map ShortName LongName
forall κ ν. Map κ ν
emptyMap [Options]
options
  where
    g :: Options -> Map ShortName LongName -> Map ShortName LongName
    g :: Options -> Map ShortName LongName -> Map ShortName LongName
g (Option LongName
longname Maybe ShortName
shortname ParameterValue
_ Rope
_) Map ShortName LongName
shorts = case Maybe ShortName
shortname of
        Just ShortName
shortchar -> ShortName
-> LongName -> Map ShortName LongName -> Map ShortName LongName
forall κ ν. Key κ => κ -> ν -> Map κ ν -> Map κ ν
insertKeyValue ShortName
shortchar LongName
longname Map ShortName LongName
shorts
        Maybe ShortName
Nothing -> Map ShortName LongName
shorts
    g Options
_ Map ShortName LongName
shorts = Map ShortName LongName
shorts

extractRequiredArguments :: [Options] -> [LongName]
extractRequiredArguments :: [Options] -> [LongName]
extractRequiredArguments [Options]
arguments =
    (Options -> [LongName] -> [LongName])
-> [LongName] -> [Options] -> [LongName]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
List.foldr Options -> [LongName] -> [LongName]
h [] [Options]
arguments
  where
    h :: Options -> [LongName] -> [LongName]
    h :: Options -> [LongName] -> [LongName]
h (Argument LongName
longname Rope
_) [LongName]
needed = LongName
longname LongName -> [LongName] -> [LongName]
forall a. a -> [a] -> [a]
: [LongName]
needed
    h Options
_ [LongName]
needed = [LongName]
needed

extractGlobalOptions :: [Commands] -> [Options]
extractGlobalOptions :: [Commands] -> [Options]
extractGlobalOptions [Commands]
commands =
    (Commands -> [Options] -> [Options])
-> [Options] -> [Commands] -> [Options]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Commands -> [Options] -> [Options]
j [] [Commands]
commands
  where
    j :: Commands -> [Options] -> [Options]
    j :: Commands -> [Options] -> [Options]
j (Global [Options]
options) [Options]
valids = [Options]
options [Options] -> [Options] -> [Options]
forall a. [a] -> [a] -> [a]
++ [Options]
valids
    j Commands
_ [Options]
valids = [Options]
valids

extractValidModes :: [Commands] -> Map LongName [Options]
extractValidModes :: [Commands] -> Map LongName [Options]
extractValidModes [Commands]
commands =
    (Map LongName [Options] -> Commands -> Map LongName [Options])
-> Map LongName [Options] -> [Commands] -> Map LongName [Options]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Map LongName [Options] -> Commands -> Map LongName [Options]
k Map LongName [Options]
forall κ ν. Map κ ν
emptyMap [Commands]
commands
  where
    k :: Map LongName [Options] -> Commands -> Map LongName [Options]
    k :: Map LongName [Options] -> Commands -> Map LongName [Options]
k Map LongName [Options]
modes (Command LongName
longname Rope
_ [Options]
options) = LongName
-> [Options] -> Map LongName [Options] -> Map LongName [Options]
forall κ ν. Key κ => κ -> ν -> Map κ ν -> Map κ ν
insertKeyValue LongName
longname [Options]
options Map LongName [Options]
modes
    k Map LongName [Options]
modes Commands
_ = Map LongName [Options]
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 :: [String] -> Either InvalidCommandLine ([String], [String])
splitCommandLine1 [String]
args =
    let ([String]
possibles, [String]
remainder) = (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.span String -> Bool
isOption [String]
args
     in if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
possibles Bool -> Bool -> Bool
&& [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
remainder
            then InvalidCommandLine
-> Either InvalidCommandLine ([String], [String])
forall a b. a -> Either a b
Left InvalidCommandLine
NoCommandFound
            else ([String], [String])
-> Either InvalidCommandLine ([String], [String])
forall a b. b -> Either a b
Right ([String]
possibles, [String]
remainder)

splitCommandLine2 :: [String] -> Either InvalidCommandLine (String, [String])
splitCommandLine2 :: [String] -> Either InvalidCommandLine (String, [String])
splitCommandLine2 [String]
argv' =
    let x :: Maybe (String, [String])
x = [String] -> Maybe (String, [String])
forall a. [a] -> Maybe (a, [a])
List.uncons [String]
argv'
     in case Maybe (String, [String])
x of
            Just (String
mode, [String]
remainingArgs) -> (String, [String]) -> Either InvalidCommandLine (String, [String])
forall a b. b -> Either a b
Right (String
mode, [String]
remainingArgs)
            Maybe (String, [String])
Nothing -> InvalidCommandLine -> Either InvalidCommandLine (String, [String])
forall a b. a -> Either a b
Left InvalidCommandLine
NoCommandFound

--
-- Environment variable handling
--

extractValidEnvironments :: Maybe LongName -> Config -> Set LongName
extractValidEnvironments :: Maybe LongName -> Config -> Set LongName
extractValidEnvironments Maybe LongName
mode Config
config = case Config
config of
    Config
Blank -> Set LongName
forall ε. Key ε => Set ε
emptySet
    Simple [Options]
options -> [Options] -> Set LongName
extractVariableNames [Options]
options
    Complex [Commands]
commands ->
        let globals :: [Options]
globals = [Commands] -> [Options]
extractGlobalOptions [Commands]
commands
            variables1 :: Set LongName
variables1 = [Options] -> Set LongName
extractVariableNames [Options]
globals

            locals :: [Options]
locals = [Commands] -> LongName -> [Options]
extractLocalVariables [Commands]
commands (LongName -> Maybe LongName -> LongName
forall a. a -> Maybe a -> a
fromMaybe LongName
"" Maybe LongName
mode)
            variables2 :: Set LongName
variables2 = [Options] -> Set LongName
extractVariableNames [Options]
locals
         in Set LongName
variables1 Set LongName -> Set LongName -> Set LongName
forall a. Semigroup a => a -> a -> a
<> Set LongName
variables2

extractLocalVariables :: [Commands] -> LongName -> [Options]
extractLocalVariables :: [Commands] -> LongName -> [Options]
extractLocalVariables [Commands]
commands LongName
mode =
    (Commands -> [Options] -> [Options])
-> [Options] -> [Commands] -> [Options]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Commands -> [Options] -> [Options]
k [] [Commands]
commands
  where
    k :: Commands -> [Options] -> [Options]
    k :: Commands -> [Options] -> [Options]
k (Command LongName
name Rope
_ [Options]
options) [Options]
acc = if LongName
name LongName -> LongName -> Bool
forall a. Eq a => a -> a -> Bool
== LongName
mode then [Options]
options else [Options]
acc
    k Commands
_ [Options]
acc = [Options]
acc

extractVariableNames :: [Options] -> Set LongName
extractVariableNames :: [Options] -> Set LongName
extractVariableNames [Options]
options =
    (Options -> Set LongName -> Set LongName)
-> Set LongName -> [Options] -> Set LongName
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Options -> Set LongName -> Set LongName
f Set LongName
forall ε. Key ε => Set ε
emptySet [Options]
options
  where
    f :: Options -> Set LongName -> Set LongName
    f :: Options -> Set LongName -> Set LongName
f (Variable LongName
longname Rope
_) Set LongName
valids = LongName -> Set LongName -> Set LongName
forall ε. Key ε => ε -> Set ε -> Set ε
insertElement LongName
longname Set LongName
valids
    f Options
_ Set LongName
valids = Set LongName
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 shell prompt.
--

buildUsage :: Config -> Maybe LongName -> Doc ann
buildUsage :: Config -> Maybe LongName -> Doc ann
buildUsage Config
config Maybe LongName
mode = case Config
config of
    Config
Blank -> Doc ann
forall ann. Doc ann
emptyDoc
    Simple [Options]
options ->
        let ([Options]
o, [Options]
a, [Options]
v) = [Options] -> ([Options], [Options], [Options])
partitionParameters [Options]
options
         in Doc ann
"Usage:" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
hardline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
hardline
                Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent
                    Int
4
                    ( Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest
                        Int
4
                        ( [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
fillCat
                            [ String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
programName
                            , [Options] -> Doc ann
forall ann. [Options] -> Doc ann
optionsSummary [Options]
o
                            , [Options] -> Doc ann
forall ann. [Options] -> Doc ann
argumentsSummary [Options]
a
                            , [Options] -> Doc ann
forall ann. [Options] -> Doc ann
remainingSummary [Options]
a
                            ]
                        )
                    )
                Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
hardline
                Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Options] -> Doc ann
forall (t :: * -> *) a ann. Foldable t => t a -> Doc ann
optionsHeading [Options]
o
                Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Options] -> Doc ann
forall ann. [Options] -> Doc ann
formatParameters [Options]
o
                Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Options] -> Doc ann
forall (t :: * -> *) a ann. Foldable t => t a -> Doc ann
argumentsHeading [Options]
a
                Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Options] -> Doc ann
forall ann. [Options] -> Doc ann
formatParameters [Options]
a
                Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Options] -> Doc ann
forall (t :: * -> *) a ann. Foldable t => t a -> Doc ann
variablesHeading [Options]
v
                Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Options] -> Doc ann
forall ann. [Options] -> Doc ann
formatParameters [Options]
v
    Complex [Commands]
commands ->
        let globalOptions :: [Options]
globalOptions = [Commands] -> [Options]
extractGlobalOptions [Commands]
commands
            modes :: Map LongName [Options]
modes = [Commands] -> Map LongName [Options]
extractValidModes [Commands]
commands

            ([Options]
oG, [Options]
_, [Options]
vG) = [Options] -> ([Options], [Options], [Options])
partitionParameters [Options]
globalOptions
         in Doc ann
"Usage:" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
hardline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
hardline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> case Maybe LongName
mode of
                Maybe LongName
Nothing ->
                    Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent
                        Int
2
                        ( Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest
                            Int
4
                            ( [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
fillCat
                                [ String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
programName
                                , [Options] -> Doc ann
forall (t :: * -> *) a ann. Foldable t => t a -> Doc ann
globalSummary [Options]
oG
                                , Map LongName [Options] -> Doc ann
forall (t :: * -> *) a ann. Foldable t => t a -> Doc ann
commandSummary Map LongName [Options]
modes
                                ]
                            )
                        )
                        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
hardline
                        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Options] -> Doc ann
forall (t :: * -> *) a ann. Foldable t => t a -> Doc ann
globalHeading [Options]
oG
                        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Options] -> Doc ann
forall ann. [Options] -> Doc ann
formatParameters [Options]
oG
                        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Map LongName [Options] -> Doc ann
forall (t :: * -> *) a ann. Foldable t => t a -> Doc ann
commandHeading Map LongName [Options]
modes
                        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Commands] -> Doc ann
forall ann. [Commands] -> Doc ann
formatCommands [Commands]
commands
                        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Options] -> Doc ann
forall (t :: * -> *) a ann. Foldable t => t a -> Doc ann
variablesHeading [Options]
vG
                        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Options] -> Doc ann
forall ann. [Options] -> Doc ann
formatParameters [Options]
vG
                Just LongName
longname ->
                    let ([Options]
oL, [Options]
aL, [Options]
vL) = case LongName -> Map LongName [Options] -> Maybe [Options]
forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue LongName
longname Map LongName [Options]
modes of
                            Just [Options]
localOptions -> [Options] -> ([Options], [Options], [Options])
partitionParameters [Options]
localOptions
                            Maybe [Options]
Nothing -> String -> ([Options], [Options], [Options])
forall a. HasCallStack => String -> a
error String
"Illegal State"
                     in Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent
                            Int
2
                            ( Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest
                                Int
4
                                ( [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
fillCat
                                    [ String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
programName
                                    , [Options] -> Doc ann
forall (t :: * -> *) a ann. Foldable t => t a -> Doc ann
globalSummary [Options]
oG
                                    , Map LongName [Options] -> Doc ann
forall (t :: * -> *) a ann. Foldable t => t a -> Doc ann
commandSummary Map LongName [Options]
modes
                                    , [Options] -> Doc ann
forall (t :: * -> *) a ann. Foldable t => t a -> Doc ann
localSummary [Options]
oL
                                    , [Options] -> Doc ann
forall ann. [Options] -> Doc ann
argumentsSummary [Options]
aL
                                    , [Options] -> Doc ann
forall ann. [Options] -> Doc ann
remainingSummary [Options]
aL
                                    ]
                                )
                            )
                            Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
hardline
                            Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Options] -> Doc ann
forall (t :: * -> *) a ann. Foldable t => t a -> Doc ann
localHeading [Options]
oL
                            Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Options] -> Doc ann
forall ann. [Options] -> Doc ann
formatParameters [Options]
oL
                            Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Options] -> Doc ann
forall (t :: * -> *) a ann. Foldable t => t a -> Doc ann
argumentsHeading [Options]
aL
                            Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Options] -> Doc ann
forall ann. [Options] -> Doc ann
formatParameters [Options]
aL
                            Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Options] -> Doc ann
forall (t :: * -> *) a ann. Foldable t => t a -> Doc ann
variablesHeading [Options]
vL
                            Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Options] -> Doc ann
forall ann. [Options] -> Doc ann
formatParameters [Options]
vL
  where
    partitionParameters :: [Options] -> ([Options], [Options], [Options])
    partitionParameters :: [Options] -> ([Options], [Options], [Options])
partitionParameters [Options]
options = (([Options], [Options], [Options])
 -> Options -> ([Options], [Options], [Options]))
-> ([Options], [Options], [Options])
-> [Options]
-> ([Options], [Options], [Options])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' ([Options], [Options], [Options])
-> Options -> ([Options], [Options], [Options])
f ([], [], []) [Options]
options

    optionsSummary :: [Options] -> Doc ann
    optionsSummary :: [Options] -> Doc ann
optionsSummary [Options]
os = if [Options] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Options]
os Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Doc ann
forall ann. Doc ann
softline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"[OPTIONS]" else Doc ann
forall ann. Doc ann
emptyDoc

    optionsHeading :: t a -> Doc ann
optionsHeading t a
os = if t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
os Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Doc ann
forall ann. Doc ann
hardline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"Available options:" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
hardline else Doc ann
forall ann. Doc ann
emptyDoc

    globalSummary :: t a -> Doc ann
globalSummary t a
os = if t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
os Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Doc ann
forall ann. Doc ann
softline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"[GLOBAL OPTIONS]" else Doc ann
forall ann. Doc ann
emptyDoc
    globalHeading :: t a -> Doc ann
globalHeading t a
os =
        if t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
os Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
            then Doc ann
forall ann. Doc ann
hardline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"Global options:" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
hardline
            else Doc ann
forall ann. Doc ann
emptyDoc

    localSummary :: t a -> Doc ann
localSummary t a
os = if t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
os Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Doc ann
forall ann. Doc ann
softline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"[LOCAL OPTIONS]" else Doc ann
forall ann. Doc ann
emptyDoc
    localHeading :: t a -> Doc ann
localHeading t a
os =
        if t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
os Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
            then Doc ann
forall ann. Doc ann
hardline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"Options to the '" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
commandName Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"' command:" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
hardline
            else Doc ann
forall ann. Doc ann
emptyDoc

    commandName :: Doc ann
    commandName :: Doc ann
commandName = case Maybe LongName
mode of
        Just (LongName String
name) -> String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
name
        Maybe LongName
Nothing -> Doc ann
"COMMAND..."

    argumentsSummary :: [Options] -> Doc ann
    argumentsSummary :: [Options] -> Doc ann
argumentsSummary [Options]
as = Doc ann
" " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
fillSep ((LongName -> Doc ann) -> [LongName] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\LongName
x -> Doc ann
"<" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> LongName -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty LongName
x Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
">") ([Options] -> [LongName]
extractRequiredArguments [Options]
as))

    argumentsHeading :: t a -> Doc ann
argumentsHeading t a
as = if t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
as Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Doc ann
forall ann. Doc ann
hardline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"Required arguments:" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
hardline else Doc ann
forall ann. Doc ann
emptyDoc

    variablesHeading :: t a -> Doc ann
variablesHeading t a
vs = if t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
vs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Doc ann
forall ann. Doc ann
hardline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"Known environment variables:" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
hardline else Doc ann
forall ann. Doc ann
emptyDoc

    remainingSummary :: [Options] -> Doc ann
    remainingSummary :: [Options] -> Doc ann
remainingSummary [Options]
as = if [Options] -> Bool
hasRemaining [Options]
as then Doc ann
" ..." else Doc ann
forall ann. Doc ann
emptyDoc

    -- there is a corner case of complex config with no commands
    commandSummary :: t a -> Doc ann
commandSummary t a
modes = if t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
modes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Doc ann
forall ann. Doc ann
softline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
commandName else Doc ann
forall ann. Doc ann
emptyDoc
    commandHeading :: t a -> Doc ann
commandHeading t a
modes = if t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
modes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Doc ann
forall ann. Doc ann
hardline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"Available commands:" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
hardline else Doc ann
forall ann. Doc ann
emptyDoc

    f :: ([Options], [Options], [Options]) -> Options -> ([Options], [Options], [Options])
    f :: ([Options], [Options], [Options])
-> Options -> ([Options], [Options], [Options])
f ([Options]
opts, [Options]
args, [Options]
vars) o :: Options
o@(Option LongName
_ Maybe ShortName
_ ParameterValue
_ Rope
_) = (Options
o Options -> [Options] -> [Options]
forall a. a -> [a] -> [a]
: [Options]
opts, [Options]
args, [Options]
vars)
    f ([Options]
opts, [Options]
args, [Options]
vars) a :: Options
a@(Argument LongName
_ Rope
_) = ([Options]
opts, Options
a Options -> [Options] -> [Options]
forall a. a -> [a] -> [a]
: [Options]
args, [Options]
vars)
    f ([Options]
opts, [Options]
args, [Options]
vars) a :: Options
a@(Remaining Rope
_) = ([Options]
opts, Options
a Options -> [Options] -> [Options]
forall a. a -> [a] -> [a]
: [Options]
args, [Options]
vars)
    f ([Options]
opts, [Options]
args, [Options]
vars) v :: Options
v@(Variable LongName
_ Rope
_) = ([Options]
opts, [Options]
args, Options
v Options -> [Options] -> [Options]
forall a. a -> [a] -> [a]
: [Options]
vars)

    formatParameters :: [Options] -> Doc ann
    formatParameters :: [Options] -> Doc ann
formatParameters [] = Doc ann
forall ann. Doc ann
emptyDoc
    formatParameters [Options]
options = Doc ann
forall ann. Doc ann
hardline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> (Doc ann -> Options -> Doc ann) -> Doc ann -> [Options] -> Doc ann
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Doc ann -> Options -> Doc ann
forall ann. Doc ann -> Options -> Doc ann
g Doc ann
forall ann. Doc ann
emptyDoc [Options]
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 :: Doc ann -> Options -> Doc ann
    g :: Doc ann -> Options -> Doc ann
g Doc ann
acc (Option LongName
longname Maybe ShortName
shortname ParameterValue
valued Rope
description) =
        let s :: Doc ann
s = case Maybe ShortName
shortname of
                Just ShortName
shortchar -> Doc ann
"  -" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> ShortName -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ShortName
shortchar Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
", --"
                Maybe ShortName
Nothing -> Doc ann
"      --"
            l :: Doc ann
l = LongName -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty LongName
longname
            d :: Text
d = Rope -> Text
forall α. Textual α => Rope -> α
fromRope Rope
description
         in case ParameterValue
valued of
                ParameterValue
Empty ->
                    Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
fillBreak Int
16 (Doc ann
forall ann. Doc ann
s Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
l Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
" ") Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align (Text -> Doc ann
forall ann. Text -> Doc ann
reflow Text
d) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
hardline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
acc
                Value String
label ->
                    Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
fillBreak Int
16 (Doc ann
forall ann. Doc ann
s Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
l Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"=<" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
label Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"> ") Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align (Text -> Doc ann
forall ann. Text -> Doc ann
reflow Text
d) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
hardline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
acc
    g Doc ann
acc (Argument LongName
longname Rope
description) =
        let l :: Doc ann
l = LongName -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty LongName
longname
            d :: Text
d = Rope -> Text
forall α. Textual α => Rope -> α
fromRope Rope
description
         in Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
fillBreak Int
16 (Doc ann
"  <" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
l Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"> ") Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align (Text -> Doc ann
forall ann. Text -> Doc ann
reflow Text
d) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
hardline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
acc
    g Doc ann
acc (Remaining Rope
description) =
        let d :: Text
d = Rope -> Text
forall α. Textual α => Rope -> α
fromRope Rope
description
         in Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
fillBreak Int
16 (Doc ann
"  " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"... ") Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align (Text -> Doc ann
forall ann. Text -> Doc ann
reflow Text
d) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
hardline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
acc
    g Doc ann
acc (Variable LongName
longname Rope
description) =
        let l :: Doc ann
l = LongName -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty LongName
longname
            d :: Text
d = Rope -> Text
forall α. Textual α => Rope -> α
fromRope Rope
description
         in Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
fillBreak Int
16 (Doc ann
"  " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
l Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
" ") Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align (Text -> Doc ann
forall ann. Text -> Doc ann
reflow Text
d) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
hardline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
acc

    formatCommands :: [Commands] -> Doc ann
    formatCommands :: [Commands] -> Doc ann
formatCommands [Commands]
commands = Doc ann
forall ann. Doc ann
hardline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> (Doc ann -> Commands -> Doc ann)
-> Doc ann -> [Commands] -> Doc ann
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Doc ann -> Commands -> Doc ann
forall ann. Doc ann -> Commands -> Doc ann
h Doc ann
forall ann. Doc ann
emptyDoc [Commands]
commands

    h :: Doc ann -> Commands -> Doc ann
    h :: Doc ann -> Commands -> Doc ann
h Doc ann
acc (Command LongName
longname Rope
description [Options]
_) =
        let l :: Doc ann
l = LongName -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty LongName
longname
            d :: Text
d = Rope -> Text
forall α. Textual α => Rope -> α
fromRope Rope
description
         in Doc ann
acc Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
fillBreak Int
16 (Doc ann
"  " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
l Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
" ") Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align (Text -> Doc ann
forall ann. Text -> Doc ann
reflow Text
d) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
hardline
    h Doc ann
acc Commands
_ = Doc ann
acc

buildVersion :: Version -> Doc ann
buildVersion :: Version -> Doc ann
buildVersion Version
version =
    String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Version -> String
projectNameFrom Version
version)
        Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"v"
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Version -> String
versionNumberFrom Version
version)
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
hardline