{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}

-----------------------------------------------------------------------------

-- |
-- Module      :  Distribution.Simple.Command
-- Copyright   :  Duncan Coutts 2007
-- License     :  BSD3
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  non-portable (ExistentialQuantification)
--
-- This is to do with command line handling. The Cabal command line is
-- organised into a number of named sub-commands (much like darcs). The
-- 'CommandUI' abstraction represents one of these sub-commands, with a name,
-- description, a set of flags. Commands can be associated with actions and
-- run. It handles some common stuff automatically, like the @--help@ and
-- command line completion flags. It is designed to allow other tools make
-- derived commands. This feature is used heavily in @cabal-install@.
module Distribution.Simple.Command
  ( -- * Command interface
    CommandUI (..)
  , commandShowOptions
  , CommandParse (..)
  , commandParseArgs
  , getNormalCommandDescriptions
  , helpCommandUI

    -- ** Constructing commands
  , ShowOrParseArgs (..)
  , usageDefault
  , usageAlternatives
  , mkCommandUI
  , hiddenCommand

    -- ** Associating actions with commands
  , Command
  , commandAddAction
  , noExtraFlags

    -- ** Building lists of commands
  , CommandType (..)
  , CommandSpec (..)
  , commandFromSpec

    -- ** Running commands
  , commandsRun
  , commandsRunWithFallback
  , defaultCommandFallback

    -- * Option Fields
  , OptionField (..)
  , Name

    -- ** Constructing Option Fields
  , option
  , multiOption

    -- ** Liftings & Projections
  , liftOption
  , liftOptionL

    -- * Option Descriptions
  , OptDescr (..)
  , Description
  , SFlags
  , LFlags
  , OptFlags
  , ArgPlaceHolder

    -- ** OptDescr 'smart' constructors
  , MkOptDescr
  , reqArg
  , reqArg'
  , optArg
  , optArg'
  , optArgDef'
  , noArg
  , boolOpt
  , boolOpt'
  , choiceOpt
  , choiceOptFromEnum
  ) where

import Distribution.Compat.Prelude hiding (get)
import Prelude ()

import qualified Data.Array as Array
import qualified Data.List as List
import Distribution.Compat.Lens (ALens', (#~), (^#))
import qualified Distribution.GetOpt as GetOpt
import Distribution.ReadE
import Distribution.Simple.Utils

data CommandUI flags = CommandUI
  { forall flags. CommandUI flags -> String
commandName :: String
  -- ^ The name of the command as it would be entered on the command line.
  -- For example @\"build\"@.
  , forall flags. CommandUI flags -> String
commandSynopsis :: String
  -- ^ A short, one line description of the command to use in help texts.
  , forall flags. CommandUI flags -> String -> String
commandUsage :: String -> String
  -- ^ A function that maps a program name to a usage summary for this
  -- command.
  , forall flags. CommandUI flags -> Maybe (String -> String)
commandDescription :: Maybe (String -> String)
  -- ^ Additional explanation of the command to use in help texts.
  , forall flags. CommandUI flags -> Maybe (String -> String)
commandNotes :: Maybe (String -> String)
  -- ^ Post-Usage notes and examples in help texts
  , forall flags. CommandUI flags -> flags
commandDefaultFlags :: flags
  -- ^ Initial \/ empty flags
  , forall flags.
CommandUI flags -> ShowOrParseArgs -> [OptionField flags]
commandOptions :: ShowOrParseArgs -> [OptionField flags]
  -- ^ All the Option fields for this command
  }

data ShowOrParseArgs = ShowArgs | ParseArgs
type Name = String
type Description = String

-- | We usually have a data type for storing configuration values, where
--   every field stores a configuration option, and the user sets
--   the value either via command line flags or a configuration file.
--   An individual OptionField models such a field, and we usually
--   build a list of options associated to a configuration data type.
data OptionField a = OptionField
  { forall a. OptionField a -> String
optionName :: Name
  , forall a. OptionField a -> [OptDescr a]
optionDescr :: [OptDescr a]
  }

-- | An OptionField takes one or more OptDescrs, describing the command line
-- interface for the field.
data OptDescr a
  = ReqArg
      Description
      OptFlags
      ArgPlaceHolder
      (ReadE (a -> a))
      (a -> [String])
  | OptArg
      Description
      OptFlags
      ArgPlaceHolder
      (ReadE (a -> a))
      (String, a -> a)
      (a -> [Maybe String])
  | ChoiceOpt [(Description, OptFlags, a -> a, a -> Bool)]
  | BoolOpt
      Description
      OptFlags {-True-}
      OptFlags {-False-}
      (Bool -> a -> a)
      (a -> Maybe Bool)

-- | Short command line option strings
type SFlags = [Char]

-- | Long command line option strings
type LFlags = [String]

type OptFlags = (SFlags, LFlags)
type ArgPlaceHolder = String

-- | Create an option taking a single OptDescr.
--   No explicit Name is given for the Option, the name is the first LFlag given.
--
-- Example: @'option' sf lf d get set@
-- * @sf@: Short option name, for example: @[\'d\']@. No hyphen permitted.
-- * @lf@: Long option name, for example: @["debug"]@. No hyphens permitted.
-- * @d@: Description of the option, shown to the user in help messages.
-- * @get@: Get the current value of the flag.
-- * @set@: Set the value of the flag. Gets the current value of the flag as a
--          parameter.
option
  :: SFlags
  -> LFlags
  -> Description
  -> get
  -> set
  -> MkOptDescr get set a
  -> OptionField a
option :: forall get set a.
String
-> LFlags
-> String
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option String
sf lf :: LFlags
lf@(String
n : LFlags
_) String
d get
get set
set MkOptDescr get set a
arg = String -> [OptDescr a] -> OptionField a
forall a. String -> [OptDescr a] -> OptionField a
OptionField String
n [MkOptDescr get set a
arg String
sf LFlags
lf String
d get
get set
set]
option String
_ LFlags
_ String
_ get
_ set
_ MkOptDescr get set a
_ =
  String -> OptionField a
forall a. HasCallStack => String -> a
error (String -> OptionField a) -> String -> OptionField a
forall a b. (a -> b) -> a -> b
$
    String
"Distribution.command.option: "
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"An OptionField must have at least one LFlag"

-- | Create an option taking several OptDescrs.
--   You will have to give the flags and description individually to the
--   OptDescr constructor.
multiOption
  :: Name
  -> get
  -> set
  -> [get -> set -> OptDescr a]
  -- ^ MkOptDescr constructors partially
  --  applied to flags and description.
  -> OptionField a
multiOption :: forall get set a.
String -> get -> set -> [get -> set -> OptDescr a] -> OptionField a
multiOption String
n get
get set
set [get -> set -> OptDescr a]
args = String -> [OptDescr a] -> OptionField a
forall a. String -> [OptDescr a] -> OptionField a
OptionField String
n [get -> set -> OptDescr a
arg get
get set
set | get -> set -> OptDescr a
arg <- [get -> set -> OptDescr a]
args]

type MkOptDescr get set a =
  SFlags
  -> LFlags
  -> Description
  -> get
  -> set
  -> OptDescr a

-- | Create a string-valued command line interface.
-- Usually called in the context of 'option' or 'multiOption'.
--
-- Example: @'reqArg' ad mkflag showflag@
--
-- * @ad@: Placeholder shown to the user, e.g. @"FILES"@ if files are expected
--         parameters.
-- * @mkflag@: How to parse the argument into the option.
-- * @showflag@: If parsing goes wrong, display a useful error message to
--               the user.
reqArg
  :: Monoid b
  => ArgPlaceHolder
  -> ReadE b
  -> (b -> [String])
  -> MkOptDescr (a -> b) (b -> a -> a) a
reqArg :: forall b a.
Monoid b =>
String
-> ReadE b -> (b -> LFlags) -> MkOptDescr (a -> b) (b -> a -> a) a
reqArg String
ad ReadE b
mkflag b -> LFlags
showflag String
sf LFlags
lf String
d a -> b
get b -> a -> a
set =
  String
-> OptFlags
-> String
-> ReadE (a -> a)
-> (a -> LFlags)
-> OptDescr a
forall a.
String
-> OptFlags
-> String
-> ReadE (a -> a)
-> (a -> LFlags)
-> OptDescr a
ReqArg
    String
d
    (String
sf, LFlags
lf)
    String
ad
    ((b -> a -> a) -> ReadE b -> ReadE (a -> a)
forall a b. (a -> b) -> ReadE a -> ReadE b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\b
a a
b -> b -> a -> a
set (a -> b
get a
b b -> b -> b
forall a. Monoid a => a -> a -> a
`mappend` b
a) a
b) ReadE b
mkflag)
    (b -> LFlags
showflag (b -> LFlags) -> (a -> b) -> a -> LFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
get)

-- | Create a string-valued command line interface with a default value.
optArg
  :: Monoid b
  => ArgPlaceHolder
  -> ReadE b
  -> (String, b)
  -> (b -> [Maybe String])
  -> MkOptDescr (a -> b) (b -> a -> a) a
optArg :: forall b a.
Monoid b =>
String
-> ReadE b
-> (String, b)
-> (b -> [Maybe String])
-> MkOptDescr (a -> b) (b -> a -> a) a
optArg String
ad ReadE b
mkflag (String
dv, b
mkDef) b -> [Maybe String]
showflag String
sf LFlags
lf String
d a -> b
get b -> a -> a
set =
  String
-> OptFlags
-> String
-> ReadE (a -> a)
-> (String, a -> a)
-> (a -> [Maybe String])
-> OptDescr a
forall a.
String
-> OptFlags
-> String
-> ReadE (a -> a)
-> (String, a -> a)
-> (a -> [Maybe String])
-> OptDescr a
OptArg
    String
d
    (String
sf, LFlags
lf)
    String
ad
    ((b -> a -> a) -> ReadE b -> ReadE (a -> a)
forall a b. (a -> b) -> ReadE a -> ReadE b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\b
a a
b -> b -> a -> a
set (a -> b
get a
b b -> b -> b
forall a. Monoid a => a -> a -> a
`mappend` b
a) a
b) ReadE b
mkflag)
    (String
dv, \a
b -> b -> a -> a
set (a -> b
get a
b b -> b -> b
forall a. Monoid a => a -> a -> a
`mappend` b
mkDef) a
b)
    (b -> [Maybe String]
showflag (b -> [Maybe String]) -> (a -> b) -> a -> [Maybe String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
get)

-- | (String -> a) variant of "reqArg"
reqArg'
  :: Monoid b
  => ArgPlaceHolder
  -> (String -> b)
  -> (b -> [String])
  -> MkOptDescr (a -> b) (b -> a -> a) a
reqArg' :: forall b a.
Monoid b =>
String
-> (String -> b)
-> (b -> LFlags)
-> MkOptDescr (a -> b) (b -> a -> a) a
reqArg' String
ad String -> b
mkflag b -> LFlags
showflag =
  String
-> ReadE b -> (b -> LFlags) -> MkOptDescr (a -> b) (b -> a -> a) a
forall b a.
Monoid b =>
String
-> ReadE b -> (b -> LFlags) -> MkOptDescr (a -> b) (b -> a -> a) a
reqArg String
ad ((String -> b) -> ReadE b
forall a. (String -> a) -> ReadE a
succeedReadE String -> b
mkflag) b -> LFlags
showflag

-- | (String -> a) variant of "optArg"
optArg'
  :: Monoid b
  => ArgPlaceHolder
  -> (Maybe String -> b)
  -> (b -> [Maybe String])
  -> MkOptDescr (a -> b) (b -> a -> a) a
optArg' :: forall b a.
Monoid b =>
String
-> (Maybe String -> b)
-> (b -> [Maybe String])
-> MkOptDescr (a -> b) (b -> a -> a) a
optArg' String
ad Maybe String -> b
mkflag b -> [Maybe String]
showflag =
  String
-> ReadE b
-> (String, b)
-> (b -> [Maybe String])
-> MkOptDescr (a -> b) (b -> a -> a) a
forall b a.
Monoid b =>
String
-> ReadE b
-> (String, b)
-> (b -> [Maybe String])
-> MkOptDescr (a -> b) (b -> a -> a) a
optArg String
ad ((String -> b) -> ReadE b
forall a. (String -> a) -> ReadE a
succeedReadE (Maybe String -> b
mkflag (Maybe String -> b) -> (String -> Maybe String) -> String -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
forall a. a -> Maybe a
Just)) (String
"", Maybe String -> b
mkflag Maybe String
forall a. Maybe a
Nothing) b -> [Maybe String]
showflag

optArgDef'
  :: Monoid b
  => ArgPlaceHolder
  -> (String, Maybe String -> b)
  -> (b -> [Maybe String])
  -> MkOptDescr (a -> b) (b -> a -> a) a
optArgDef' :: forall b a.
Monoid b =>
String
-> (String, Maybe String -> b)
-> (b -> [Maybe String])
-> MkOptDescr (a -> b) (b -> a -> a) a
optArgDef' String
ad (String
dv, Maybe String -> b
mkflag) b -> [Maybe String]
showflag =
  String
-> ReadE b
-> (String, b)
-> (b -> [Maybe String])
-> MkOptDescr (a -> b) (b -> a -> a) a
forall b a.
Monoid b =>
String
-> ReadE b
-> (String, b)
-> (b -> [Maybe String])
-> MkOptDescr (a -> b) (b -> a -> a) a
optArg String
ad ((String -> b) -> ReadE b
forall a. (String -> a) -> ReadE a
succeedReadE (Maybe String -> b
mkflag (Maybe String -> b) -> (String -> Maybe String) -> String -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
forall a. a -> Maybe a
Just)) (String
dv, Maybe String -> b
mkflag Maybe String
forall a. Maybe a
Nothing) b -> [Maybe String]
showflag

noArg :: Eq b => b -> MkOptDescr (a -> b) (b -> a -> a) a
noArg :: forall b a. Eq b => b -> MkOptDescr (a -> b) (b -> a -> a) a
noArg b
flag String
sf LFlags
lf String
d = [(b, OptFlags, String)] -> MkOptDescr (a -> b) (b -> a -> a) a
forall b a.
Eq b =>
[(b, OptFlags, String)] -> MkOptDescr (a -> b) (b -> a -> a) a
choiceOpt [(b
flag, (String
sf, LFlags
lf), String
d)] String
sf LFlags
lf String
d

boolOpt
  :: (b -> Maybe Bool)
  -> (Bool -> b)
  -> SFlags
  -> SFlags
  -> MkOptDescr (a -> b) (b -> a -> a) a
boolOpt :: forall b a.
(b -> Maybe Bool)
-> (Bool -> b)
-> String
-> String
-> MkOptDescr (a -> b) (b -> a -> a) a
boolOpt b -> Maybe Bool
g Bool -> b
s String
sfT String
sfF String
_sf _lf :: LFlags
_lf@(String
n : LFlags
_) String
d a -> b
get b -> a -> a
set =
  String
-> OptFlags
-> OptFlags
-> (Bool -> a -> a)
-> (a -> Maybe Bool)
-> OptDescr a
forall a.
String
-> OptFlags
-> OptFlags
-> (Bool -> a -> a)
-> (a -> Maybe Bool)
-> OptDescr a
BoolOpt String
d (String
sfT, [String
"enable-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n]) (String
sfF, [String
"disable-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n]) (b -> a -> a
set (b -> a -> a) -> (Bool -> b) -> Bool -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> b
s) (b -> Maybe Bool
g (b -> Maybe Bool) -> (a -> b) -> a -> Maybe Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
get)
boolOpt b -> Maybe Bool
_ Bool -> b
_ String
_ String
_ String
_ LFlags
_ String
_ a -> b
_ b -> a -> a
_ =
  String -> OptDescr a
forall a. HasCallStack => String -> a
error
    String
"Distribution.Simple.Setup.boolOpt: unreachable"

boolOpt'
  :: (b -> Maybe Bool)
  -> (Bool -> b)
  -> OptFlags
  -> OptFlags
  -> MkOptDescr (a -> b) (b -> a -> a) a
boolOpt' :: forall b a.
(b -> Maybe Bool)
-> (Bool -> b)
-> OptFlags
-> OptFlags
-> MkOptDescr (a -> b) (b -> a -> a) a
boolOpt' b -> Maybe Bool
g Bool -> b
s OptFlags
ffT OptFlags
ffF String
_sf LFlags
_lf String
d a -> b
get b -> a -> a
set = String
-> OptFlags
-> OptFlags
-> (Bool -> a -> a)
-> (a -> Maybe Bool)
-> OptDescr a
forall a.
String
-> OptFlags
-> OptFlags
-> (Bool -> a -> a)
-> (a -> Maybe Bool)
-> OptDescr a
BoolOpt String
d OptFlags
ffT OptFlags
ffF (b -> a -> a
set (b -> a -> a) -> (Bool -> b) -> Bool -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> b
s) (b -> Maybe Bool
g (b -> Maybe Bool) -> (a -> b) -> a -> Maybe Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
get)

-- | create a Choice option
choiceOpt
  :: Eq b
  => [(b, OptFlags, Description)]
  -> MkOptDescr (a -> b) (b -> a -> a) a
choiceOpt :: forall b a.
Eq b =>
[(b, OptFlags, String)] -> MkOptDescr (a -> b) (b -> a -> a) a
choiceOpt [(b, OptFlags, String)]
aa_ff String
_sf LFlags
_lf String
_d a -> b
get b -> a -> a
set = [(String, OptFlags, a -> a, a -> Bool)] -> OptDescr a
forall a. [(String, OptFlags, a -> a, a -> Bool)] -> OptDescr a
ChoiceOpt [(String, OptFlags, a -> a, a -> Bool)]
alts
  where
    alts :: [(String, OptFlags, a -> a, a -> Bool)]
alts = [(String
d, OptFlags
flags, b -> a -> a
set b
alt, (b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
alt) (b -> Bool) -> (a -> b) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
get) | (b
alt, OptFlags
flags, String
d) <- [(b, OptFlags, String)]
aa_ff]

-- | create a Choice option out of an enumeration type.
--   As long flags, the Show output is used. As short flags, the first character
--   which does not conflict with a previous one is used.
choiceOptFromEnum
  :: (Bounded b, Enum b, Show b, Eq b)
  => MkOptDescr (a -> b) (b -> a -> a) a
choiceOptFromEnum :: forall b a.
(Bounded b, Enum b, Show b, Eq b) =>
MkOptDescr (a -> b) (b -> a -> a) a
choiceOptFromEnum String
_sf LFlags
_lf String
d a -> b
get =
  [(b, OptFlags, String)] -> MkOptDescr (a -> b) (b -> a -> a) a
forall b a.
Eq b =>
[(b, OptFlags, String)] -> MkOptDescr (a -> b) (b -> a -> a) a
choiceOpt
    [ (b
x, (String
sf, [(Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ b -> String
forall a. Show a => a -> String
show b
x]), String
d')
    | (b
x, String
sf) <- [(b, String)]
sflags'
    , let d' :: String
d' = String
d String -> String -> String
forall a. [a] -> [a] -> [a]
++ b -> String
forall a. Show a => a -> String
show b
x
    ]
    String
_sf
    LFlags
_lf
    String
d
    a -> b
get
  where
    sflags' :: [(b, String)]
sflags' = ([(b, String)] -> b -> [(b, String)])
-> [(b, String)] -> [b] -> [(b, String)]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [(b, String)] -> b -> [(b, String)]
forall {a}. Show a => [(a, String)] -> a -> [(a, String)]
f [] [b
firstOne ..]
    f :: [(a, String)] -> a -> [(a, String)]
f [(a, String)]
prev a
x =
      let prevflags :: String
prevflags = ((a, String) -> String) -> [(a, String)] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (a, String) -> String
forall a b. (a, b) -> b
snd [(a, String)]
prev
       in [(a, String)]
prev
            [(a, String)] -> [(a, String)] -> [(a, String)]
forall a. [a] -> [a] -> [a]
++ Int -> [(a, String)] -> [(a, String)]
forall a. Int -> [a] -> [a]
take
              Int
1
              [ (a
x, [Char -> Char
toLower Char
sf])
              | Char
sf <- a -> String
forall a. Show a => a -> String
show a
x
              , Char -> Bool
isAlpha Char
sf
              , Char -> Char
toLower Char
sf Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
prevflags
              ]
    firstOne :: b
firstOne = b
forall a. Bounded a => a
minBound b -> b -> b
forall a. a -> a -> a
`asTypeOf` a -> b
get a
forall a. HasCallStack => a
undefined

commandGetOpts
  :: ShowOrParseArgs
  -> CommandUI flags
  -> [GetOpt.OptDescr (flags -> flags)]
commandGetOpts :: forall flags.
ShowOrParseArgs -> CommandUI flags -> [OptDescr (flags -> flags)]
commandGetOpts ShowOrParseArgs
showOrParse CommandUI flags
command =
  (OptionField flags -> [OptDescr (flags -> flags)])
-> [OptionField flags] -> [OptDescr (flags -> flags)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap OptionField flags -> [OptDescr (flags -> flags)]
forall a. OptionField a -> [OptDescr (a -> a)]
viewAsGetOpt (CommandUI flags -> ShowOrParseArgs -> [OptionField flags]
forall flags.
CommandUI flags -> ShowOrParseArgs -> [OptionField flags]
commandOptions CommandUI flags
command ShowOrParseArgs
showOrParse)

viewAsGetOpt :: OptionField a -> [GetOpt.OptDescr (a -> a)]
viewAsGetOpt :: forall a. OptionField a -> [OptDescr (a -> a)]
viewAsGetOpt (OptionField String
_n [OptDescr a]
aa) = (OptDescr a -> [OptDescr (a -> a)])
-> [OptDescr a] -> [OptDescr (a -> a)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap OptDescr a -> [OptDescr (a -> a)]
forall {a}. OptDescr a -> [OptDescr (a -> a)]
optDescrToGetOpt [OptDescr a]
aa
  where
    optDescrToGetOpt :: OptDescr a -> [OptDescr (a -> a)]
optDescrToGetOpt (ReqArg String
d (String
cs, LFlags
ss) String
arg_desc ReadE (a -> a)
set a -> LFlags
_) =
      [String
-> LFlags -> ArgDescr (a -> a) -> String -> OptDescr (a -> a)
forall a. String -> LFlags -> ArgDescr a -> String -> OptDescr a
GetOpt.Option String
cs LFlags
ss ((String -> Either String (a -> a)) -> String -> ArgDescr (a -> a)
forall a. (String -> Either String a) -> String -> ArgDescr a
GetOpt.ReqArg (ReadE (a -> a) -> String -> Either String (a -> a)
forall a. ReadE a -> String -> Either String a
runReadE ReadE (a -> a)
set) String
arg_desc) String
d]
    optDescrToGetOpt (OptArg String
d (String
cs, LFlags
ss) String
arg_desc ReadE (a -> a)
set (String
dv, a -> a
def) a -> [Maybe String]
_) =
      [String
-> LFlags -> ArgDescr (a -> a) -> String -> OptDescr (a -> a)
forall a. String -> LFlags -> ArgDescr a -> String -> OptDescr a
GetOpt.Option String
cs LFlags
ss (String
-> (Maybe String -> Either String (a -> a))
-> String
-> ArgDescr (a -> a)
forall a.
String -> (Maybe String -> Either String a) -> String -> ArgDescr a
GetOpt.OptArg String
dv Maybe String -> Either String (a -> a)
set' String
arg_desc) String
d]
      where
        set' :: Maybe String -> Either String (a -> a)
set' Maybe String
Nothing = (a -> a) -> Either String (a -> a)
forall a b. b -> Either a b
Right a -> a
def
        set' (Just String
txt) = ReadE (a -> a) -> String -> Either String (a -> a)
forall a. ReadE a -> String -> Either String a
runReadE ReadE (a -> a)
set String
txt
    optDescrToGetOpt (ChoiceOpt [(String, OptFlags, a -> a, a -> Bool)]
alts) =
      [String
-> LFlags -> ArgDescr (a -> a) -> String -> OptDescr (a -> a)
forall a. String -> LFlags -> ArgDescr a -> String -> OptDescr a
GetOpt.Option String
sf LFlags
lf ((a -> a) -> ArgDescr (a -> a)
forall a. a -> ArgDescr a
GetOpt.NoArg a -> a
set) String
d | (String
d, (String
sf, LFlags
lf), a -> a
set, a -> Bool
_) <- [(String, OptFlags, a -> a, a -> Bool)]
alts]
    optDescrToGetOpt (BoolOpt String
d (String
sfT, LFlags
lfT) ([], []) Bool -> a -> a
set a -> Maybe Bool
_) =
      [String
-> LFlags -> ArgDescr (a -> a) -> String -> OptDescr (a -> a)
forall a. String -> LFlags -> ArgDescr a -> String -> OptDescr a
GetOpt.Option String
sfT LFlags
lfT ((a -> a) -> ArgDescr (a -> a)
forall a. a -> ArgDescr a
GetOpt.NoArg (Bool -> a -> a
set Bool
True)) String
d]
    optDescrToGetOpt (BoolOpt String
d ([], []) (String
sfF, LFlags
lfF) Bool -> a -> a
set a -> Maybe Bool
_) =
      [String
-> LFlags -> ArgDescr (a -> a) -> String -> OptDescr (a -> a)
forall a. String -> LFlags -> ArgDescr a -> String -> OptDescr a
GetOpt.Option String
sfF LFlags
lfF ((a -> a) -> ArgDescr (a -> a)
forall a. a -> ArgDescr a
GetOpt.NoArg (Bool -> a -> a
set Bool
False)) String
d]
    optDescrToGetOpt (BoolOpt String
d (String
sfT, LFlags
lfT) (String
sfF, LFlags
lfF) Bool -> a -> a
set a -> Maybe Bool
_) =
      [ String
-> LFlags -> ArgDescr (a -> a) -> String -> OptDescr (a -> a)
forall a. String -> LFlags -> ArgDescr a -> String -> OptDescr a
GetOpt.Option String
sfT LFlags
lfT ((a -> a) -> ArgDescr (a -> a)
forall a. a -> ArgDescr a
GetOpt.NoArg (Bool -> a -> a
set Bool
True)) (String
"Enable " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
d)
      , String
-> LFlags -> ArgDescr (a -> a) -> String -> OptDescr (a -> a)
forall a. String -> LFlags -> ArgDescr a -> String -> OptDescr a
GetOpt.Option String
sfF LFlags
lfF ((a -> a) -> ArgDescr (a -> a)
forall a. a -> ArgDescr a
GetOpt.NoArg (Bool -> a -> a
set Bool
False)) (String
"Disable " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
d)
      ]

getCurrentChoice :: OptDescr a -> a -> [String]
getCurrentChoice :: forall a. OptDescr a -> a -> LFlags
getCurrentChoice (ChoiceOpt [(String, OptFlags, a -> a, a -> Bool)]
alts) a
a =
  [String
lf | (String
_, (String
_sf, String
lf : LFlags
_), a -> a
_, a -> Bool
currentChoice) <- [(String, OptFlags, a -> a, a -> Bool)]
alts, a -> Bool
currentChoice a
a]
getCurrentChoice OptDescr a
_ a
_ = String -> LFlags
forall a. HasCallStack => String -> a
error String
"Command.getChoice: expected a Choice OptDescr"

liftOption :: (b -> a) -> (a -> (b -> b)) -> OptionField a -> OptionField b
liftOption :: forall b a.
(b -> a) -> (a -> b -> b) -> OptionField a -> OptionField b
liftOption b -> a
get' a -> b -> b
set' OptionField a
opt =
  OptionField a
opt{optionDescr = liftOptDescr get' set' `map` optionDescr opt}

-- | @since 3.4.0.0
liftOptionL :: ALens' b a -> OptionField a -> OptionField b
liftOptionL :: forall b a. ALens' b a -> OptionField a -> OptionField b
liftOptionL ALens' b a
l = (b -> a) -> (a -> b -> b) -> OptionField a -> OptionField b
forall b a.
(b -> a) -> (a -> b -> b) -> OptionField a -> OptionField b
liftOption (b -> ALens' b a -> a
forall s t a b. s -> ALens s t a b -> a
^# ALens' b a
l) (ALens' b a
l ALens' b a -> a -> b -> b
forall s t a b. ALens s t a b -> b -> s -> t
#~)

liftOptDescr :: (b -> a) -> (a -> (b -> b)) -> OptDescr a -> OptDescr b
liftOptDescr :: forall b a. (b -> a) -> (a -> b -> b) -> OptDescr a -> OptDescr b
liftOptDescr b -> a
get' a -> b -> b
set' (ChoiceOpt [(String, OptFlags, a -> a, a -> Bool)]
opts) =
  [(String, OptFlags, b -> b, b -> Bool)] -> OptDescr b
forall a. [(String, OptFlags, a -> a, a -> Bool)] -> OptDescr a
ChoiceOpt
    [ (String
d, OptFlags
ff, (b -> a) -> (a -> b -> b) -> (a -> a) -> b -> b
forall b a. (b -> a) -> (a -> b -> b) -> (a -> a) -> b -> b
liftSet b -> a
get' a -> b -> b
set' a -> a
set, (a -> Bool
get (a -> Bool) -> (b -> a) -> b -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
get'))
    | (String
d, OptFlags
ff, a -> a
set, a -> Bool
get) <- [(String, OptFlags, a -> a, a -> Bool)]
opts
    ]
liftOptDescr b -> a
get' a -> b -> b
set' (OptArg String
d OptFlags
ff String
ad ReadE (a -> a)
set (String
dv, a -> a
mkDef) a -> [Maybe String]
get) =
  String
-> OptFlags
-> String
-> ReadE (b -> b)
-> (String, b -> b)
-> (b -> [Maybe String])
-> OptDescr b
forall a.
String
-> OptFlags
-> String
-> ReadE (a -> a)
-> (String, a -> a)
-> (a -> [Maybe String])
-> OptDescr a
OptArg
    String
d
    OptFlags
ff
    String
ad
    ((b -> a) -> (a -> b -> b) -> (a -> a) -> b -> b
forall b a. (b -> a) -> (a -> b -> b) -> (a -> a) -> b -> b
liftSet b -> a
get' a -> b -> b
set' ((a -> a) -> b -> b) -> ReadE (a -> a) -> ReadE (b -> b)
forall a b. (a -> b) -> ReadE a -> ReadE b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ReadE (a -> a)
set)
    (String
dv, (b -> a) -> (a -> b -> b) -> (a -> a) -> b -> b
forall b a. (b -> a) -> (a -> b -> b) -> (a -> a) -> b -> b
liftSet b -> a
get' a -> b -> b
set' a -> a
mkDef)
    (a -> [Maybe String]
get (a -> [Maybe String]) -> (b -> a) -> b -> [Maybe String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
get')
liftOptDescr b -> a
get' a -> b -> b
set' (ReqArg String
d OptFlags
ff String
ad ReadE (a -> a)
set a -> LFlags
get) =
  String
-> OptFlags
-> String
-> ReadE (b -> b)
-> (b -> LFlags)
-> OptDescr b
forall a.
String
-> OptFlags
-> String
-> ReadE (a -> a)
-> (a -> LFlags)
-> OptDescr a
ReqArg String
d OptFlags
ff String
ad ((b -> a) -> (a -> b -> b) -> (a -> a) -> b -> b
forall b a. (b -> a) -> (a -> b -> b) -> (a -> a) -> b -> b
liftSet b -> a
get' a -> b -> b
set' ((a -> a) -> b -> b) -> ReadE (a -> a) -> ReadE (b -> b)
forall a b. (a -> b) -> ReadE a -> ReadE b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ReadE (a -> a)
set) (a -> LFlags
get (a -> LFlags) -> (b -> a) -> b -> LFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
get')
liftOptDescr b -> a
get' a -> b -> b
set' (BoolOpt String
d OptFlags
ffT OptFlags
ffF Bool -> a -> a
set a -> Maybe Bool
get) =
  String
-> OptFlags
-> OptFlags
-> (Bool -> b -> b)
-> (b -> Maybe Bool)
-> OptDescr b
forall a.
String
-> OptFlags
-> OptFlags
-> (Bool -> a -> a)
-> (a -> Maybe Bool)
-> OptDescr a
BoolOpt String
d OptFlags
ffT OptFlags
ffF ((b -> a) -> (a -> b -> b) -> (a -> a) -> b -> b
forall b a. (b -> a) -> (a -> b -> b) -> (a -> a) -> b -> b
liftSet b -> a
get' a -> b -> b
set' ((a -> a) -> b -> b) -> (Bool -> a -> a) -> Bool -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> a -> a
set) (a -> Maybe Bool
get (a -> Maybe Bool) -> (b -> a) -> b -> Maybe Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
get')

liftSet :: (b -> a) -> (a -> (b -> b)) -> (a -> a) -> b -> b
liftSet :: forall b a. (b -> a) -> (a -> b -> b) -> (a -> a) -> b -> b
liftSet b -> a
get' a -> b -> b
set' a -> a
set b
x = a -> b -> b
set' (a -> a
set (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ b -> a
get' b
x) b
x

-- | Show flags in the standard long option command line format
commandShowOptions :: CommandUI flags -> flags -> [String]
commandShowOptions :: forall flags. CommandUI flags -> flags -> LFlags
commandShowOptions CommandUI flags
command flags
v =
  [LFlags] -> LFlags
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ flags -> OptDescr flags -> LFlags
forall a. a -> OptDescr a -> LFlags
showOptDescr flags
v OptDescr flags
od | OptionField flags
o <- CommandUI flags -> ShowOrParseArgs -> [OptionField flags]
forall flags.
CommandUI flags -> ShowOrParseArgs -> [OptionField flags]
commandOptions CommandUI flags
command ShowOrParseArgs
ParseArgs, OptDescr flags
od <- OptionField flags -> [OptDescr flags]
forall a. OptionField a -> [OptDescr a]
optionDescr OptionField flags
o
    ]
  where
    maybePrefix :: LFlags -> LFlags
maybePrefix [] = []
    maybePrefix (String
lOpt : LFlags
_) = [String
"--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lOpt]

    showOptDescr :: a -> OptDescr a -> [String]
    showOptDescr :: forall a. a -> OptDescr a -> LFlags
showOptDescr a
x (BoolOpt String
_ (String
_, LFlags
lfTs) (String
_, LFlags
lfFs) Bool -> a -> a
_ a -> Maybe Bool
enabled) =
      case a -> Maybe Bool
enabled a
x of
        Maybe Bool
Nothing -> []
        Just Bool
True -> LFlags -> LFlags
maybePrefix LFlags
lfTs
        Just Bool
False -> LFlags -> LFlags
maybePrefix LFlags
lfFs
    showOptDescr a
x c :: OptDescr a
c@ChoiceOpt{} =
      [String
"--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
val | String
val <- OptDescr a -> a -> LFlags
forall a. OptDescr a -> a -> LFlags
getCurrentChoice OptDescr a
c a
x]
    showOptDescr a
x (ReqArg String
_ (String
_ssff, String
lf : LFlags
_) String
_ ReadE (a -> a)
_ a -> LFlags
showflag) =
      [ String
"--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lf String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
flag
      | String
flag <- a -> LFlags
showflag a
x
      ]
    showOptDescr a
x (OptArg String
_ (String
_ssff, String
lf : LFlags
_) String
_ ReadE (a -> a)
_ (String, a -> a)
_ a -> [Maybe String]
showflag) =
      [ case Maybe String
flag of
        Just String
s -> String
"--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lf String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
        Maybe String
Nothing -> String
"--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lf
      | Maybe String
flag <- a -> [Maybe String]
showflag a
x
      ]
    showOptDescr a
_ OptDescr a
_ =
      String -> LFlags
forall a. HasCallStack => String -> a
error String
"Distribution.Simple.Command.showOptDescr: unreachable"

commandListOptions :: CommandUI flags -> [String]
commandListOptions :: forall flags. CommandUI flags -> LFlags
commandListOptions CommandUI flags
command =
  (OptDescr (Either CommonFlag (flags -> flags)) -> LFlags)
-> [OptDescr (Either CommonFlag (flags -> flags))] -> LFlags
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap OptDescr (Either CommonFlag (flags -> flags)) -> LFlags
forall {a}. OptDescr a -> LFlags
listOption ([OptDescr (Either CommonFlag (flags -> flags))] -> LFlags)
-> [OptDescr (Either CommonFlag (flags -> flags))] -> LFlags
forall a b. (a -> b) -> a -> b
$
    ShowOrParseArgs
-> [OptDescr (flags -> flags)]
-> [OptDescr (Either CommonFlag (flags -> flags))]
forall a.
ShowOrParseArgs -> [OptDescr a] -> [OptDescr (Either CommonFlag a)]
addCommonFlags ShowOrParseArgs
ShowArgs ([OptDescr (flags -> flags)]
 -> [OptDescr (Either CommonFlag (flags -> flags))])
-> [OptDescr (flags -> flags)]
-> [OptDescr (Either CommonFlag (flags -> flags))]
forall a b. (a -> b) -> a -> b
$ -- This is a slight hack, we don't want
    -- "--list-options" showing up in the
    -- list options output, so use ShowArgs
      ShowOrParseArgs -> CommandUI flags -> [OptDescr (flags -> flags)]
forall flags.
ShowOrParseArgs -> CommandUI flags -> [OptDescr (flags -> flags)]
commandGetOpts ShowOrParseArgs
ShowArgs CommandUI flags
command
  where
    listOption :: OptDescr a -> LFlags
listOption (GetOpt.Option String
shortNames LFlags
longNames ArgDescr a
_ String
_) =
      [String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
name] | Char
name <- String
shortNames]
        LFlags -> LFlags -> LFlags
forall a. [a] -> [a] -> [a]
++ [String
"--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name | String
name <- LFlags
longNames]

-- | The help text for this command with descriptions of all the options.
commandHelp :: CommandUI flags -> String -> String
commandHelp :: forall flags. CommandUI flags -> String -> String
commandHelp CommandUI flags
command String
pname =
  CommandUI flags -> String
forall flags. CommandUI flags -> String
commandSynopsis CommandUI flags
command
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n\n"
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ CommandUI flags -> String -> String
forall flags. CommandUI flags -> String -> String
commandUsage CommandUI flags
command String
pname
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ ( case CommandUI flags -> Maybe (String -> String)
forall flags. CommandUI flags -> Maybe (String -> String)
commandDescription CommandUI flags
command of
          Maybe (String -> String)
Nothing -> String
""
          Just String -> String
desc -> Char
'\n' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
desc String
pname
       )
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ ( if String
cname String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
""
          then String
"Global flags:"
          else String
"Flags for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":"
       )
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ ( String -> [OptDescr (Either CommonFlag (flags -> flags))] -> String
forall a. String -> [OptDescr a] -> String
GetOpt.usageInfo String
""
          ([OptDescr (Either CommonFlag (flags -> flags))] -> String)
-> ([OptDescr (flags -> flags)]
    -> [OptDescr (Either CommonFlag (flags -> flags))])
-> [OptDescr (flags -> flags)]
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowOrParseArgs
-> [OptDescr (flags -> flags)]
-> [OptDescr (Either CommonFlag (flags -> flags))]
forall a.
ShowOrParseArgs -> [OptDescr a] -> [OptDescr (Either CommonFlag a)]
addCommonFlags ShowOrParseArgs
ShowArgs
          ([OptDescr (flags -> flags)] -> String)
-> [OptDescr (flags -> flags)] -> String
forall a b. (a -> b) -> a -> b
$ ShowOrParseArgs -> CommandUI flags -> [OptDescr (flags -> flags)]
forall flags.
ShowOrParseArgs -> CommandUI flags -> [OptDescr (flags -> flags)]
commandGetOpts ShowOrParseArgs
ShowArgs CommandUI flags
command
       )
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ ( case CommandUI flags -> Maybe (String -> String)
forall flags. CommandUI flags -> Maybe (String -> String)
commandNotes CommandUI flags
command of
          Maybe (String -> String)
Nothing -> String
""
          Just String -> String
notes -> Char
'\n' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
notes String
pname
       )
  where
    cname :: String
cname = CommandUI flags -> String
forall flags. CommandUI flags -> String
commandName CommandUI flags
command

-- | Default "usage" documentation text for commands.
usageDefault :: String -> String -> String
usageDefault :: String -> String -> String
usageDefault String
name String
pname =
  String
"Usage: "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pname
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" [FLAGS]\n\n"
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Flags for "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":"

-- | Create "usage" documentation from a list of parameter
--   configurations.
usageAlternatives :: String -> [String] -> String -> String
usageAlternatives :: String -> LFlags -> String -> String
usageAlternatives String
name LFlags
strs String
pname =
  LFlags -> String
unlines
    [ String
start String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
    | let starts :: LFlags
starts = String
"Usage: " String -> LFlags -> LFlags
forall a. a -> [a] -> [a]
: String -> LFlags
forall a. a -> [a]
repeat String
"   or: "
    , (String
start, String
s) <- LFlags -> LFlags -> [(String, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip LFlags
starts LFlags
strs
    ]

-- | Make a Command from standard 'GetOpt' options.
mkCommandUI
  :: String
  -- ^ name
  -> String
  -- ^ synopsis
  -> [String]
  -- ^ usage alternatives
  -> flags
  -- ^ initial\/empty flags
  -> (ShowOrParseArgs -> [OptionField flags])
  -- ^ options
  -> CommandUI flags
mkCommandUI :: forall flags.
String
-> String
-> LFlags
-> flags
-> (ShowOrParseArgs -> [OptionField flags])
-> CommandUI flags
mkCommandUI String
name String
synopsis LFlags
usages flags
flags ShowOrParseArgs -> [OptionField flags]
options =
  CommandUI
    { commandName :: String
commandName = String
name
    , commandSynopsis :: String
commandSynopsis = String
synopsis
    , commandDescription :: Maybe (String -> String)
commandDescription = Maybe (String -> String)
forall a. Maybe a
Nothing
    , commandNotes :: Maybe (String -> String)
commandNotes = Maybe (String -> String)
forall a. Maybe a
Nothing
    , commandUsage :: String -> String
commandUsage = String -> LFlags -> String -> String
usageAlternatives String
name LFlags
usages
    , commandDefaultFlags :: flags
commandDefaultFlags = flags
flags
    , commandOptions :: ShowOrParseArgs -> [OptionField flags]
commandOptions = ShowOrParseArgs -> [OptionField flags]
options
    }

-- | Common flags that apply to every command
data CommonFlag = HelpFlag | ListOptionsFlag

commonFlags :: ShowOrParseArgs -> [GetOpt.OptDescr CommonFlag]
commonFlags :: ShowOrParseArgs -> [OptDescr CommonFlag]
commonFlags ShowOrParseArgs
showOrParseArgs = case ShowOrParseArgs
showOrParseArgs of
  ShowOrParseArgs
ShowArgs -> [OptDescr CommonFlag
help]
  ShowOrParseArgs
ParseArgs -> [OptDescr CommonFlag
help, OptDescr CommonFlag
list]
  where
    help :: OptDescr CommonFlag
help =
      String
-> LFlags -> ArgDescr CommonFlag -> String -> OptDescr CommonFlag
forall a. String -> LFlags -> ArgDescr a -> String -> OptDescr a
GetOpt.Option
        String
helpShortFlags
        [String
"help"]
        (CommonFlag -> ArgDescr CommonFlag
forall a. a -> ArgDescr a
GetOpt.NoArg CommonFlag
HelpFlag)
        String
"Show this help text"
    helpShortFlags :: String
helpShortFlags = case ShowOrParseArgs
showOrParseArgs of
      ShowOrParseArgs
ShowArgs -> [Char
'h']
      ShowOrParseArgs
ParseArgs -> [Char
'h', Char
'?']
    list :: OptDescr CommonFlag
list =
      String
-> LFlags -> ArgDescr CommonFlag -> String -> OptDescr CommonFlag
forall a. String -> LFlags -> ArgDescr a -> String -> OptDescr a
GetOpt.Option
        []
        [String
"list-options"]
        (CommonFlag -> ArgDescr CommonFlag
forall a. a -> ArgDescr a
GetOpt.NoArg CommonFlag
ListOptionsFlag)
        String
"Print a list of command line flags"

addCommonFlags
  :: ShowOrParseArgs
  -> [GetOpt.OptDescr a]
  -> [GetOpt.OptDescr (Either CommonFlag a)]
addCommonFlags :: forall a.
ShowOrParseArgs -> [OptDescr a] -> [OptDescr (Either CommonFlag a)]
addCommonFlags ShowOrParseArgs
showOrParseArgs [OptDescr a]
options =
  (OptDescr CommonFlag -> OptDescr (Either CommonFlag a))
-> [OptDescr CommonFlag] -> [OptDescr (Either CommonFlag a)]
forall a b. (a -> b) -> [a] -> [b]
map ((CommonFlag -> Either CommonFlag a)
-> OptDescr CommonFlag -> OptDescr (Either CommonFlag a)
forall a b. (a -> b) -> OptDescr a -> OptDescr b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CommonFlag -> Either CommonFlag a
forall a b. a -> Either a b
Left) (ShowOrParseArgs -> [OptDescr CommonFlag]
commonFlags ShowOrParseArgs
showOrParseArgs)
    [OptDescr (Either CommonFlag a)]
-> [OptDescr (Either CommonFlag a)]
-> [OptDescr (Either CommonFlag a)]
forall a. [a] -> [a] -> [a]
++ (OptDescr a -> OptDescr (Either CommonFlag a))
-> [OptDescr a] -> [OptDescr (Either CommonFlag a)]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> Either CommonFlag a)
-> OptDescr a -> OptDescr (Either CommonFlag a)
forall a b. (a -> b) -> OptDescr a -> OptDescr b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either CommonFlag a
forall a b. b -> Either a b
Right) [OptDescr a]
options

-- | Parse a bunch of command line arguments
commandParseArgs
  :: CommandUI flags
  -> Bool
  -- ^ Is the command a global or subcommand?
  -> [String]
  -> CommandParse (flags -> flags, [String])
commandParseArgs :: forall flags.
CommandUI flags
-> Bool -> LFlags -> CommandParse (flags -> flags, LFlags)
commandParseArgs CommandUI flags
command Bool
global LFlags
args =
  let options :: [OptDescr (Either CommonFlag (flags -> flags))]
options =
        ShowOrParseArgs
-> [OptDescr (flags -> flags)]
-> [OptDescr (Either CommonFlag (flags -> flags))]
forall a.
ShowOrParseArgs -> [OptDescr a] -> [OptDescr (Either CommonFlag a)]
addCommonFlags ShowOrParseArgs
ParseArgs ([OptDescr (flags -> flags)]
 -> [OptDescr (Either CommonFlag (flags -> flags))])
-> [OptDescr (flags -> flags)]
-> [OptDescr (Either CommonFlag (flags -> flags))]
forall a b. (a -> b) -> a -> b
$
          ShowOrParseArgs -> CommandUI flags -> [OptDescr (flags -> flags)]
forall flags.
ShowOrParseArgs -> CommandUI flags -> [OptDescr (flags -> flags)]
commandGetOpts ShowOrParseArgs
ParseArgs CommandUI flags
command
      order :: ArgOrder a
order
        | Bool
global = ArgOrder a
forall a. ArgOrder a
GetOpt.RequireOrder
        | Bool
otherwise = ArgOrder a
forall a. ArgOrder a
GetOpt.Permute
   in case ArgOrder (Either CommonFlag (flags -> flags))
-> [OptDescr (Either CommonFlag (flags -> flags))]
-> LFlags
-> ([Either CommonFlag (flags -> flags)], LFlags, LFlags, LFlags)
forall a.
ArgOrder a
-> [OptDescr a] -> LFlags -> ([a], LFlags, LFlags, LFlags)
GetOpt.getOpt' ArgOrder (Either CommonFlag (flags -> flags))
forall a. ArgOrder a
order [OptDescr (Either CommonFlag (flags -> flags))]
options LFlags
args of
        ([Either CommonFlag (flags -> flags)]
flags, LFlags
_, LFlags
_, LFlags
_)
          | (Either CommonFlag (flags -> flags) -> Bool)
-> [Either CommonFlag (flags -> flags)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Either CommonFlag (flags -> flags) -> Bool
forall {b}. Either CommonFlag b -> Bool
listFlag [Either CommonFlag (flags -> flags)]
flags -> LFlags -> CommandParse (flags -> flags, LFlags)
forall flags. LFlags -> CommandParse flags
CommandList (CommandUI flags -> LFlags
forall flags. CommandUI flags -> LFlags
commandListOptions CommandUI flags
command)
          | (Either CommonFlag (flags -> flags) -> Bool)
-> [Either CommonFlag (flags -> flags)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Either CommonFlag (flags -> flags) -> Bool
forall {b}. Either CommonFlag b -> Bool
helpFlag [Either CommonFlag (flags -> flags)]
flags -> (String -> String) -> CommandParse (flags -> flags, LFlags)
forall flags. (String -> String) -> CommandParse flags
CommandHelp (CommandUI flags -> String -> String
forall flags. CommandUI flags -> String -> String
commandHelp CommandUI flags
command)
          where
            listFlag :: Either CommonFlag b -> Bool
listFlag (Left CommonFlag
ListOptionsFlag) = Bool
True; listFlag Either CommonFlag b
_ = Bool
False
            helpFlag :: Either CommonFlag b -> Bool
helpFlag (Left CommonFlag
HelpFlag) = Bool
True; helpFlag Either CommonFlag b
_ = Bool
False
        ([Either CommonFlag (flags -> flags)]
flags, LFlags
opts, LFlags
opts', [])
          | Bool
global Bool -> Bool -> Bool
|| LFlags -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null LFlags
opts' -> (flags -> flags, LFlags) -> CommandParse (flags -> flags, LFlags)
forall flags. flags -> CommandParse flags
CommandReadyToGo ([Either CommonFlag (flags -> flags)] -> flags -> flags
forall {a} {c}. [Either a (c -> c)] -> c -> c
accum [Either CommonFlag (flags -> flags)]
flags, LFlags -> LFlags -> LFlags
forall a. [a] -> [a] -> [a]
mix LFlags
opts LFlags
opts')
          | Bool
otherwise -> LFlags -> CommandParse (flags -> flags, LFlags)
forall flags. LFlags -> CommandParse flags
CommandErrors (LFlags -> LFlags
unrecognised LFlags
opts')
        ([Either CommonFlag (flags -> flags)]
_, LFlags
_, LFlags
_, LFlags
errs) -> LFlags -> CommandParse (flags -> flags, LFlags)
forall flags. LFlags -> CommandParse flags
CommandErrors LFlags
errs
  where
    -- Note: It is crucial to use reverse function composition here or to
    -- reverse the flags here as we want to process the flags left to right
    -- but data flow in function composition is right to left.
    accum :: [Either a (c -> c)] -> c -> c
accum [Either a (c -> c)]
flags = ((c -> c) -> (c -> c) -> c -> c) -> (c -> c) -> [c -> c] -> c -> c
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (((c -> c) -> (c -> c) -> c -> c) -> (c -> c) -> (c -> c) -> c -> c
forall a b c. (a -> b -> c) -> b -> a -> c
flip (c -> c) -> (c -> c) -> c -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)) c -> c
forall a. a -> a
id [c -> c
f | Right c -> c
f <- [Either a (c -> c)]
flags]
    unrecognised :: LFlags -> LFlags
unrecognised LFlags
opts =
      [ String
"unrecognized "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ (CommandUI flags -> String
forall flags. CommandUI flags -> String
commandName CommandUI flags
command)
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" option `"
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
opt
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'\n"
      | String
opt <- LFlags
opts
      ]
    -- For unrecognised global flags we put them in the position just after
    -- the command, if there is one. This gives us a chance to parse them
    -- as sub-command rather than global flags.
    mix :: [a] -> [a] -> [a]
mix [] [a]
ys = [a]
ys
    mix (a
x : [a]
xs) [a]
ys = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
ys [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
xs

data CommandParse flags
  = CommandHelp (String -> String)
  | CommandList [String]
  | CommandErrors [String]
  | CommandReadyToGo flags
instance Functor CommandParse where
  fmap :: forall a b. (a -> b) -> CommandParse a -> CommandParse b
fmap a -> b
_ (CommandHelp String -> String
help) = (String -> String) -> CommandParse b
forall flags. (String -> String) -> CommandParse flags
CommandHelp String -> String
help
  fmap a -> b
_ (CommandList LFlags
opts) = LFlags -> CommandParse b
forall flags. LFlags -> CommandParse flags
CommandList LFlags
opts
  fmap a -> b
_ (CommandErrors LFlags
errs) = LFlags -> CommandParse b
forall flags. LFlags -> CommandParse flags
CommandErrors LFlags
errs
  fmap a -> b
f (CommandReadyToGo a
flags) = b -> CommandParse b
forall flags. flags -> CommandParse flags
CommandReadyToGo (a -> b
f a
flags)

data CommandType = NormalCommand | HiddenCommand
data Command action
  = Command String String ([String] -> CommandParse action) CommandType

-- | Mark command as hidden. Hidden commands don't show up in the 'progname
-- help' or 'progname --help' output.
hiddenCommand :: Command action -> Command action
hiddenCommand :: forall action. Command action -> Command action
hiddenCommand (Command String
name String
synopsys LFlags -> CommandParse action
f CommandType
_cmdType) =
  String
-> String
-> (LFlags -> CommandParse action)
-> CommandType
-> Command action
forall action.
String
-> String
-> (LFlags -> CommandParse action)
-> CommandType
-> Command action
Command String
name String
synopsys LFlags -> CommandParse action
f CommandType
HiddenCommand

commandAddAction
  :: CommandUI flags
  -> (flags -> [String] -> action)
  -> Command action
commandAddAction :: forall flags action.
CommandUI flags -> (flags -> LFlags -> action) -> Command action
commandAddAction CommandUI flags
command flags -> LFlags -> action
action =
  String
-> String
-> (LFlags -> CommandParse action)
-> CommandType
-> Command action
forall action.
String
-> String
-> (LFlags -> CommandParse action)
-> CommandType
-> Command action
Command
    (CommandUI flags -> String
forall flags. CommandUI flags -> String
commandName CommandUI flags
command)
    (CommandUI flags -> String
forall flags. CommandUI flags -> String
commandSynopsis CommandUI flags
command)
    (((flags -> flags, LFlags) -> action)
-> CommandParse (flags -> flags, LFlags) -> CommandParse action
forall a b. (a -> b) -> CommandParse a -> CommandParse b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((flags -> flags) -> LFlags -> action)
-> (flags -> flags, LFlags) -> action
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (flags -> flags) -> LFlags -> action
applyDefaultArgs) (CommandParse (flags -> flags, LFlags) -> CommandParse action)
-> (LFlags -> CommandParse (flags -> flags, LFlags))
-> LFlags
-> CommandParse action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommandUI flags
-> Bool -> LFlags -> CommandParse (flags -> flags, LFlags)
forall flags.
CommandUI flags
-> Bool -> LFlags -> CommandParse (flags -> flags, LFlags)
commandParseArgs CommandUI flags
command Bool
False)
    CommandType
NormalCommand
  where
    applyDefaultArgs :: (flags -> flags) -> LFlags -> action
applyDefaultArgs flags -> flags
mkflags LFlags
args =
      let flags :: flags
flags = flags -> flags
mkflags (CommandUI flags -> flags
forall flags. CommandUI flags -> flags
commandDefaultFlags CommandUI flags
command)
       in flags -> LFlags -> action
action flags
flags LFlags
args

-- Print suggested command if edit distance is < 5
badCommand :: [Command action] -> String -> CommandParse a
badCommand :: forall action a. [Command action] -> String -> CommandParse a
badCommand [Command action]
commands' String
cname =
  case LFlags
eDists of
    [] -> LFlags -> CommandParse a
forall flags. LFlags -> CommandParse flags
CommandErrors [String
unErr]
    (String
s : LFlags
_) ->
      LFlags -> CommandParse a
forall flags. LFlags -> CommandParse flags
CommandErrors
        [ String
unErr
        , String
"Maybe you meant `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"`?\n"
        ]
  where
    eDists :: LFlags
eDists =
      ((String, Int) -> String) -> [(String, Int)] -> LFlags
forall a b. (a -> b) -> [a] -> [b]
map (String, Int) -> String
forall a b. (a, b) -> a
fst ([(String, Int)] -> LFlags)
-> ([(String, Int)] -> [(String, Int)])
-> [(String, Int)]
-> LFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, Int) -> (String, Int) -> Ordering)
-> [(String, Int)] -> [(String, Int)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
List.sortBy (((String, Int) -> Int)
-> (String, Int) -> (String, Int) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (String, Int) -> Int
forall a b. (a, b) -> b
snd) ([(String, Int)] -> LFlags) -> [(String, Int)] -> LFlags
forall a b. (a -> b) -> a -> b
$
        [ (String
cname', Int
dist)
        | -- Note that this is not commandNames, so close suggestions will show
        -- hidden commands
        (Command String
cname' String
_ LFlags -> CommandParse action
_ CommandType
_) <- [Command action]
commands'
        , let dist :: Int
dist = String -> String -> Int
forall a. Eq a => [a] -> [a] -> Int
editDistance String
cname' String
cname
        , Int
dist Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
5
        ]
    unErr :: String
unErr = String
"unrecognised command: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (try --help)"

commandsRun
  :: CommandUI a
  -> [Command action]
  -> [String]
  -> IO (CommandParse (a, CommandParse action))
commandsRun :: forall a action.
CommandUI a
-> [Command action]
-> LFlags
-> IO (CommandParse (a, CommandParse action))
commandsRun CommandUI a
globalCommand [Command action]
commands LFlags
args =
  CommandUI a
-> [Command action]
-> ([Command action]
    -> String -> LFlags -> IO (CommandParse action))
-> LFlags
-> IO (CommandParse (a, CommandParse action))
forall a action.
CommandUI a
-> [Command action]
-> ([Command action]
    -> String -> LFlags -> IO (CommandParse action))
-> LFlags
-> IO (CommandParse (a, CommandParse action))
commandsRunWithFallback CommandUI a
globalCommand [Command action]
commands [Command action] -> String -> LFlags -> IO (CommandParse action)
forall action.
[Command action] -> String -> LFlags -> IO (CommandParse action)
defaultCommandFallback LFlags
args

defaultCommandFallback
  :: [Command action]
  -> String
  -> [String]
  -> IO (CommandParse action)
defaultCommandFallback :: forall action.
[Command action] -> String -> LFlags -> IO (CommandParse action)
defaultCommandFallback [Command action]
commands' String
name LFlags
_cmdArgs = CommandParse action -> IO (CommandParse action)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CommandParse action -> IO (CommandParse action))
-> CommandParse action -> IO (CommandParse action)
forall a b. (a -> b) -> a -> b
$ [Command action] -> String -> CommandParse action
forall action a. [Command action] -> String -> CommandParse a
badCommand [Command action]
commands' String
name

commandsRunWithFallback
  :: CommandUI a
  -> [Command action]
  -> ([Command action] -> String -> [String] -> IO (CommandParse action))
  -> [String]
  -> IO (CommandParse (a, CommandParse action))
commandsRunWithFallback :: forall a action.
CommandUI a
-> [Command action]
-> ([Command action]
    -> String -> LFlags -> IO (CommandParse action))
-> LFlags
-> IO (CommandParse (a, CommandParse action))
commandsRunWithFallback CommandUI a
globalCommand [Command action]
commands [Command action] -> String -> LFlags -> IO (CommandParse action)
defaultCommand LFlags
args =
  case CommandUI a -> Bool -> LFlags -> CommandParse (a -> a, LFlags)
forall flags.
CommandUI flags
-> Bool -> LFlags -> CommandParse (flags -> flags, LFlags)
commandParseArgs CommandUI a
globalCommand Bool
True LFlags
args of
    CommandHelp String -> String
help -> CommandParse (a, CommandParse action)
-> IO (CommandParse (a, CommandParse action))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CommandParse (a, CommandParse action)
 -> IO (CommandParse (a, CommandParse action)))
-> CommandParse (a, CommandParse action)
-> IO (CommandParse (a, CommandParse action))
forall a b. (a -> b) -> a -> b
$ (String -> String) -> CommandParse (a, CommandParse action)
forall flags. (String -> String) -> CommandParse flags
CommandHelp String -> String
help
    CommandList LFlags
opts -> CommandParse (a, CommandParse action)
-> IO (CommandParse (a, CommandParse action))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CommandParse (a, CommandParse action)
 -> IO (CommandParse (a, CommandParse action)))
-> CommandParse (a, CommandParse action)
-> IO (CommandParse (a, CommandParse action))
forall a b. (a -> b) -> a -> b
$ LFlags -> CommandParse (a, CommandParse action)
forall flags. LFlags -> CommandParse flags
CommandList (LFlags
opts LFlags -> LFlags -> LFlags
forall a. [a] -> [a] -> [a]
++ LFlags
commandNames)
    CommandErrors LFlags
errs -> CommandParse (a, CommandParse action)
-> IO (CommandParse (a, CommandParse action))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CommandParse (a, CommandParse action)
 -> IO (CommandParse (a, CommandParse action)))
-> CommandParse (a, CommandParse action)
-> IO (CommandParse (a, CommandParse action))
forall a b. (a -> b) -> a -> b
$ LFlags -> CommandParse (a, CommandParse action)
forall flags. LFlags -> CommandParse flags
CommandErrors LFlags
errs
    CommandReadyToGo (a -> a
mkflags, LFlags
args') -> case LFlags
args' of
      (String
"help" : LFlags
cmdArgs) -> a -> LFlags -> IO (CommandParse (a, CommandParse action))
forall {a}.
a -> LFlags -> IO (CommandParse (a, CommandParse action))
handleHelpCommand a
flags LFlags
cmdArgs
      (String
name : LFlags
cmdArgs) -> case String -> [Command action]
lookupCommand String
name of
        [Command String
_ String
_ LFlags -> CommandParse action
action CommandType
_] ->
          CommandParse (a, CommandParse action)
-> IO (CommandParse (a, CommandParse action))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CommandParse (a, CommandParse action)
 -> IO (CommandParse (a, CommandParse action)))
-> CommandParse (a, CommandParse action)
-> IO (CommandParse (a, CommandParse action))
forall a b. (a -> b) -> a -> b
$ (a, CommandParse action) -> CommandParse (a, CommandParse action)
forall flags. flags -> CommandParse flags
CommandReadyToGo (a
flags, LFlags -> CommandParse action
action LFlags
cmdArgs)
        [Command action]
_ -> do
          final_cmd <- [Command action] -> String -> LFlags -> IO (CommandParse action)
defaultCommand [Command action]
commands' String
name LFlags
cmdArgs
          return $ CommandReadyToGo (flags, final_cmd)
      [] -> CommandParse (a, CommandParse action)
-> IO (CommandParse (a, CommandParse action))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CommandParse (a, CommandParse action)
 -> IO (CommandParse (a, CommandParse action)))
-> CommandParse (a, CommandParse action)
-> IO (CommandParse (a, CommandParse action))
forall a b. (a -> b) -> a -> b
$ (a, CommandParse action) -> CommandParse (a, CommandParse action)
forall flags. flags -> CommandParse flags
CommandReadyToGo (a
flags, CommandParse action
forall {flags}. CommandParse flags
noCommand)
      where
        flags :: a
flags = a -> a
mkflags (CommandUI a -> a
forall flags. CommandUI flags -> flags
commandDefaultFlags CommandUI a
globalCommand)
  where
    lookupCommand :: String -> [Command action]
lookupCommand String
cname =
      [ Command action
cmd | cmd :: Command action
cmd@(Command String
cname' String
_ LFlags -> CommandParse action
_ CommandType
_) <- [Command action]
commands', String
cname' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
cname
      ]

    noCommand :: CommandParse flags
noCommand = LFlags -> CommandParse flags
forall flags. LFlags -> CommandParse flags
CommandErrors [String
"no command given (try --help)\n"]

    commands' :: [Command action]
commands' = [Command action]
commands [Command action] -> [Command action] -> [Command action]
forall a. [a] -> [a] -> [a]
++ [CommandUI () -> (() -> LFlags -> action) -> Command action
forall flags action.
CommandUI flags -> (flags -> LFlags -> action) -> Command action
commandAddAction CommandUI ()
helpCommandUI () -> LFlags -> action
forall a. HasCallStack => a
undefined]
    commandNames :: LFlags
commandNames = [String
name | (Command String
name String
_ LFlags -> CommandParse action
_ CommandType
NormalCommand) <- [Command action]
commands']

    -- A bit of a hack: support "prog help" as a synonym of "prog --help"
    -- furthermore, support "prog help command" as "prog command --help"
    handleHelpCommand :: a -> LFlags -> IO (CommandParse (a, CommandParse action))
handleHelpCommand a
flags LFlags
cmdArgs =
      case CommandUI () -> Bool -> LFlags -> CommandParse (() -> (), LFlags)
forall flags.
CommandUI flags
-> Bool -> LFlags -> CommandParse (flags -> flags, LFlags)
commandParseArgs CommandUI ()
helpCommandUI Bool
True LFlags
cmdArgs of
        CommandHelp String -> String
help -> CommandParse (a, CommandParse action)
-> IO (CommandParse (a, CommandParse action))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CommandParse (a, CommandParse action)
 -> IO (CommandParse (a, CommandParse action)))
-> CommandParse (a, CommandParse action)
-> IO (CommandParse (a, CommandParse action))
forall a b. (a -> b) -> a -> b
$ (String -> String) -> CommandParse (a, CommandParse action)
forall flags. (String -> String) -> CommandParse flags
CommandHelp String -> String
help
        CommandList LFlags
list -> CommandParse (a, CommandParse action)
-> IO (CommandParse (a, CommandParse action))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CommandParse (a, CommandParse action)
 -> IO (CommandParse (a, CommandParse action)))
-> CommandParse (a, CommandParse action)
-> IO (CommandParse (a, CommandParse action))
forall a b. (a -> b) -> a -> b
$ LFlags -> CommandParse (a, CommandParse action)
forall flags. LFlags -> CommandParse flags
CommandList (LFlags
list LFlags -> LFlags -> LFlags
forall a. [a] -> [a] -> [a]
++ LFlags
commandNames)
        CommandErrors LFlags
_ -> CommandParse (a, CommandParse action)
-> IO (CommandParse (a, CommandParse action))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CommandParse (a, CommandParse action)
 -> IO (CommandParse (a, CommandParse action)))
-> CommandParse (a, CommandParse action)
-> IO (CommandParse (a, CommandParse action))
forall a b. (a -> b) -> a -> b
$ (String -> String) -> CommandParse (a, CommandParse action)
forall flags. (String -> String) -> CommandParse flags
CommandHelp String -> String
globalHelp
        CommandReadyToGo (() -> ()
_, []) -> CommandParse (a, CommandParse action)
-> IO (CommandParse (a, CommandParse action))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CommandParse (a, CommandParse action)
 -> IO (CommandParse (a, CommandParse action)))
-> CommandParse (a, CommandParse action)
-> IO (CommandParse (a, CommandParse action))
forall a b. (a -> b) -> a -> b
$ (String -> String) -> CommandParse (a, CommandParse action)
forall flags. (String -> String) -> CommandParse flags
CommandHelp String -> String
globalHelp
        CommandReadyToGo (() -> ()
_, (String
name : LFlags
cmdArgs')) ->
          case String -> [Command action]
lookupCommand String
name of
            [Command String
_ String
_ LFlags -> CommandParse action
action CommandType
_] ->
              case LFlags -> CommandParse action
action (String
"--help" String -> LFlags -> LFlags
forall a. a -> [a] -> [a]
: LFlags
cmdArgs') of
                CommandHelp String -> String
help -> CommandParse (a, CommandParse action)
-> IO (CommandParse (a, CommandParse action))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CommandParse (a, CommandParse action)
 -> IO (CommandParse (a, CommandParse action)))
-> CommandParse (a, CommandParse action)
-> IO (CommandParse (a, CommandParse action))
forall a b. (a -> b) -> a -> b
$ (String -> String) -> CommandParse (a, CommandParse action)
forall flags. (String -> String) -> CommandParse flags
CommandHelp String -> String
help
                CommandList LFlags
_ -> CommandParse (a, CommandParse action)
-> IO (CommandParse (a, CommandParse action))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CommandParse (a, CommandParse action)
 -> IO (CommandParse (a, CommandParse action)))
-> CommandParse (a, CommandParse action)
-> IO (CommandParse (a, CommandParse action))
forall a b. (a -> b) -> a -> b
$ LFlags -> CommandParse (a, CommandParse action)
forall flags. LFlags -> CommandParse flags
CommandList []
                CommandParse action
_ -> CommandParse (a, CommandParse action)
-> IO (CommandParse (a, CommandParse action))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CommandParse (a, CommandParse action)
 -> IO (CommandParse (a, CommandParse action)))
-> CommandParse (a, CommandParse action)
-> IO (CommandParse (a, CommandParse action))
forall a b. (a -> b) -> a -> b
$ (String -> String) -> CommandParse (a, CommandParse action)
forall flags. (String -> String) -> CommandParse flags
CommandHelp String -> String
globalHelp
            [Command action]
_ -> do
              fall_back <- [Command action] -> String -> LFlags -> IO (CommandParse action)
defaultCommand [Command action]
commands' String
name (String
"--help" String -> LFlags -> LFlags
forall a. a -> [a] -> [a]
: LFlags
cmdArgs')
              return $ CommandReadyToGo (flags, fall_back)
      where
        globalHelp :: String -> String
globalHelp = CommandUI a -> String -> String
forall flags. CommandUI flags -> String -> String
commandHelp CommandUI a
globalCommand

-- Levenshtein distance, from https://wiki.haskell.org/Edit_distance
-- (Author: JeanPhilippeBernardy, Simple Permissive Licence)
editDistance :: Eq a => [a] -> [a] -> Int
editDistance :: forall a. Eq a => [a] -> [a] -> Int
editDistance [a]
xs [a]
ys = Array (Int, Int) Int
table Array (Int, Int) Int -> (Int, Int) -> Int
forall i e. Ix i => Array i e -> i -> e
Array.! (Int
m, Int
n)
  where
    (Int
m, Int
n) = ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs, [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
ys)
    x :: Array Int a
x = (Int, Int) -> [(Int, a)] -> Array Int a
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
Array.array (Int
1, Int
m) ([Int] -> [a] -> [(Int, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ..] [a]
xs)
    y :: Array Int a
y = (Int, Int) -> [(Int, a)] -> Array Int a
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
Array.array (Int
1, Int
n) ([Int] -> [a] -> [(Int, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ..] [a]
ys)

    table :: Array.Array (Int, Int) Int
    table :: Array (Int, Int) Int
table = ((Int, Int), (Int, Int))
-> [((Int, Int), Int)] -> Array (Int, Int) Int
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
Array.array ((Int, Int), (Int, Int))
bnds [((Int, Int)
ij, (Int, Int) -> Int
dist (Int, Int)
ij) | (Int, Int)
ij <- ((Int, Int), (Int, Int)) -> [(Int, Int)]
forall a. Ix a => (a, a) -> [a]
Array.range ((Int, Int), (Int, Int))
bnds]
    bnds :: ((Int, Int), (Int, Int))
bnds = ((Int
0, Int
0), (Int
m, Int
n))

    dist :: (Int, Int) -> Int
dist (Int
0, Int
j) = Int
j
    dist (Int
i, Int
0) = Int
i
    dist (Int
i, Int
j) =
      [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum
        [ Array (Int, Int) Int
table Array (Int, Int) Int -> (Int, Int) -> Int
forall i e. Ix i => Array i e -> i -> e
Array.! (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Int
j) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
        , Array (Int, Int) Int
table Array (Int, Int) Int -> (Int, Int) -> Int
forall i e. Ix i => Array i e -> i -> e
Array.! (Int
i, Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
        , if Array Int a
x Array Int a -> Int -> a
forall i e. Ix i => Array i e -> i -> e
Array.! Int
i a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== Array Int a
y Array Int a -> Int -> a
forall i e. Ix i => Array i e -> i -> e
Array.! Int
j
            then Array (Int, Int) Int
table Array (Int, Int) Int -> (Int, Int) -> Int
forall i e. Ix i => Array i e -> i -> e
Array.! (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
            else Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Array (Int, Int) Int
table Array (Int, Int) Int -> (Int, Int) -> Int
forall i e. Ix i => Array i e -> i -> e
Array.! (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
        ]

-- | Utility function, many commands do not accept additional flags. This
-- action fails with a helpful error message if the user supplies any extra.
noExtraFlags :: [String] -> IO ()
noExtraFlags :: LFlags -> IO ()
noExtraFlags [] = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
noExtraFlags LFlags
extraFlags =
  String -> IO ()
forall a. String -> IO a
dieNoVerbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Unrecognised flags: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> LFlags -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " LFlags
extraFlags

-- TODO: eliminate this function and turn it into a variant on commandAddAction
--      instead like commandAddActionNoArgs that doesn't supply the [String]

-- | Helper function for creating globalCommand description
getNormalCommandDescriptions :: [Command action] -> [(String, String)]
getNormalCommandDescriptions :: forall action. [Command action] -> [(String, String)]
getNormalCommandDescriptions [Command action]
cmds =
  [ (String
name, String
description)
  | Command String
name String
description LFlags -> CommandParse action
_ CommandType
NormalCommand <- [Command action]
cmds
  ]

helpCommandUI :: CommandUI ()
helpCommandUI :: CommandUI ()
helpCommandUI =
  ( String
-> String
-> LFlags
-> ()
-> (ShowOrParseArgs -> [OptionField ()])
-> CommandUI ()
forall flags.
String
-> String
-> LFlags
-> flags
-> (ShowOrParseArgs -> [OptionField flags])
-> CommandUI flags
mkCommandUI
      String
"help"
      String
"Help about commands."
      [String
"[FLAGS]", String
"COMMAND [FLAGS]"]
      ()
      ([OptionField ()] -> ShowOrParseArgs -> [OptionField ()]
forall a b. a -> b -> a
const [])
  )
    { commandNotes = Just $ \String
pname ->
        String
"Examples:\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pname
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" help help\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"    Oh, apparently you already know this.\n"
    }

-- | wraps a @CommandUI@ together with a function that turns it into a @Command@.
-- By hiding the type of flags for the UI allows construction of a list of all UIs at the
-- top level of the program. That list can then be used for generation of manual page
-- as well as for executing the selected command.
data CommandSpec action
  = forall flags. CommandSpec (CommandUI flags) (CommandUI flags -> Command action) CommandType

commandFromSpec :: CommandSpec a -> Command a
commandFromSpec :: forall a. CommandSpec a -> Command a
commandFromSpec (CommandSpec CommandUI flags
ui CommandUI flags -> Command a
action CommandType
_) = CommandUI flags -> Command a
action CommandUI flags
ui