{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE StrictData #-}
{-# OPTIONS_HADDOCK prune #-}

-- |
-- Invoking a command-line program (be it tool or daemon) consists of listing
-- the name of its binary, optionally supplying various options to adjust the
-- behaviour of the program, and then supplying mandatory arguments, if any
-- are specified.
--
-- On startup, we parse any arguments passed in from the shell into
-- @name,value@ pairs and incorporated into the resultant configuration stored
-- in the program's Context.
--
-- Additionally, this module allows you to specify environment variables that,
-- if present, will be incorporated into the stored configuration.
module Core.Program.Arguments
  ( -- * Setup
    Config,
    blank,
    simple,
    complex,
    baselineOptions,
    Parameters (..),
    ParameterValue (..),

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

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

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

import Core.Data.Structures
import Core.Program.Metadata
import Core.System.Base
import Core.Text.Rope
import Core.Text.Utilities
import Data.Hashable (Hashable)
import qualified Data.List as List
import Data.Maybe (fromMaybe)
import Data.String
import Data.Text.Prettyprint.Doc
  ( Doc,
    Pretty (..),
    align,
    emptyDoc,
    fillBreak,
    fillCat,
    fillSep,
    hardline,
    indent,
    nest,
    softline,
    (<+>),
  )
import Data.Text.Prettyprint.Doc.Util (reflow)
import System.Environment (getProgName)

-- |
-- Single letter "short" options (omitting the "@-@" prefix, obviously).
type ShortName = Char

-- |
-- The description of an option, command, or environment variable (for use
-- when rendering usage information in response to @--help@ on the
-- command-line).
type Description = Rope

-- |
-- The name of an option, command, or agument (omitting the "@--@" prefix in
-- the case of options). This identifier will be used to generate usage text
-- in response to @--help@ and by you later when retreiving the values of the
-- supplied parameters after the program has initialized.
--
-- Turn on __@OverloadedStrings@__ when specifying configurations, obviously.
newtype LongName = LongName String
  deriving (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, Int -> LongName -> Int
LongName -> Int
(Int -> LongName -> Int) -> (LongName -> Int) -> Hashable LongName
forall 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
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 'simple' or 'complex', and pass it to
-- 'Core.Program.Context.configure'.
data Config
  = Blank
  | Simple [Options]
  | Complex [Commands]

--
-- Those constructors are not exposed [and functions wrapping them are] partly
-- for documentation convenience, partly for aesthetics (after a point too many
-- constructors got a bit hard to differentiate betwen), and mostly so that if
-- configure's argument turns into a monad like RequestBuilder we have
-- somewhere to make that change.
--

-- |
-- A completely empty configuration, without the default debugging and logging
-- options. Your program won't process any command-line options or arguments,
-- which would be weird in most cases. Prefer 'simple'.
blank :: Config
blank :: Config
blank = 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' ('simple'
--         [ 'Option' "host" ('Just' \'h\') 'Empty' ['quote'|
--             Specify an alternate host to connect to when performing the
--             frobnication. The default is \"localhost\".
--           |]
--         , 'Option' "port" ('Just' \'p\') 'Empty' ['quote'|
--             Specify an alternate port to connect to when frobnicating.
--           |]
--         , 'Option' "dry-run" 'Nothing' ('Value' \"TIME\") ['quote'|
--             Perform a trial run at the specified time but don't actually
--             do anything.
--           |]
--         , 'Option' "quiet" ('Just' \'q\') 'Empty' ['quote'|
--             Supress normal output.
--           |]
--         , 'Argument' "filename" ['quote'|
--             The file you want to frobnicate.
--           |]
--         ])
--
--     'Core.Program.Execute.executeWith' context program
-- @
--
-- which, if you build that into an executable called @snippet@ and invoke it
-- with @--help@, would result in:
--
-- @
-- \$ __./snippet --help__
-- Usage:
--
--     snippet [OPTIONS] filename
--
-- Available options:
--
--   -h, --host     Specify an alternate host to connect to when performing the
--                  frobnication. The default is \"localhost\".
--   -p, --port     Specify an alternate port to connect to when frobnicating.
--       --dry-run=TIME
--                  Perform a trial run at the specified time but don't
--                  actually do anything.
--   -q, --quiet    Supress normal output.
--   -v, --verbose  Turn on event tracing. By default the logging stream will go
--                  to standard output on your terminal.
--       --debug    Turn on debug level logging. Implies --verbose.
--
-- Required arguments:
--
--   filename       The file you want to frobnicate.
-- \$ __|__
-- @
--
-- For information on how to use the multi-line string literals shown here,
-- see 'quote' in "Core.Text.Utilities".
simple :: [Options] -> Config
simple :: [Options] -> Config
simple [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' ('complex'
--         [ 'Global'
--             [ 'Option' "station-name" 'Nothing' ('Value' \"NAME\") ['quote'|
--                 Specify an alternate radio station to connect to when performing
--                 actions. The default is \"BBC Radio 1\".
--               |]
--             , 'Variable' \"PLAYER_FORCE_HEADPHONES\" ['quote'|
--                 If set to @1@, override the audio subsystem to force output
--                 to go to the user's headphone jack.
--               |]
--             ]
--         , 'Command' \"play\" \"Play the music.\"
--             [ 'Option' "repeat" 'Nothing' 'Empty' ['quote'|
--                 Request that they play the same song over and over and over
--                 again, simulating the effect of listening to a Top 40 radio
--                 station.
--               |]
--             ]
--         , 'Command' \"rate\" \"Vote on whether you like the song or not.\"
--             [ 'Option' "academic" 'Nothing' 'Empty' ['quote'|
--                 The rating you wish to apply, from A+ to F. This is the
--                 default, so there is no reason whatsoever to specify this.
--                 But some people are obsessive, compulsive, and have time on
--                 their hands.
--               |]
--             , 'Option' "numeric" 'Nothing' 'Empty' ['quote'|
--                 Specify a score as a number from 0 to 100 instead of an
--                 academic style letter grade. Note that negative values are
--                 not valid scores, despite how vicerally satisfying that
--                 would be for music produced in the 1970s.
--               |]
--             , 'Option' "unicode" ('Just' \'c\') 'Empty' ['quote'|
--                 Instead of a score, indicate your rating with a single
--                 character.  This allows you to use emoji, so that you can
--                 rate a piece \'💩\', as so many songs deserve.
--               |]
--             , 'Argument' "score" ['quote'|
--                 The rating you wish to apply.
--               |]
--             ]
--         ])
--
--     'Core.Program.Execute.executeWith' context program
-- @
--
-- is a program with one global option (in addition to the default ones) [and
-- an environment variable] and two commands: @play@, with one option; and
-- @rate@, with two options and a required argument. It also is set up to
-- carry its top-level application state around in a type called
-- @MusicAppStatus@ (implementing 'Monoid' and so initialized here with
-- 'mempty'. This is a good pattern to use given we are so early in the
-- program's lifetime).
--
-- The resultant program could be invoked as in these examples:
--
-- @
-- \$ __./player --station-name=\"KBBL-FM 102.5\" play__
-- \$
-- @
--
-- @
-- \$ __./player -v rate --numeric 76__
-- \$
-- @
--
-- For information on how to use the multi-line string literals shown here,
-- see 'quote' in "Core.Text.Utilities".
complex :: [Commands] -> Config
complex :: [Commands] -> Config
complex [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.
--
-- 'Variable' declares an /environment variable/ that, if present, will be
-- read by the program and stored in its runtime context. By convention these
-- are /upper case/. If the identifier is two or more words they are joined
-- with an underscore:
--
-- @
--         [ ...
--         , 'Variable' \"CRAZY_MODE\" "Specify how many crazies to activate."
--         , ...
--         ]
-- @
data Options
  = Option LongName (Maybe ShortName) ParameterValue Description
  | Argument LongName Description
  | Variable LongName Description

-- |
-- Individual parameters read in off the command-line can either have a value
-- (in the case of arguments and options taking a value) or be empty (in the
-- case of options that are just flags).
data ParameterValue
  = Value String
  | Empty
  deriving (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 -> 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)

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 event tracing. By default the logging stream will go to
        standard output on your terminal.
    |],
    LongName -> Maybe ShortName -> ParameterValue -> Rope -> Options
Option
      LongName
"debug"
      Maybe ShortName
forall a. Maybe a
Nothing
      ParameterValue
Empty
      [quote|
        Turn on debug level logging. Implies --verbose.
    |]
  ]

-- |
-- Different ways parsing a simple or complex command-line can fail.
data InvalidCommandLine
  = -- | Something was wrong with the way the user specified [usually a short] option.
    InvalidOption String
  | -- | User specified an option that doesn't match any in the supplied configuration.
    UnknownOption String
  | -- | Arguments are mandatory, and this one is missing.
    MissingArgument LongName
  | -- | Arguments are present we weren't expecting.
    UnexpectedArguments [String]
  | -- | In a complex configuration, user specified a command that doesn't match any in the configuration.
    UnknownCommand String
  | -- | In a complex configuration, user didn't specify a command.
    NoCommandFound
  | -- | In a complex configuration, usage information was requested with @--help@, either globally or for the supplied command.
    HelpRequest (Maybe LongName)
  | -- | Display of the program version requested with @--version@.
    VersionRequest
  deriving (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 '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
-> 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 <- Maybe LongName
-> [Options]
-> [String]
-> Either InvalidCommandLine (Map LongName ParameterValue)
extractor Maybe LongName
forall a. Maybe a
Nothing [Options]
options [String]
argv
    Parameters -> Either InvalidCommandLine Parameters
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe LongName
-> Map LongName ParameterValue
-> Map LongName ParameterValue
-> Parameters
Parameters Maybe LongName
forall a. Maybe a
Nothing Map LongName ParameterValue
params 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 <- Maybe LongName
-> [Options]
-> [String]
-> Either InvalidCommandLine (Map LongName ParameterValue)
extractor Maybe LongName
forall a. Maybe a
Nothing [Options]
globalOptions [String]
possibles
          (String
first, [String]
remainingArgs) <- [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 <- Maybe LongName
-> [Options]
-> [String]
-> Either InvalidCommandLine (Map LongName ParameterValue)
extractor (LongName -> Maybe LongName
forall a. a -> Maybe a
Just LongName
mode) [Options]
localOptions [String]
remainingArgs
          Parameters -> Either InvalidCommandLine Parameters
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe LongName
-> Map LongName ParameterValue
-> 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) Map LongName ParameterValue
forall κ ν. Map κ ν
emptyMap)
  where
    extractor :: Maybe LongName -> [Options] -> [String] -> Either InvalidCommandLine (Map LongName ParameterValue)
    extractor :: Maybe LongName
-> [Options]
-> [String]
-> Either InvalidCommandLine (Map LongName ParameterValue)
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 <- [LongName]
-> [String]
-> Either InvalidCommandLine [(LongName, ParameterValue)]
parseRequiredArguments [LongName]
needed [String]
arguments
            Map LongName ParameterValue
-> Either InvalidCommandLine (Map LongName ParameterValue)
forall (m :: * -> *) a. Monad m => a -> m a
return (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))

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)]
parseRequiredArguments :: [LongName]
-> [String]
-> Either InvalidCommandLine [(LongName, ParameterValue)]
parseRequiredArguments [LongName]
needed [String]
argv = [LongName]
-> [String]
-> Either InvalidCommandLine [(LongName, ParameterValue)]
iter [LongName]
needed [String]
argv
  where
    iter :: [LongName] -> [String] -> Either InvalidCommandLine [(LongName, ParameterValue)]

    iter :: [LongName]
-> [String]
-> Either InvalidCommandLine [(LongName, ParameterValue)]
iter [] [] = [(LongName, ParameterValue)]
-> Either InvalidCommandLine [(LongName, ParameterValue)]
forall a b. b -> Either a b
Right []
    -- more arguments supplied than expected
    iter [] [String]
args = InvalidCommandLine
-> Either InvalidCommandLine [(LongName, ParameterValue)]
forall a b. a -> Either a b
Left ([String] -> InvalidCommandLine
UnexpectedArguments [String]
args)
    -- more arguments required, not satisfied
    iter (LongName
name : [LongName]
_) [] = InvalidCommandLine
-> Either InvalidCommandLine [(LongName, ParameterValue)]
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)]
deeper = [LongName]
-> [String]
-> Either InvalidCommandLine [(LongName, ParameterValue)]
iter [LongName]
names [String]
args
       in case Either InvalidCommandLine [(LongName, ParameterValue)]
deeper of
            Left InvalidCommandLine
e -> InvalidCommandLine
-> Either InvalidCommandLine [(LongName, ParameterValue)]
forall a b. a -> Either a b
Left InvalidCommandLine
e
            Right [(LongName, ParameterValue)]
list -> [(LongName, ParameterValue)]
-> Either InvalidCommandLine [(LongName, ParameterValue)]
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)

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
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 =
  (Commands -> Map LongName [Options] -> Map LongName [Options])
-> Map LongName [Options] -> [Commands] -> Map LongName [Options]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Commands -> Map LongName [Options] -> Map LongName [Options]
k Map LongName [Options]
forall κ ν. Map κ ν
emptyMap [Commands]
commands
  where
    k :: Commands -> Map LongName [Options] -> Map LongName [Options]
    k :: Commands -> Map LongName [Options] -> Map LongName [Options]
k (Command LongName
longname Rope
_ [Options]
options) Map LongName [Options]
modes = LongName
-> [Options] -> Map LongName [Options] -> Map LongName [Options]
forall κ ν. Key κ => κ -> ν -> Map κ ν -> Map κ ν
insertKeyValue LongName
longname [Options]
options Map LongName [Options]
modes
    k Commands
_ Map LongName [Options]
modes = 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 command line.
--

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] -> ([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
                    ]
                )
            )
          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
  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] -> ([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
          Just LongName
longname ->
            let ([Options]
oL, [Options]
aL) = 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])
partitionParameters [Options]
localOptions
                  Maybe [Options]
Nothing -> String -> ([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
                          ]
                      )
                  )
                  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
  where
    partitionParameters :: [Options] -> ([Options], [Options])
    partitionParameters :: [Options] -> ([Options], [Options])
partitionParameters [Options]
options = (Options -> ([Options], [Options]) -> ([Options], [Options]))
-> ([Options], [Options]) -> [Options] -> ([Options], [Options])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr 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 -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ([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

    -- 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])
    f :: Options -> ([Options], [Options]) -> ([Options], [Options])
f o :: Options
o@(Option LongName
_ Maybe ShortName
_ ParameterValue
_ Rope
_) ([Options]
opts, [Options]
args) = (Options
o Options -> [Options] -> [Options]
forall a. a -> [a] -> [a]
: [Options]
opts, [Options]
args)
    f a :: Options
a@(Argument LongName
_ Rope
_) ([Options]
opts, [Options]
args) = ([Options]
opts, Options
a Options -> [Options] -> [Options]
forall a. a -> [a] -> [a]
: [Options]
args)
    f (Variable LongName
_ Rope
_) ([Options]
opts, [Options]
args) = ([Options]
opts, [Options]
args)

    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
<> (Options -> Doc ann -> Doc ann) -> Doc ann -> [Options] -> Doc ann
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Options -> Doc ann -> Doc ann
forall ann. Options -> Doc ann -> 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 :: Options -> Doc ann -> Doc ann
    g :: Options -> Doc ann -> Doc ann
g (Option LongName
longname Maybe ShortName
shortname ParameterValue
valued Rope
description) Doc ann
acc =
      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 (Argument LongName
longname Rope
description) Doc ann
acc =
      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 (Variable LongName
longname Rope
description) Doc ann
acc =
      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
<> (Commands -> Doc ann -> Doc ann)
-> Doc ann -> [Commands] -> Doc ann
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Commands -> Doc ann -> Doc ann
forall ann. Commands -> Doc ann -> Doc ann
h Doc ann
forall ann. Doc ann
emptyDoc [Commands]
commands

    h :: Commands -> Doc ann -> Doc ann
    h :: Commands -> Doc ann -> Doc ann
h (Command LongName
longname Rope
description [Options]
_) Doc ann
acc =
      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
    h Commands
_ Doc ann
acc = 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