{-# 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,

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

-- ** Constructing Option Fields
  option, multiOption,

-- ** Liftings & Projections
  liftOption,

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

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

  ) where

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

import qualified Distribution.GetOpt as GetOpt
import Distribution.ReadE
import Distribution.Simple.Utils


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

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 {
  OptionField a -> String
optionName        :: Name,
  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)) (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.
option :: SFlags -> LFlags -> Description -> get -> set -> MkOptDescr get set a
          -> OptionField a
option :: 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 :: 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.
reqArg :: Monoid b => ArgPlaceHolder -> ReadE b -> (b -> [String])
                   -> MkOptDescr (a -> b) (b -> a -> a) a
reqArg :: 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 (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 -> b -> (b -> [Maybe String])
                   -> MkOptDescr (a -> b) (b -> a -> a) a
optArg :: String
-> ReadE b
-> b
-> (b -> [Maybe String])
-> MkOptDescr (a -> b) (b -> a -> a) a
optArg String
ad ReadE b
mkflag b
def b -> [Maybe String]
showflag String
sf LFlags
lf String
d a -> b
get b -> a -> a
set  =
  String
-> OptFlags
-> String
-> ReadE (a -> a)
-> (a -> a)
-> (a -> [Maybe String])
-> OptDescr a
forall a.
String
-> OptFlags
-> String
-> ReadE (a -> a)
-> (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 (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)
               (\a
b ->          b -> a -> a
set (a -> b
get a
b b -> b -> b
forall a. Monoid a => a -> a -> a
`mappend` b
def) 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' :: 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' :: 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
-> b
-> (b -> [Maybe String])
-> MkOptDescr (a -> b) (b -> a -> a) a
forall b a.
Monoid b =>
String
-> ReadE b
-> 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)) b
def b -> [Maybe String]
showflag
      where def :: b
def = Maybe String -> b
mkflag Maybe String
forall a. Maybe a
Nothing

noArg :: (Eq b) => b -> MkOptDescr (a -> b) (b -> a -> a) a
noArg :: 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 :: (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' :: (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 :: [(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 :: 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 (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 :: 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 :: 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 -> a -> a) -> String -> ArgDescr (a -> a)
forall a. (String -> a) -> String -> ArgDescr a
GetOpt.ReqArg String -> a -> a
set' String
arg_desc) String
d]
             where set' :: String -> a -> a
set' = ReadE (a -> a) -> String -> a -> a
forall a. ReadE a -> String -> a
readEOrFail ReadE (a -> a)
set
    optDescrToGetOpt (OptArg String
d (String
cs,LFlags
ss) String
arg_desc ReadE (a -> a)
set 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 ((Maybe String -> a -> a) -> String -> ArgDescr (a -> a)
forall a. (Maybe String -> a) -> String -> ArgDescr a
GetOpt.OptArg Maybe String -> a -> a
set' String
arg_desc) String
d]
             where set' :: Maybe String -> a -> a
set' Maybe String
Nothing    = a -> a
def
                   set' (Just String
txt) = ReadE (a -> a) -> String -> a -> a
forall a. ReadE a -> String -> a
readEOrFail 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 :: 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 :: (b -> a) -> (a -> b -> b) -> OptionField a -> OptionField b
liftOption b -> a
get' a -> b -> b
set' OptionField a
opt =
  OptionField a
opt { optionDescr :: [OptDescr b]
optionDescr = (b -> a) -> (a -> b -> b) -> OptDescr a -> OptDescr b
forall b a. (b -> a) -> (a -> b -> b) -> OptDescr a -> OptDescr b
liftOptDescr b -> a
get' a -> b -> b
set' (OptDescr a -> OptDescr b) -> [OptDescr a] -> [OptDescr b]
forall a b. (a -> b) -> [a] -> [b]
`map` OptionField a -> [OptDescr a]
forall a. OptionField a -> [OptDescr a]
optionDescr OptionField a
opt}


liftOptDescr :: (b -> a) -> (a -> (b -> b)) -> OptDescr a -> OptDescr b
liftOptDescr :: (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 a -> a
def a -> [Maybe String]
get) =
    String
-> OptFlags
-> String
-> ReadE (b -> b)
-> (b -> b)
-> (b -> [Maybe String])
-> OptDescr b
forall a.
String
-> OptFlags
-> String
-> ReadE (a -> a)
-> (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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ReadE (a -> a)
set)
    ((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
def) (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 (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 :: (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 :: 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 :: 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
lfString -> 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)
_ a -> a
_ a -> [Maybe String]
showflag)
      = [ case Maybe String
flag of
            Just String
s  -> String
"--"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
lfString -> 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 :: 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 :: 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 :: String
-> String
-> LFlags
-> flags
-> (ShowOrParseArgs -> [OptionField flags])
-> CommandUI flags
mkCommandUI String
name String
synopsis LFlags
usages flags
flags ShowOrParseArgs -> [OptionField flags]
options = CommandUI :: forall flags.
String
-> String
-> (String -> String)
-> Maybe (String -> String)
-> Maybe (String -> String)
-> flags
-> (ShowOrParseArgs -> [OptionField flags])
-> CommandUI flags
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 :: 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 t a. (t -> a) -> OptDescr t -> OptDescr a
fmapOptDesc 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 t a. (t -> a) -> OptDescr t -> OptDescr a
fmapOptDesc a -> Either CommonFlag a
forall a b. b -> Either a b
Right) [OptDescr a]
options
  where fmapOptDesc :: (t -> a) -> OptDescr t -> OptDescr a
fmapOptDesc t -> a
f (GetOpt.Option String
s LFlags
l ArgDescr t
d String
m) =
                       String -> LFlags -> ArgDescr a -> String -> OptDescr a
forall a. String -> LFlags -> ArgDescr a -> String -> OptDescr a
GetOpt.Option String
s LFlags
l ((t -> a) -> ArgDescr t -> ArgDescr a
forall t a. (t -> a) -> ArgDescr t -> ArgDescr a
fmapArgDesc t -> a
f ArgDescr t
d) String
m
        fmapArgDesc :: (t -> a) -> ArgDescr t -> ArgDescr a
fmapArgDesc t -> a
f (GetOpt.NoArg t
a)    = a -> ArgDescr a
forall a. a -> ArgDescr a
GetOpt.NoArg (t -> a
f t
a)
        fmapArgDesc t -> a
f (GetOpt.ReqArg String -> t
s String
d) = (String -> a) -> String -> ArgDescr a
forall a. (String -> a) -> String -> ArgDescr a
GetOpt.ReqArg (t -> a
f (t -> a) -> (String -> t) -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> t
s) String
d
        fmapArgDesc t -> a
f (GetOpt.OptArg Maybe String -> t
s String
d) = (Maybe String -> a) -> String -> ArgDescr a
forall a. (Maybe String -> a) -> String -> ArgDescr a
GetOpt.OptArg (t -> a
f (t -> a) -> (Maybe String -> t) -> Maybe String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe String -> t
s) String
d

-- | Parse a bunch of command line arguments
--
commandParseArgs :: CommandUI flags
                 -> Bool      -- ^ Is the command a global or subcommand?
                 -> [String]
                 -> CommandParse (flags -> flags, [String])
commandParseArgs :: 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 (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 (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
xa -> [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 :: (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 :: 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 :: 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 (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

commandsRun :: CommandUI a
            -> [Command action]
            -> [String]
            -> CommandParse (a, CommandParse action)
commandsRun :: CommandUI a
-> [Command action]
-> LFlags
-> CommandParse (a, CommandParse action)
commandsRun CommandUI a
globalCommand [Command action]
commands 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          -> (String -> String) -> CommandParse (a, CommandParse action)
forall flags. (String -> String) -> CommandParse flags
CommandHelp String -> String
help
    CommandList      LFlags
opts          -> 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          -> 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) -> LFlags -> CommandParse (a, CommandParse action)
forall flags. LFlags -> CommandParse flags
handleHelpCommand LFlags
cmdArgs
      (String
name:LFlags
cmdArgs)   -> case String -> [Command action]
lookupCommand String
name of
        [Command String
_ String
_ LFlags -> CommandParse action
action CommandType
_]
          -> (a, CommandParse action) -> CommandParse (a, CommandParse action)
forall flags. flags -> CommandParse flags
CommandReadyToGo (a
flags, LFlags -> CommandParse action
action LFlags
cmdArgs)
        [Command action]
_ -> (a, CommandParse action) -> CommandParse (a, CommandParse action)
forall flags. flags -> CommandParse flags
CommandReadyToGo (a
flags, String -> CommandParse action
forall flags. String -> CommandParse flags
badCommand String
name)
      []               -> (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"]
    badCommand :: String -> CommandParse flags
badCommand String
cname = LFlags -> CommandParse flags
forall flags. LFlags -> CommandParse flags
CommandErrors [String
"unrecognised command: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cname
                                   String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (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 :: LFlags -> CommandParse flags
handleHelpCommand 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    -> (String -> String) -> CommandParse flags
forall flags. (String -> String) -> CommandParse flags
CommandHelp String -> String
help
        CommandList      LFlags
list    -> LFlags -> CommandParse flags
forall flags. LFlags -> CommandParse flags
CommandList (LFlags
list LFlags -> LFlags -> LFlags
forall a. [a] -> [a] -> [a]
++ LFlags
commandNames)
        CommandErrors    LFlags
_       -> (String -> String) -> CommandParse flags
forall flags. (String -> String) -> CommandParse flags
CommandHelp String -> String
globalHelp
        CommandReadyToGo (() -> ()
_,[])  -> (String -> String) -> CommandParse flags
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 -> (String -> String) -> CommandParse flags
forall flags. (String -> String) -> CommandParse flags
CommandHelp String -> String
help
                CommandList LFlags
_    -> LFlags -> CommandParse flags
forall flags. LFlags -> CommandParse flags
CommandList []
                CommandParse action
_                -> (String -> String) -> CommandParse flags
forall flags. (String -> String) -> CommandParse flags
CommandHelp String -> String
globalHelp
            [Command action]
_                    -> String -> CommandParse flags
forall flags. String -> CommandParse flags
badCommand String
name

     where globalHelp :: String -> String
globalHelp = CommandUI a -> String -> String
forall flags. CommandUI flags -> String -> String
commandHelp CommandUI a
globalCommand

-- | 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 (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 :: [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 :: Maybe (String -> String)
commandNotes = (String -> String) -> Maybe (String -> String)
forall a. a -> Maybe a
Just ((String -> String) -> Maybe (String -> String))
-> (String -> String) -> Maybe (String -> String)
forall a b. (a -> b) -> a -> b
$ \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, appararently 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 :: CommandSpec a -> Command a
commandFromSpec (CommandSpec CommandUI flags
ui CommandUI flags -> Command a
action CommandType
_) = CommandUI flags -> Command a
action CommandUI flags
ui