{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
module Distribution.Simple.Command (
CommandUI(..),
commandShowOptions,
CommandParse(..),
commandParseArgs,
getNormalCommandDescriptions,
helpCommandUI,
ShowOrParseArgs(..),
usageDefault,
usageAlternatives,
mkCommandUI,
hiddenCommand,
Command,
commandAddAction,
noExtraFlags,
CommandType(..),
CommandSpec(..),
commandFromSpec,
commandsRun,
OptionField(..), Name,
option, multiOption,
liftOption,
OptDescr(..), Description, SFlags, LFlags, OptFlags, ArgPlaceHolder,
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 {
CommandUI flags -> String
commandName :: String,
CommandUI flags -> String
commandSynopsis :: String,
CommandUI flags -> String -> String
commandUsage :: String -> String,
CommandUI flags -> Maybe (String -> String)
commandDescription :: Maybe (String -> String),
CommandUI flags -> Maybe (String -> String)
commandNotes :: Maybe (String -> String),
CommandUI flags -> flags
commandDefaultFlags :: flags,
CommandUI flags -> ShowOrParseArgs -> [OptionField flags]
commandOptions :: ShowOrParseArgs -> [OptionField flags]
}
data ShowOrParseArgs = ShowArgs | ParseArgs
type Name = String
type Description = String
data OptionField a = OptionField {
OptionField a -> String
optionName :: Name,
OptionField a -> [OptDescr a]
optionDescr :: [OptDescr a] }
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 OptFlags
(Bool -> a -> a) (a-> Maybe Bool)
type SFlags = [Char]
type LFlags = [String]
type OptFlags = (SFlags,LFlags)
type ArgPlaceHolder = String
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 sf :: String
sf lf :: LFlags
lf@(n :: String
n:_) d :: String
d get :: get
get set :: set
set arg :: 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 -> OptionField a
forall a. HasCallStack => String -> a
error (String -> OptionField a) -> String -> OptionField a
forall a b. (a -> b) -> a -> b
$ "Distribution.command.option: "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ "An OptionField must have at least one LFlag"
multiOption :: Name -> get -> set
-> [get -> set -> OptDescr a]
-> OptionField a
multiOption :: String -> get -> set -> [get -> set -> OptDescr a] -> OptionField a
multiOption n :: String
n get :: get
get set :: set
set args :: [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
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 ad :: String
ad mkflag :: ReadE b
mkflag showflag :: b -> LFlags
showflag sf :: String
sf lf :: LFlags
lf d :: String
d get :: a -> b
get set :: 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 (\a :: b
a b :: 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)
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 ad :: String
ad mkflag :: ReadE b
mkflag def :: b
def showflag :: b -> [Maybe String]
showflag sf :: String
sf lf :: LFlags
lf d :: String
d get :: a -> b
get set :: 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 (\a :: b
a b :: 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 :: 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)
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' ad :: String
ad mkflag :: String -> b
mkflag showflag :: 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
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' ad :: String
ad mkflag :: Maybe String -> b
mkflag showflag :: 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 flag :: b
flag sf :: String
sf lf :: LFlags
lf d :: 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 g :: b -> Maybe Bool
g s :: Bool -> b
s sfT :: String
sfT sfF :: String
sfF _sf :: String
_sf _lf :: LFlags
_lf@(n :: String
n:_) d :: String
d get :: a -> b
get set :: 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, ["enable-"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
n]) (String
sfF, ["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 _ _ _ _ _ _ _ _ _ = String -> OptDescr a
forall a. HasCallStack => String -> a
error
"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' g :: b -> Maybe Bool
g s :: Bool -> b
s ffT :: OptFlags
ffT ffF :: OptFlags
ffF _sf :: String
_sf _lf :: LFlags
_lf d :: String
d get :: a -> b
get set :: 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)
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 aa_ff :: [(b, OptFlags, String)]
aa_ff _sf :: String
_sf _lf :: LFlags
_lf _d :: String
_d get :: a -> b
get set :: 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) | (alt :: b
alt,flags :: OptFlags
flags,d :: String
d) <- [(b, OptFlags, String)]
aa_ff]
choiceOptFromEnum :: (Bounded b, Enum b, Show b, Eq b) =>
MkOptDescr (a -> b) (b -> a -> a) a
_sf :: String
_sf _lf :: LFlags
_lf d :: String
d get :: 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')
| (x :: b
x, sf :: 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 prev :: [(a, String)]
prev x :: 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 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 showOrParse :: ShowOrParseArgs
showOrParse command :: 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 _n :: String
_n aa :: [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 d :: String
d (cs :: String
cs,ss :: LFlags
ss) arg_desc :: String
arg_desc set :: ReadE (a -> a)
set _) =
[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 d :: String
d (cs :: String
cs,ss :: LFlags
ss) arg_desc :: String
arg_desc set :: ReadE (a -> a)
set def :: a -> a
def _) =
[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' Nothing = a -> a
def
set' (Just txt :: String
txt) = ReadE (a -> a) -> String -> a -> a
forall a. ReadE a -> String -> a
readEOrFail ReadE (a -> a)
set String
txt
optDescrToGetOpt (ChoiceOpt alts :: [(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 | (d :: String
d,(sf :: String
sf,lf :: LFlags
lf),set :: a -> a
set,_) <- [(String, OptFlags, a -> a, a -> Bool)]
alts ]
optDescrToGetOpt (BoolOpt d :: String
d (sfT :: String
sfT, lfT :: LFlags
lfT) ([], []) set :: Bool -> a -> a
set _) =
[ 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 d :: String
d ([], []) (sfF :: String
sfF, lfF :: LFlags
lfF) set :: Bool -> a -> a
set _) =
[ 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 d :: String
d (sfT :: String
sfT,lfT :: LFlags
lfT) (sfF :: String
sfF, lfF :: LFlags
lfF) set :: Bool -> a -> a
set _) =
[ 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)) ("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)) ("Disable " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
d) ]
getCurrentChoice :: OptDescr a -> a -> [String]
getCurrentChoice :: OptDescr a -> a -> LFlags
getCurrentChoice (ChoiceOpt alts :: [(String, OptFlags, a -> a, a -> Bool)]
alts) a :: a
a =
[ String
lf | (_,(_sf :: String
_sf,lf :: String
lf:_), _, currentChoice :: a -> Bool
currentChoice) <- [(String, OptFlags, a -> a, a -> Bool)]
alts, a -> Bool
currentChoice a
a]
getCurrentChoice _ _ = String -> LFlags
forall a. HasCallStack => String -> a
error "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 get' :: b -> a
get' set' :: a -> b -> b
set' opt :: 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 get' :: b -> a
get' set' :: a -> b -> b
set' (ChoiceOpt opts :: [(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'))
| (d :: String
d, ff :: OptFlags
ff, set :: a -> a
set, get :: a -> Bool
get) <- [(String, OptFlags, a -> a, a -> Bool)]
opts]
liftOptDescr get' :: b -> a
get' set' :: a -> b -> b
set' (OptArg d :: String
d ff :: OptFlags
ff ad :: String
ad set :: ReadE (a -> a)
set def :: a -> a
def get :: 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 get' :: b -> a
get' set' :: a -> b -> b
set' (ReqArg d :: String
d ff :: OptFlags
ff ad :: String
ad set :: ReadE (a -> a)
set get :: 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 get' :: b -> a
get' set' :: a -> b -> b
set' (BoolOpt d :: String
d ffT :: OptFlags
ffT ffF :: OptFlags
ffF set :: Bool -> a -> a
set get :: 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 get' :: b -> a
get' set' :: a -> b -> b
set' set :: a -> a
set x :: 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
commandShowOptions :: CommandUI flags -> flags -> [String]
commandShowOptions :: CommandUI flags -> flags -> LFlags
commandShowOptions command :: CommandUI flags
command v :: 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 (lOpt :: String
lOpt:_) = ["--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lOpt]
showOptDescr :: a -> OptDescr a -> [String]
showOptDescr :: a -> OptDescr a -> LFlags
showOptDescr x :: a
x (BoolOpt _ (_,lfTs :: LFlags
lfTs) (_,lfFs :: LFlags
lfFs) _ enabled :: a -> Maybe Bool
enabled)
= case a -> Maybe Bool
enabled a
x of
Nothing -> []
Just True -> LFlags -> LFlags
maybePrefix LFlags
lfTs
Just False -> LFlags -> LFlags
maybePrefix LFlags
lfFs
showOptDescr x :: a
x c :: OptDescr a
c@ChoiceOpt{}
= ["--" 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 x :: a
x (ReqArg _ (_ssff :: String
_ssff,lf :: String
lf:_) _ _ showflag :: a -> LFlags
showflag)
= [ "--"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
lfString -> String -> String
forall a. [a] -> [a] -> [a]
++"="String -> String -> String
forall a. [a] -> [a] -> [a]
++String
flag
| String
flag <- a -> LFlags
showflag a
x ]
showOptDescr x :: a
x (OptArg _ (_ssff :: String
_ssff,lf :: String
lf:_) _ _ _ showflag :: a -> [Maybe String]
showflag)
= [ case Maybe String
flag of
Just s :: String
s -> "--"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
lfString -> String -> String
forall a. [a] -> [a] -> [a]
++"="String -> String -> String
forall a. [a] -> [a] -> [a]
++String
s
Nothing -> "--"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
lf
| Maybe String
flag <- a -> [Maybe String]
showflag a
x ]
showOptDescr _ _
= String -> LFlags
forall a. HasCallStack => String -> a
error "Distribution.Simple.Command.showOptDescr: unreachable"
commandListOptions :: CommandUI flags -> [String]
commandListOptions :: CommandUI flags -> LFlags
commandListOptions command :: 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
$
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 shortNames :: String
shortNames longNames :: LFlags
longNames _ _) =
[ "-" 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
forall a. [a] -> [a] -> [a]
++ String
name | String
name <- LFlags
longNames ]
commandHelp :: CommandUI flags -> String -> String
commandHelp :: CommandUI flags -> String -> String
commandHelp command :: CommandUI flags
command pname :: String
pname =
CommandUI flags -> String
forall flags. CommandUI flags -> String
commandSynopsis CommandUI flags
command
String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\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
Nothing -> ""
Just desc :: String -> String
desc -> '\n'Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
desc String
pname)
String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ ( if String
cname String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== ""
then "Global flags:"
else "Flags for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cname String -> String -> String
forall a. [a] -> [a] -> [a]
++ ":" )
String -> String -> String
forall a. [a] -> [a] -> [a]
++ ( String -> [OptDescr (Either CommonFlag (flags -> flags))] -> String
forall a. String -> [OptDescr a] -> String
GetOpt.usageInfo ""
([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
Nothing -> ""
Just notes :: String -> String
notes -> '\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
usageDefault :: String -> String -> String
usageDefault :: String -> String -> String
usageDefault name :: String
name pname :: String
pname =
"Usage: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pname String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ " [FLAGS]\n\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Flags for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ ":"
usageAlternatives :: String -> [String] -> String -> String
usageAlternatives :: String -> LFlags -> String -> String
usageAlternatives name :: String
name strs :: LFlags
strs pname :: 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
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
| let starts :: LFlags
starts = "Usage: " String -> LFlags -> LFlags
forall a. a -> [a] -> [a]
: String -> LFlags
forall a. a -> [a]
repeat " or: "
, (start :: String
start, s :: String
s) <- LFlags -> LFlags -> [(String, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip LFlags
starts LFlags
strs
]
mkCommandUI :: String
-> String
-> [String]
-> flags
-> (ShowOrParseArgs -> [OptionField flags])
-> CommandUI flags
mkCommandUI :: String
-> String
-> LFlags
-> flags
-> (ShowOrParseArgs -> [OptionField flags])
-> CommandUI flags
mkCommandUI name :: String
name synopsis :: String
synopsis usages :: LFlags
usages flags :: flags
flags options :: 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
}
data CommonFlag = HelpFlag | ListOptionsFlag
commonFlags :: ShowOrParseArgs -> [GetOpt.OptDescr CommonFlag]
commonFlags :: ShowOrParseArgs -> [OptDescr CommonFlag]
commonFlags showOrParseArgs :: ShowOrParseArgs
showOrParseArgs = case ShowOrParseArgs
showOrParseArgs of
ShowArgs -> [OptDescr CommonFlag
help]
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 ["help"] (CommonFlag -> ArgDescr CommonFlag
forall a. a -> ArgDescr a
GetOpt.NoArg CommonFlag
HelpFlag)
"Show this help text"
helpShortFlags :: String
helpShortFlags = case ShowOrParseArgs
showOrParseArgs of
ShowArgs -> ['h']
ParseArgs -> ['h', '?']
list :: OptDescr CommonFlag
list = String
-> LFlags -> ArgDescr CommonFlag -> String -> OptDescr CommonFlag
forall a. String -> LFlags -> ArgDescr a -> String -> OptDescr a
GetOpt.Option [] ["list-options"] (CommonFlag -> ArgDescr CommonFlag
forall a. a -> ArgDescr a
GetOpt.NoArg CommonFlag
ListOptionsFlag)
"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
showOrParseArgs options :: [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 f :: t -> a
f (GetOpt.Option s :: String
s l :: LFlags
l d :: ArgDescr t
d m :: 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 f :: t -> a
f (GetOpt.NoArg a :: t
a) = a -> ArgDescr a
forall a. a -> ArgDescr a
GetOpt.NoArg (t -> a
f t
a)
fmapArgDesc f :: t -> a
f (GetOpt.ReqArg s :: String -> t
s d :: 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 f :: t -> a
f (GetOpt.OptArg s :: Maybe String -> t
s d :: 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
commandParseArgs :: CommandUI flags
-> Bool
-> [String]
-> CommandParse (flags -> flags, [String])
commandParseArgs :: CommandUI flags
-> Bool -> LFlags -> CommandParse (flags -> flags, LFlags)
commandParseArgs command :: CommandUI flags
command global :: Bool
global args :: 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
(flags :: [Either CommonFlag (flags -> flags)]
flags, _, _, _)
| (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 ListOptionsFlag) = Bool
True; listFlag _ = Bool
False
helpFlag :: Either CommonFlag b -> Bool
helpFlag (Left HelpFlag) = Bool
True; helpFlag _ = Bool
False
(flags :: [Either CommonFlag (flags -> flags)]
flags, opts :: LFlags
opts, 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')
(_, _, _, errs :: LFlags
errs) -> LFlags -> CommandParse (flags -> flags, LFlags)
forall flags. LFlags -> CommandParse flags
CommandErrors LFlags
errs
where
accum :: [Either a (c -> c)] -> c -> c
accum flags :: [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 f :: c -> c
f <- [Either a (c -> c)]
flags ]
unrecognised :: LFlags -> LFlags
unrecognised opts :: LFlags
opts = [ "unrecognized "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ "'" 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
forall a. [a] -> [a] -> [a]
++ " option `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
opt String -> String -> String
forall a. [a] -> [a] -> [a]
++ "'\n"
| String
opt <- LFlags
opts ]
mix :: [a] -> [a] -> [a]
mix [] ys :: [a]
ys = [a]
ys
mix (x :: a
x:xs :: [a]
xs) ys :: [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 _ (CommandHelp help :: String -> String
help) = (String -> String) -> CommandParse b
forall flags. (String -> String) -> CommandParse flags
CommandHelp String -> String
help
fmap _ (CommandList opts :: LFlags
opts) = LFlags -> CommandParse b
forall flags. LFlags -> CommandParse flags
CommandList LFlags
opts
fmap _ (CommandErrors errs :: LFlags
errs) = LFlags -> CommandParse b
forall flags. LFlags -> CommandParse flags
CommandErrors LFlags
errs
fmap f :: a -> b
f (CommandReadyToGo flags :: 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
hiddenCommand :: Command action -> Command action
hiddenCommand :: Command action -> Command action
hiddenCommand (Command name :: String
name synopsys :: String
synopsys f :: LFlags -> CommandParse action
f _cmdType :: 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 command :: CommandUI flags
command action :: 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 mkflags :: flags -> flags
mkflags args :: 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 globalCommand :: CommandUI a
globalCommand commands :: [Command action]
commands args :: 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 help :: String -> String
help -> (String -> String) -> CommandParse (a, CommandParse action)
forall flags. (String -> String) -> CommandParse flags
CommandHelp String -> String
help
CommandList opts :: 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 errs :: LFlags
errs -> LFlags -> CommandParse (a, CommandParse action)
forall flags. LFlags -> CommandParse flags
CommandErrors LFlags
errs
CommandReadyToGo (mkflags :: a -> a
mkflags, args' :: LFlags
args') -> case LFlags
args' of
("help":cmdArgs :: LFlags
cmdArgs) -> LFlags -> CommandParse (a, CommandParse action)
forall flags. LFlags -> CommandParse flags
handleHelpCommand LFlags
cmdArgs
(name :: String
name:cmdArgs :: LFlags
cmdArgs) -> case String -> [Command action]
lookupCommand String
name of
[Command _ _ action :: LFlags -> CommandParse action
action _]
-> (a, CommandParse action) -> CommandParse (a, CommandParse action)
forall flags. flags -> CommandParse flags
CommandReadyToGo (a
flags, LFlags -> CommandParse action
action LFlags
cmdArgs)
_ -> (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 cname :: String
cname = [ Command action
cmd | cmd :: Command action
cmd@(Command cname' :: String
cname' _ _ _) <- [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 ["no command given (try --help)\n"]
badCommand :: String -> CommandParse flags
badCommand cname :: String
cname = LFlags -> CommandParse flags
forall flags. LFlags -> CommandParse flags
CommandErrors ["unrecognised command: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cname
String -> String -> String
forall a. [a] -> [a] -> [a]
++ " (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 name :: String
name _ _ NormalCommand) <- [Command action]
commands' ]
handleHelpCommand :: LFlags -> CommandParse flags
handleHelpCommand cmdArgs :: 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 help :: String -> String
help -> (String -> String) -> CommandParse flags
forall flags. (String -> String) -> CommandParse flags
CommandHelp String -> String
help
CommandList list :: LFlags
list -> LFlags -> CommandParse flags
forall flags. LFlags -> CommandParse flags
CommandList (LFlags
list LFlags -> LFlags -> LFlags
forall a. [a] -> [a] -> [a]
++ LFlags
commandNames)
CommandErrors _ -> (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 (_,(name :: String
name:cmdArgs' :: LFlags
cmdArgs')) ->
case String -> [Command action]
lookupCommand String
name of
[Command _ _ action :: LFlags -> CommandParse action
action _] ->
case LFlags -> CommandParse action
action ("--help"String -> LFlags -> LFlags
forall a. a -> [a] -> [a]
:LFlags
cmdArgs') of
CommandHelp help :: String -> String
help -> (String -> String) -> CommandParse flags
forall flags. (String -> String) -> CommandParse flags
CommandHelp String -> String
help
CommandList _ -> LFlags -> CommandParse flags
forall flags. LFlags -> CommandParse flags
CommandList []
_ -> (String -> String) -> CommandParse flags
forall flags. (String -> String) -> CommandParse flags
CommandHelp String -> String
globalHelp
_ -> 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
noExtraFlags :: [String] -> IO ()
[] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
noExtraFlags extraFlags :: LFlags
extraFlags =
String -> IO ()
forall a. String -> IO a
dieNoVerbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Unrecognised flags: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> LFlags -> String
forall a. [a] -> [[a]] -> [a]
intercalate ", " LFlags
extraFlags
getNormalCommandDescriptions :: [Command action] -> [(String, String)]
getNormalCommandDescriptions :: [Command action] -> [(String, String)]
getNormalCommandDescriptions cmds :: [Command action]
cmds =
[ (String
name, String
description)
| Command name :: String
name description :: String
description _ 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
"help"
"Help about commands."
["[FLAGS]", "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
$ \pname :: String
pname ->
"Examples:\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pname String -> String -> String
forall a. [a] -> [a] -> [a]
++ " help help\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ " Oh, appararently you already know this.\n"
}
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 ui :: CommandUI flags
ui action :: CommandUI flags -> Command a
action _) = CommandUI flags -> Command a
action CommandUI flags
ui