{-# 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
    , simpleConfig'
    , complexConfig
    , 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 -> [ShortName]
forall a.
(Int -> a -> ShowS)
-> (a -> [ShortName]) -> ([a] -> ShowS) -> Show a
showList :: [LongName] -> ShowS
$cshowList :: [LongName] -> ShowS
show :: LongName -> [ShortName]
$cshow :: LongName -> [ShortName]
showsPrec :: Int -> LongName -> ShowS
$cshowsPrec :: Int -> LongName -> ShowS
Show, [ShortName] -> LongName
forall a. ([ShortName] -> a) -> IsString a
fromString :: [ShortName] -> LongName
$cfromString :: [ShortName] -> LongName
IsString, LongName -> LongName -> Bool
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
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
Hashable, Eq 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
Ord)

instance Key LongName

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

instance Textual LongName where
    intoRope :: LongName -> Description
intoRope (LongName [ShortName]
str) = forall α. Textual α => α -> Description
intoRope [ShortName]
str
    fromRope :: Description -> LongName
fromRope = [ShortName] -> LongName
LongName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall α. Textual α => Description -> α
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 Description [Options]
    | Complex Description [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 = Description -> [Options] -> Config
Simple Description
emptyRope ([Options]
options forall a. [a] -> [a] -> [a]
++ [Options]
baselineOptions)

{- |
Declare a simple configuration as with 'simpleConfig', along with a
descriptive precis that will be printed at the top of the @--help@ output.


@
\$ __./snippet --help__
A small but very useful program.

Usage:

    snippet [OPTIONS] <filename>
...
@

@since 0.6.5
-}
simpleConfig' :: Description -> [Options] -> Config
simpleConfig' :: Description -> [Options] -> Config
simpleConfig' Description
description [Options]
options = Description -> [Options] -> Config
Simple Description
description ([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 = Description -> [Commands] -> Config
Complex Description
emptyRope ([Commands]
commands forall a. [a] -> [a] -> [a]
++ [[Options] -> Commands
Global [Options]
baselineOptions])

{- |
Declare a complex configuration as with 'complexConfig', along with a
descriptive precis that will be printed at the top of the @--help@ output when
requesting help for the program as a whole.

If help is requested for one of the sub commands, the description from the
'Command' constructor will be used at the top of the output.

@since 0.6.5
-}
complexConfig' :: Description -> [Commands] -> Config
complexConfig' :: Description -> [Commands] -> Config
complexConfig' Description
precis [Commands]
commands = Description -> [Commands] -> Config
Complex Description
precis ([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.\"
        , ...
        ]
@

Finally, there is a 'Descriptive' constructor which allows you to put a piece
of header text as a descriptive summary in help output before it starts
enumerating the options and arguments.

@
        [ 'Descriptive' \"A program to evaluate just how crazy you are.\"
        , ...
        ]
@
-}
data Options
    = Option LongName (Maybe ShortName) ParameterValue Description
    | Argument LongName Description
    | Remaining Description
    | Variable LongName Description
    deriving (Int -> Options -> ShowS
[Options] -> ShowS
Options -> [ShortName]
forall a.
(Int -> a -> ShowS)
-> (a -> [ShortName]) -> ([a] -> ShowS) -> Show a
showList :: [Options] -> ShowS
$cshowList :: [Options] -> ShowS
show :: Options -> [ShortName]
$cshow :: Options -> [ShortName]
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 Description
precis [Options]
options -> Description -> [Options] -> Config
Simple Description
precis ([Options]
options forall a. [a] -> [a] -> [a]
++ [Options
option])
        Complex Description
precis [Commands]
commands -> Description -> [Commands] -> Config
Complex Description
precis ([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 -> [ShortName]
forall a.
(Int -> a -> ShowS)
-> (a -> [ShortName]) -> ([a] -> ShowS) -> Show a
showList :: [ParameterValue] -> ShowS
$cshowList :: [ParameterValue] -> ShowS
show :: ParameterValue -> [ShortName]
$cshow :: ParameterValue -> [ShortName]
showsPrec :: Int -> ParameterValue -> ShowS
$cshowsPrec :: Int -> ParameterValue -> ShowS
Show, ParameterValue -> ParameterValue -> Bool
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 :: [ShortName] -> ParameterValue
fromString [ShortName]
x = [ShortName] -> ParameterValue
Value [ShortName]
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 -> [[ShortName]]
remainingArgumentsFrom :: [String]
    , Parameters -> Map LongName ParameterValue
environmentValuesFrom :: Map LongName ParameterValue
    }
    deriving (Int -> Parameters -> ShowS
[Parameters] -> ShowS
Parameters -> [ShortName]
forall a.
(Int -> a -> ShowS)
-> (a -> [ShortName]) -> ([a] -> ShowS) -> Show a
showList :: [Parameters] -> ShowS
$cshowList :: [Parameters] -> ShowS
show :: Parameters -> [ShortName]
$cshow :: Parameters -> [ShortName]
showsPrec :: Int -> Parameters -> ShowS
$cshowsPrec :: Int -> Parameters -> ShowS
Show, Parameters -> Parameters -> Bool
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
        { commandNameFrom :: Maybe LongName
commandNameFrom = forall a. Maybe a
Nothing
        , parameterValuesFrom :: Map LongName ParameterValue
parameterValuesFrom = forall κ ν. Map κ ν
emptyMap
        , remainingArgumentsFrom :: [[ShortName]]
remainingArgumentsFrom = []
        , environmentValuesFrom :: Map LongName ParameterValue
environmentValuesFrom = forall κ ν. Map κ ν
emptyMap
        }

baselineOptions :: [Options]
baselineOptions :: [Options]
baselineOptions =
    [ LongName
-> Maybe ShortName -> ParameterValue -> Description -> Options
Option
        LongName
"verbose"
        (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 -> Description -> Options
Option
        LongName
"debug"
        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 -> [ShortName]
forall a.
(Int -> a -> ShowS)
-> (a -> [ShortName]) -> ([a] -> ShowS) -> Show a
showList :: [InvalidCommandLine] -> ShowS
$cshowList :: [InvalidCommandLine] -> ShowS
show :: InvalidCommandLine -> [ShortName]
$cshow :: InvalidCommandLine -> [ShortName]
showsPrec :: Int -> InvalidCommandLine -> ShowS
$cshowsPrec :: Int -> InvalidCommandLine -> ShowS
Show, InvalidCommandLine -> InvalidCommandLine -> Bool
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 -> [ShortName]
displayException InvalidCommandLine
e = case InvalidCommandLine
e of
        InvalidOption [ShortName]
arg ->
            let one :: [ShortName]
one = [ShortName]
"Option '" forall a. [a] -> [a] -> [a]
++ [ShortName]
arg forall a. [a] -> [a] -> [a]
++ [ShortName]
"' illegal.\n\n"
                two :: [ShortName]
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  [ShortName]
one forall a. [a] -> [a] -> [a]
++ [ShortName]
two
        UnknownOption [ShortName]
name -> [ShortName]
"Sorry, option '" forall a. [a] -> [a] -> [a]
++ [ShortName]
name forall a. [a] -> [a] -> [a]
++ [ShortName]
"' not recognized."
        MissingArgument (LongName [ShortName]
name) -> [ShortName]
"Mandatory argument '" forall a. [a] -> [a] -> [a]
++ [ShortName]
name forall a. [a] -> [a] -> [a]
++ [ShortName]
"' missing."
        UnexpectedArguments [[ShortName]]
args ->
            let quoted :: [ShortName]
quoted = forall a. [a] -> [[a]] -> [a]
List.intercalate [ShortName]
"', '" [[ShortName]]
args
            in  [quote|
Unexpected trailing arguments:

|]
                    forall a. [a] -> [a] -> [a]
++ [ShortName]
quoted
                    forall a. [a] -> [a] -> [a]
++ [quote|

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

    |]
                forall a. [a] -> [a] -> [a]
++ [ShortName]
programName
                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
_ -> [ShortName]
""
        -- handled by parent module calling back into here buildVersion
        InvalidCommandLine
VersionRequest -> [ShortName]
""

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

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

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

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

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

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

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

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

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

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

extractValidNames :: [Options] -> Set LongName
extractValidNames :: [Options] -> Set LongName
extractValidNames [Options]
options =
    forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Options -> Set LongName -> Set LongName
f 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
_ Description
_) Set LongName
valids = 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 =
    forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Options -> Map ShortName LongName -> Map ShortName LongName
g 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
_ Description
_) Map ShortName LongName
shorts = case Maybe ShortName
shortname of
        Just ShortName
shortchar -> 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 =
    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 Description
_) [LongName]
needed = LongName
longname forall a. a -> [a] -> [a]
: [LongName]
needed
    h Options
_ [LongName]
needed = [LongName]
needed

extractGlobalOptions :: [Commands] -> [Options]
extractGlobalOptions :: [Commands] -> [Options]
extractGlobalOptions [Commands]
commands =
    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 forall a. [a] -> [a] -> [a]
++ [Options]
valids
    j Commands
_ [Options]
valids = [Options]
valids

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

splitCommandLine2 :: [String] -> Either InvalidCommandLine (String, [String])
splitCommandLine2 :: [[ShortName]]
-> Either InvalidCommandLine ([ShortName], [[ShortName]])
splitCommandLine2 [[ShortName]]
argv' =
    let x :: Maybe ([ShortName], [[ShortName]])
x = forall a. [a] -> Maybe (a, [a])
List.uncons [[ShortName]]
argv'
    in  case Maybe ([ShortName], [[ShortName]])
x of
            Just ([ShortName]
mode, [[ShortName]]
remainingArgs) -> forall a b. b -> Either a b
Right ([ShortName]
mode, [[ShortName]]
remainingArgs)
            Maybe ([ShortName], [[ShortName]])
Nothing -> 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 -> forall ε. Key ε => Set ε
emptySet
    Simple Description
_ [Options]
options -> [Options] -> Set LongName
extractVariableNames [Options]
options
    Complex Description
_ [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 (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 forall a. Semigroup a => a -> a -> a
<> Set LongName
variables2

extractLocalVariables :: [Commands] -> LongName -> [Options]
extractLocalVariables :: [Commands] -> LongName -> [Options]
extractLocalVariables [Commands]
commands LongName
mode =
    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 Description
_ [Options]
options) [Options]
acc = if LongName
name 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 =
    forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Options -> Set LongName -> Set LongName
f forall ε. Key ε => Set ε
emptySet [Options]
options
  where
    f :: Options -> Set LongName -> Set LongName
    f :: Options -> Set LongName -> Set LongName
f (Variable LongName
longname Description
_) Set LongName
valids = 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 :: forall ann. Config -> Maybe LongName -> Doc ann
buildUsage Config
config Maybe LongName
mode = case Config
config of
    Config
Blank -> forall ann. Doc ann
emptyDoc
    Simple Description
precis [Options]
options ->
        let ([Options]
o, [Options]
a, [Options]
v) = [Options] -> ([Options], [Options], [Options])
partitionParameters [Options]
options
        in  forall ann. Description -> Doc ann
formatPrecis Description
precis
                forall a. Semigroup a => a -> a -> a
<> Doc ann
"Usage:"
                forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
hardline
                forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
hardline
                forall a. Semigroup a => a -> a -> a
<> forall ann. Int -> Doc ann -> Doc ann
indent
                    Int
4
                    ( forall ann. Int -> Doc ann -> Doc ann
nest
                        Int
4
                        ( forall ann. [Doc ann] -> Doc ann
fillCat
                            [ forall a ann. Pretty a => a -> Doc ann
pretty [ShortName]
programName
                            , forall ann. [Options] -> Doc ann
optionsSummary [Options]
o
                            , forall ann. [Options] -> Doc ann
argumentsSummary [Options]
a
                            , forall ann. [Options] -> Doc ann
remainingSummary [Options]
a
                            ]
                        )
                    )
                forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
hardline
                forall a. Semigroup a => a -> a -> a
<> forall {t :: * -> *} {a} {ann}. Foldable t => t a -> Doc ann
optionsHeading [Options]
o
                forall a. Semigroup a => a -> a -> a
<> forall ann. [Options] -> Doc ann
formatParameters [Options]
o
                forall a. Semigroup a => a -> a -> a
<> forall {t :: * -> *} {a} {ann}. Foldable t => t a -> Doc ann
argumentsHeading [Options]
a
                forall a. Semigroup a => a -> a -> a
<> forall ann. [Options] -> Doc ann
formatParameters [Options]
a
                forall a. Semigroup a => a -> a -> a
<> forall {t :: * -> *} {a} {ann}. Foldable t => t a -> Doc ann
variablesHeading [Options]
v
                forall a. Semigroup a => a -> a -> a
<> forall ann. [Options] -> Doc ann
formatParameters [Options]
v
    Complex Description
precis [Commands]
commands ->
        let globalOptions :: [Options]
globalOptions = [Commands] -> [Options]
extractGlobalOptions [Commands]
commands
            modes :: Map LongName (Description, [Options])
modes = [Commands] -> Map LongName (Description, [Options])
extractValidModes [Commands]
commands

            ([Options]
oG, [Options]
_, [Options]
vG) = [Options] -> ([Options], [Options], [Options])
partitionParameters [Options]
globalOptions
        in  case Maybe LongName
mode of
                Maybe LongName
Nothing ->
                    forall ann. Description -> Doc ann
formatPrecis Description
precis
                        forall a. Semigroup a => a -> a -> a
<> Doc ann
"Usage:"
                        forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
hardline
                        forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
hardline
                        forall a. Semigroup a => a -> a -> a
<> forall ann. Int -> Doc ann -> Doc ann
indent
                            Int
2
                            ( forall ann. Int -> Doc ann -> Doc ann
nest
                                Int
4
                                ( forall ann. [Doc ann] -> Doc ann
fillCat
                                    [ forall a ann. Pretty a => a -> Doc ann
pretty [ShortName]
programName
                                    , forall {t :: * -> *} {a} {ann}. Foldable t => t a -> Doc ann
globalSummary [Options]
oG
                                    , forall {t :: * -> *} {a} {ann}. Foldable t => t a -> Doc ann
commandSummary Map LongName (Description, [Options])
modes
                                    ]
                                )
                            )
                        forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
hardline
                        forall a. Semigroup a => a -> a -> a
<> forall {t :: * -> *} {a} {ann}. Foldable t => t a -> Doc ann
globalHeading [Options]
oG
                        forall a. Semigroup a => a -> a -> a
<> forall ann. [Options] -> Doc ann
formatParameters [Options]
oG
                        forall a. Semigroup a => a -> a -> a
<> forall {t :: * -> *} {a} {ann}. Foldable t => t a -> Doc ann
commandHeading Map LongName (Description, [Options])
modes
                        forall a. Semigroup a => a -> a -> a
<> forall ann. [Commands] -> Doc ann
formatCommands [Commands]
commands
                        forall a. Semigroup a => a -> a -> a
<> forall {t :: * -> *} {a} {ann}. Foldable t => t a -> Doc ann
variablesHeading [Options]
vG
                        forall a. Semigroup a => a -> a -> a
<> forall ann. [Options] -> Doc ann
formatParameters [Options]
vG
                Just LongName
longname ->
                    let (Description
dL, ([Options]
oL, [Options]
aL, [Options]
vL)) = case forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue LongName
longname Map LongName (Description, [Options])
modes of
                            Just (Description
description, [Options]
localOptions) -> (Description
description, [Options] -> ([Options], [Options], [Options])
partitionParameters [Options]
localOptions)
                            Maybe (Description, [Options])
Nothing -> forall a. HasCallStack => [ShortName] -> a
error [ShortName]
"Illegal State"
                    in  forall ann. Description -> Doc ann
formatPrecis Description
dL
                            forall a. Semigroup a => a -> a -> a
<> Doc ann
"Usage:"
                            forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
hardline
                            forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
hardline
                            forall a. Semigroup a => a -> a -> a
<> forall ann. Int -> Doc ann -> Doc ann
indent
                                Int
2
                                ( forall ann. Int -> Doc ann -> Doc ann
nest
                                    Int
4
                                    ( forall ann. [Doc ann] -> Doc ann
fillCat
                                        [ forall a ann. Pretty a => a -> Doc ann
pretty [ShortName]
programName
                                        , forall {t :: * -> *} {a} {ann}. Foldable t => t a -> Doc ann
globalSummary [Options]
oG
                                        , forall {t :: * -> *} {a} {ann}. Foldable t => t a -> Doc ann
commandSummary Map LongName (Description, [Options])
modes
                                        , forall {t :: * -> *} {a} {ann}. Foldable t => t a -> Doc ann
localSummary [Options]
oL
                                        , forall ann. [Options] -> Doc ann
argumentsSummary [Options]
aL
                                        , forall ann. [Options] -> Doc ann
remainingSummary [Options]
aL
                                        ]
                                    )
                                )
                            forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
hardline
                            forall a. Semigroup a => a -> a -> a
<> forall {t :: * -> *} {a} {ann}. Foldable t => t a -> Doc ann
localHeading [Options]
oL
                            forall a. Semigroup a => a -> a -> a
<> forall ann. [Options] -> Doc ann
formatParameters [Options]
oL
                            forall a. Semigroup a => a -> a -> a
<> forall {t :: * -> *} {a} {ann}. Foldable t => t a -> Doc ann
argumentsHeading [Options]
aL
                            forall a. Semigroup a => a -> a -> a
<> forall ann. [Options] -> Doc ann
formatParameters [Options]
aL
                            forall a. Semigroup a => a -> a -> a
<> forall {t :: * -> *} {a} {ann}. Foldable t => t a -> Doc ann
variablesHeading [Options]
vL
                            forall a. Semigroup a => a -> a -> a
<> forall ann. [Options] -> Doc ann
formatParameters [Options]
vL
  where
    formatPrecis :: Description -> Doc ann
    formatPrecis :: forall ann. Description -> Doc ann
formatPrecis Description
precis = case Description -> Int
widthRope Description
precis of
        Int
0 -> forall ann. Doc ann
emptyDoc
        Int
_ -> forall ann. Text -> Doc ann
reflow (forall α. Textual α => Description -> α
fromRope Description
precis) forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
hardline forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
hardline

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

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

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

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

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

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

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

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

    remainingSummary :: [Options] -> Doc ann
    remainingSummary :: forall ann. [Options] -> Doc ann
remainingSummary [Options]
as = if [Options] -> Bool
hasRemaining [Options]
as then Doc ann
" ..." else 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 forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
modes forall a. Ord a => a -> a -> Bool
> Int
0 then forall ann. Doc ann
softline forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
commandName else forall ann. Doc ann
emptyDoc
    commandHeading :: t a -> Doc ann
commandHeading t a
modes = if forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
modes forall a. Ord a => a -> a -> Bool
> Int
0 then forall ann. Doc ann
hardline forall a. Semigroup a => a -> a -> a
<> Doc ann
"Available commands:" forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
hardline else 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
_ Description
_) = (Options
o forall a. a -> [a] -> [a]
: [Options]
opts, [Options]
args, [Options]
vars)
    f ([Options]
opts, [Options]
args, [Options]
vars) a :: Options
a@(Argument LongName
_ Description
_) = ([Options]
opts, Options
a forall a. a -> [a] -> [a]
: [Options]
args, [Options]
vars)
    f ([Options]
opts, [Options]
args, [Options]
vars) a :: Options
a@(Remaining Description
_) = ([Options]
opts, Options
a forall a. a -> [a] -> [a]
: [Options]
args, [Options]
vars)
    f ([Options]
opts, [Options]
args, [Options]
vars) v :: Options
v@(Variable LongName
_ Description
_) = ([Options]
opts, [Options]
args, Options
v forall a. a -> [a] -> [a]
: [Options]
vars)

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

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

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

buildVersion :: Version -> Doc ann
buildVersion :: forall ann. Version -> Doc ann
buildVersion Version
version =
    let
        project :: [ShortName]
project = Version -> [ShortName]
projectNameFrom Version
version
        number :: [ShortName]
number = Version -> [ShortName]
versionNumberFrom Version
version
        description :: [ShortName]
description = Version -> [ShortName]
gitDescriptionFrom Version
version
    in
        forall a ann. Pretty a => a -> Doc ann
pretty [ShortName]
project
            forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty [ShortName]
number
                forall a. Semigroup a => a -> a -> a
<> if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ShortName]
description
                    then forall ann. Doc ann
hardline
                    else Doc ann
"," forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty [ShortName]
description forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
hardline