{-# 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, liftOptionL,
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 Data.Array as Array
import qualified Data.List as List
import qualified Distribution.GetOpt as GetOpt
import Distribution.ReadE
import Distribution.Simple.Utils
import Distribution.Compat.Lens (ALens', (^#), (#~))
data CommandUI flags = CommandUI {
forall flags. CommandUI flags -> String
commandName :: String,
forall flags. CommandUI flags -> String
commandSynopsis :: String,
forall flags. CommandUI flags -> String -> String
commandUsage :: String -> String,
forall flags. CommandUI flags -> Maybe (String -> String)
commandDescription :: Maybe (String -> String),
forall flags. CommandUI flags -> Maybe (String -> String)
commandNotes :: Maybe (String -> String),
forall flags. CommandUI flags -> flags
commandDefaultFlags :: flags,
forall flags.
CommandUI flags -> ShowOrParseArgs -> [OptionField flags]
commandOptions :: ShowOrParseArgs -> [OptionField flags]
}
data ShowOrParseArgs = ShowArgs | ParseArgs
type Name = String
type Description = String
data OptionField a = OptionField {
forall a. OptionField a -> String
optionName :: Name,
forall a. 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 :: forall get set a.
String
-> LFlags
-> String
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option String
sf lf :: LFlags
lf@(String
n:LFlags
_) String
d get
get set
set MkOptDescr get set a
arg = String -> [OptDescr a] -> OptionField a
forall a. String -> [OptDescr a] -> OptionField a
OptionField String
n [MkOptDescr get set a
arg String
sf LFlags
lf String
d get
get set
set]
option String
_ LFlags
_ String
_ get
_ set
_ MkOptDescr get set a
_ = String -> OptionField a
forall a. HasCallStack => String -> a
error (String -> OptionField a) -> String -> OptionField a
forall a b. (a -> b) -> a -> b
$ String
"Distribution.command.option: "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"An OptionField must have at least one LFlag"
multiOption :: Name -> get -> set
-> [get -> set -> OptDescr a]
-> OptionField a
multiOption :: forall get set a.
String -> get -> set -> [get -> set -> OptDescr a] -> OptionField a
multiOption String
n get
get set
set [get -> set -> OptDescr a]
args = String -> [OptDescr a] -> OptionField a
forall a. String -> [OptDescr a] -> OptionField a
OptionField String
n [get -> set -> OptDescr a
arg get
get set
set | get -> set -> OptDescr a
arg <- [get -> set -> OptDescr a]
args]
type MkOptDescr get set a = SFlags -> LFlags -> Description -> get -> set
-> OptDescr a
reqArg :: Monoid b => ArgPlaceHolder -> ReadE b -> (b -> [String])
-> MkOptDescr (a -> b) (b -> a -> a) a
reqArg :: forall b a.
Monoid b =>
String
-> ReadE b -> (b -> LFlags) -> MkOptDescr (a -> b) (b -> a -> a) a
reqArg String
ad ReadE b
mkflag b -> LFlags
showflag String
sf LFlags
lf String
d a -> b
get b -> a -> a
set =
String
-> OptFlags
-> String
-> ReadE (a -> a)
-> (a -> LFlags)
-> OptDescr a
forall a.
String
-> OptFlags
-> String
-> ReadE (a -> a)
-> (a -> LFlags)
-> OptDescr a
ReqArg String
d (String
sf,LFlags
lf) String
ad ((b -> a -> a) -> ReadE b -> ReadE (a -> a)
forall a b. (a -> b) -> ReadE a -> ReadE b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\b
a a
b -> b -> a -> a
set (a -> b
get a
b b -> b -> b
forall a. Monoid a => a -> a -> a
`mappend` b
a) a
b) ReadE b
mkflag)
(b -> LFlags
showflag (b -> LFlags) -> (a -> b) -> a -> LFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
get)
optArg :: Monoid b => ArgPlaceHolder -> ReadE b -> b -> (b -> [Maybe String])
-> MkOptDescr (a -> b) (b -> a -> a) a
optArg :: forall b a.
Monoid b =>
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 a b. (a -> b) -> ReadE a -> ReadE b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\b
a a
b -> b -> a -> a
set (a -> b
get a
b b -> b -> b
forall a. Monoid a => a -> a -> a
`mappend` b
a) a
b) ReadE b
mkflag)
(\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' :: forall b a.
Monoid b =>
String
-> (String -> b)
-> (b -> LFlags)
-> MkOptDescr (a -> b) (b -> a -> a) a
reqArg' String
ad String -> b
mkflag b -> LFlags
showflag =
String
-> ReadE b -> (b -> LFlags) -> MkOptDescr (a -> b) (b -> a -> a) a
forall b a.
Monoid b =>
String
-> ReadE b -> (b -> LFlags) -> MkOptDescr (a -> b) (b -> a -> a) a
reqArg String
ad ((String -> b) -> ReadE b
forall a. (String -> a) -> ReadE a
succeedReadE String -> b
mkflag) b -> LFlags
showflag
optArg' :: Monoid b => ArgPlaceHolder -> (Maybe String -> b)
-> (b -> [Maybe String])
-> MkOptDescr (a -> b) (b -> a -> a) a
optArg' :: forall b a.
Monoid b =>
String
-> (Maybe String -> b)
-> (b -> [Maybe String])
-> MkOptDescr (a -> b) (b -> a -> a) a
optArg' String
ad Maybe String -> b
mkflag b -> [Maybe String]
showflag =
String
-> ReadE b
-> 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 :: forall b a. Eq b => b -> MkOptDescr (a -> b) (b -> a -> a) a
noArg b
flag String
sf LFlags
lf String
d = [(b, OptFlags, String)] -> MkOptDescr (a -> b) (b -> a -> a) a
forall b a.
Eq b =>
[(b, OptFlags, String)] -> MkOptDescr (a -> b) (b -> a -> a) a
choiceOpt [(b
flag, (String
sf,LFlags
lf), String
d)] String
sf LFlags
lf String
d
boolOpt :: (b -> Maybe Bool) -> (Bool -> b) -> SFlags -> SFlags
-> MkOptDescr (a -> b) (b -> a -> a) a
boolOpt :: forall b a.
(b -> Maybe Bool)
-> (Bool -> b)
-> String
-> String
-> MkOptDescr (a -> b) (b -> a -> a) a
boolOpt b -> Maybe Bool
g Bool -> b
s String
sfT String
sfF String
_sf _lf :: LFlags
_lf@(String
n:LFlags
_) String
d a -> b
get b -> a -> a
set =
String
-> OptFlags
-> OptFlags
-> (Bool -> a -> a)
-> (a -> Maybe Bool)
-> OptDescr a
forall a.
String
-> OptFlags
-> OptFlags
-> (Bool -> a -> a)
-> (a -> Maybe Bool)
-> OptDescr a
BoolOpt String
d (String
sfT, [String
"enable-"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
n]) (String
sfF, [String
"disable-"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
n]) (b -> a -> a
set(b -> a -> a) -> (Bool -> b) -> Bool -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Bool -> b
s) (b -> Maybe Bool
g(b -> Maybe Bool) -> (a -> b) -> a -> Maybe Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.a -> b
get)
boolOpt b -> Maybe Bool
_ Bool -> b
_ String
_ String
_ String
_ LFlags
_ String
_ a -> b
_ b -> a -> a
_ = String -> OptDescr a
forall a. HasCallStack => String -> a
error
String
"Distribution.Simple.Setup.boolOpt: unreachable"
boolOpt' :: (b -> Maybe Bool) -> (Bool -> b) -> OptFlags -> OptFlags
-> MkOptDescr (a -> b) (b -> a -> a) a
boolOpt' :: forall b a.
(b -> Maybe Bool)
-> (Bool -> b)
-> OptFlags
-> OptFlags
-> MkOptDescr (a -> b) (b -> a -> a) a
boolOpt' b -> Maybe Bool
g Bool -> b
s OptFlags
ffT OptFlags
ffF String
_sf LFlags
_lf String
d a -> b
get b -> a -> a
set = String
-> OptFlags
-> OptFlags
-> (Bool -> a -> a)
-> (a -> Maybe Bool)
-> OptDescr a
forall a.
String
-> OptFlags
-> OptFlags
-> (Bool -> a -> a)
-> (a -> Maybe Bool)
-> OptDescr a
BoolOpt String
d OptFlags
ffT OptFlags
ffF (b -> a -> a
set(b -> a -> a) -> (Bool -> b) -> Bool -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Bool -> b
s) (b -> Maybe Bool
g (b -> Maybe Bool) -> (a -> b) -> a -> Maybe Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
get)
choiceOpt :: Eq b => [(b,OptFlags,Description)]
-> MkOptDescr (a -> b) (b -> a -> a) a
choiceOpt :: forall b a.
Eq b =>
[(b, OptFlags, String)] -> MkOptDescr (a -> b) (b -> a -> a) a
choiceOpt [(b, OptFlags, String)]
aa_ff String
_sf LFlags
_lf String
_d a -> b
get b -> a -> a
set = [(String, OptFlags, a -> a, a -> Bool)] -> OptDescr a
forall a. [(String, OptFlags, a -> a, a -> Bool)] -> OptDescr a
ChoiceOpt [(String, OptFlags, a -> a, a -> Bool)]
alts
where alts :: [(String, OptFlags, a -> a, a -> Bool)]
alts = [(String
d,OptFlags
flags, b -> a -> a
set b
alt, (b -> b -> Bool
forall a. Eq a => a -> a -> Bool
==b
alt) (b -> Bool) -> (a -> b) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
get) | (b
alt,OptFlags
flags,String
d) <- [(b, OptFlags, String)]
aa_ff]
choiceOptFromEnum :: (Bounded b, Enum b, Show b, Eq b) =>
MkOptDescr (a -> b) (b -> a -> a) a
String
_sf LFlags
_lf String
d a -> b
get =
[(b, OptFlags, String)] -> MkOptDescr (a -> b) (b -> a -> a) a
forall b a.
Eq b =>
[(b, OptFlags, String)] -> MkOptDescr (a -> b) (b -> a -> a) a
choiceOpt [ (b
x, (String
sf, [(Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ b -> String
forall a. Show a => a -> String
show b
x]), String
d')
| (b
x, String
sf) <- [(b, String)]
sflags'
, let d' :: String
d' = String
d String -> String -> String
forall a. [a] -> [a] -> [a]
++ b -> String
forall a. Show a => a -> String
show b
x]
String
_sf LFlags
_lf String
d a -> b
get
where sflags' :: [(b, String)]
sflags' = ([(b, String)] -> b -> [(b, String)])
-> [(b, String)] -> [b] -> [(b, String)]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [(b, String)] -> b -> [(b, String)]
forall {a}. Show a => [(a, String)] -> a -> [(a, String)]
f [] [b
firstOne..]
f :: [(a, String)] -> a -> [(a, String)]
f [(a, String)]
prev a
x = let prevflags :: String
prevflags = ((a, String) -> String) -> [(a, String)] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (a, String) -> String
forall a b. (a, b) -> b
snd [(a, String)]
prev in
[(a, String)]
prev [(a, String)] -> [(a, String)] -> [(a, String)]
forall a. [a] -> [a] -> [a]
++ Int -> [(a, String)] -> [(a, String)]
forall a. Int -> [a] -> [a]
take Int
1 [(a
x, [Char -> Char
toLower Char
sf])
| Char
sf <- a -> String
forall a. Show a => a -> String
show a
x, Char -> Bool
isAlpha Char
sf
, Char -> Char
toLower Char
sf Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
prevflags]
firstOne :: b
firstOne = b
forall a. Bounded a => a
minBound b -> b -> b
forall a. a -> a -> a
`asTypeOf` a -> b
get a
forall a. HasCallStack => a
undefined
commandGetOpts :: ShowOrParseArgs -> CommandUI flags
-> [GetOpt.OptDescr (flags -> flags)]
commandGetOpts :: forall flags.
ShowOrParseArgs -> CommandUI flags -> [OptDescr (flags -> flags)]
commandGetOpts ShowOrParseArgs
showOrParse CommandUI flags
command =
(OptionField flags -> [OptDescr (flags -> flags)])
-> [OptionField flags] -> [OptDescr (flags -> flags)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap OptionField flags -> [OptDescr (flags -> flags)]
forall a. OptionField a -> [OptDescr (a -> a)]
viewAsGetOpt (CommandUI flags -> ShowOrParseArgs -> [OptionField flags]
forall flags.
CommandUI flags -> ShowOrParseArgs -> [OptionField flags]
commandOptions CommandUI flags
command ShowOrParseArgs
showOrParse)
viewAsGetOpt :: OptionField a -> [GetOpt.OptDescr (a -> a)]
viewAsGetOpt :: forall a. OptionField a -> [OptDescr (a -> a)]
viewAsGetOpt (OptionField String
_n [OptDescr a]
aa) = (OptDescr a -> [OptDescr (a -> a)])
-> [OptDescr a] -> [OptDescr (a -> a)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap OptDescr a -> [OptDescr (a -> a)]
forall {a}. OptDescr a -> [OptDescr (a -> a)]
optDescrToGetOpt [OptDescr a]
aa
where
optDescrToGetOpt :: OptDescr a -> [OptDescr (a -> a)]
optDescrToGetOpt (ReqArg String
d (String
cs,LFlags
ss) String
arg_desc ReadE (a -> a)
set a -> LFlags
_) =
[String
-> LFlags -> ArgDescr (a -> a) -> String -> OptDescr (a -> a)
forall a. String -> LFlags -> ArgDescr a -> String -> OptDescr a
GetOpt.Option String
cs LFlags
ss ((String -> Either String (a -> a)) -> String -> ArgDescr (a -> a)
forall a. (String -> Either String a) -> String -> ArgDescr a
GetOpt.ReqArg (ReadE (a -> a) -> String -> Either String (a -> a)
forall a. ReadE a -> String -> Either String a
runReadE ReadE (a -> a)
set) String
arg_desc) String
d]
optDescrToGetOpt (OptArg String
d (String
cs,LFlags
ss) String
arg_desc ReadE (a -> a)
set 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 -> Either String (a -> a))
-> String -> ArgDescr (a -> a)
forall a. (Maybe String -> Either String a) -> String -> ArgDescr a
GetOpt.OptArg Maybe String -> Either String (a -> a)
set' String
arg_desc) String
d]
where set' :: Maybe String -> Either String (a -> a)
set' Maybe String
Nothing = (a -> a) -> Either String (a -> a)
forall a b. b -> Either a b
Right a -> a
def
set' (Just String
txt) = ReadE (a -> a) -> String -> Either String (a -> a)
forall a. ReadE a -> String -> Either String a
runReadE ReadE (a -> a)
set String
txt
optDescrToGetOpt (ChoiceOpt [(String, OptFlags, a -> a, a -> Bool)]
alts) =
[String
-> LFlags -> ArgDescr (a -> a) -> String -> OptDescr (a -> a)
forall a. String -> LFlags -> ArgDescr a -> String -> OptDescr a
GetOpt.Option String
sf LFlags
lf ((a -> a) -> ArgDescr (a -> a)
forall a. a -> ArgDescr a
GetOpt.NoArg a -> a
set) String
d | (String
d,(String
sf,LFlags
lf),a -> a
set,a -> Bool
_) <- [(String, OptFlags, a -> a, a -> Bool)]
alts ]
optDescrToGetOpt (BoolOpt String
d (String
sfT, LFlags
lfT) ([], []) Bool -> a -> a
set a -> Maybe Bool
_) =
[ String
-> LFlags -> ArgDescr (a -> a) -> String -> OptDescr (a -> a)
forall a. String -> LFlags -> ArgDescr a -> String -> OptDescr a
GetOpt.Option String
sfT LFlags
lfT ((a -> a) -> ArgDescr (a -> a)
forall a. a -> ArgDescr a
GetOpt.NoArg (Bool -> a -> a
set Bool
True)) String
d ]
optDescrToGetOpt (BoolOpt String
d ([], []) (String
sfF, LFlags
lfF) Bool -> a -> a
set a -> Maybe Bool
_) =
[ String
-> LFlags -> ArgDescr (a -> a) -> String -> OptDescr (a -> a)
forall a. String -> LFlags -> ArgDescr a -> String -> OptDescr a
GetOpt.Option String
sfF LFlags
lfF ((a -> a) -> ArgDescr (a -> a)
forall a. a -> ArgDescr a
GetOpt.NoArg (Bool -> a -> a
set Bool
False)) String
d ]
optDescrToGetOpt (BoolOpt String
d (String
sfT,LFlags
lfT) (String
sfF, LFlags
lfF) Bool -> a -> a
set a -> Maybe Bool
_) =
[ String
-> LFlags -> ArgDescr (a -> a) -> String -> OptDescr (a -> a)
forall a. String -> LFlags -> ArgDescr a -> String -> OptDescr a
GetOpt.Option String
sfT LFlags
lfT ((a -> a) -> ArgDescr (a -> a)
forall a. a -> ArgDescr a
GetOpt.NoArg (Bool -> a -> a
set Bool
True)) (String
"Enable " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
d)
, String
-> LFlags -> ArgDescr (a -> a) -> String -> OptDescr (a -> a)
forall a. String -> LFlags -> ArgDescr a -> String -> OptDescr a
GetOpt.Option String
sfF LFlags
lfF ((a -> a) -> ArgDescr (a -> a)
forall a. a -> ArgDescr a
GetOpt.NoArg (Bool -> a -> a
set Bool
False)) (String
"Disable " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
d) ]
getCurrentChoice :: OptDescr a -> a -> [String]
getCurrentChoice :: forall a. OptDescr a -> a -> LFlags
getCurrentChoice (ChoiceOpt [(String, OptFlags, a -> a, a -> Bool)]
alts) a
a =
[ String
lf | (String
_,(String
_sf,String
lf:LFlags
_), a -> a
_, a -> Bool
currentChoice) <- [(String, OptFlags, a -> a, a -> Bool)]
alts, a -> Bool
currentChoice a
a]
getCurrentChoice OptDescr a
_ a
_ = String -> LFlags
forall a. HasCallStack => String -> a
error String
"Command.getChoice: expected a Choice OptDescr"
liftOption :: (b -> a) -> (a -> (b -> b)) -> OptionField a -> OptionField b
liftOption :: forall b a.
(b -> a) -> (a -> b -> b) -> OptionField a -> OptionField b
liftOption b -> a
get' a -> b -> b
set' OptionField a
opt =
OptionField a
opt { optionDescr :: [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}
liftOptionL :: ALens' b a -> OptionField a -> OptionField b
liftOptionL :: forall b a. ALens' b a -> OptionField a -> OptionField b
liftOptionL ALens' b a
l = (b -> a) -> (a -> b -> b) -> OptionField a -> OptionField b
forall b a.
(b -> a) -> (a -> b -> b) -> OptionField a -> OptionField b
liftOption (b -> ALens' b a -> a
forall s t a b. s -> ALens s t a b -> a
^# ALens' b a
l) (ALens' b a
l ALens' b a -> a -> b -> b
forall s t a b. ALens s t a b -> b -> s -> t
#~)
liftOptDescr :: (b -> a) -> (a -> (b -> b)) -> OptDescr a -> OptDescr b
liftOptDescr :: forall b a. (b -> a) -> (a -> b -> b) -> OptDescr a -> OptDescr b
liftOptDescr b -> a
get' a -> b -> b
set' (ChoiceOpt [(String, OptFlags, a -> a, a -> Bool)]
opts) =
[(String, OptFlags, b -> b, b -> Bool)] -> OptDescr b
forall a. [(String, OptFlags, a -> a, a -> Bool)] -> OptDescr a
ChoiceOpt [ (String
d, OptFlags
ff, (b -> a) -> (a -> b -> b) -> (a -> a) -> b -> b
forall b a. (b -> a) -> (a -> b -> b) -> (a -> a) -> b -> b
liftSet b -> a
get' a -> b -> b
set' a -> a
set , (a -> Bool
get (a -> Bool) -> (b -> a) -> b -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
get'))
| (String
d, OptFlags
ff, a -> a
set, a -> Bool
get) <- [(String, OptFlags, a -> a, a -> Bool)]
opts]
liftOptDescr b -> a
get' a -> b -> b
set' (OptArg String
d OptFlags
ff String
ad ReadE (a -> a)
set 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 a b. (a -> b) -> ReadE a -> ReadE b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ReadE (a -> a)
set)
((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 a b. (a -> b) -> ReadE a -> ReadE b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ReadE (a -> a)
set) (a -> LFlags
get (a -> LFlags) -> (b -> a) -> b -> LFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
get')
liftOptDescr b -> a
get' a -> b -> b
set' (BoolOpt String
d OptFlags
ffT OptFlags
ffF Bool -> a -> a
set a -> Maybe Bool
get) =
String
-> OptFlags
-> OptFlags
-> (Bool -> b -> b)
-> (b -> Maybe Bool)
-> OptDescr b
forall a.
String
-> OptFlags
-> OptFlags
-> (Bool -> a -> a)
-> (a -> Maybe Bool)
-> OptDescr a
BoolOpt String
d OptFlags
ffT OptFlags
ffF ((b -> a) -> (a -> b -> b) -> (a -> a) -> b -> b
forall b a. (b -> a) -> (a -> b -> b) -> (a -> a) -> b -> b
liftSet b -> a
get' a -> b -> b
set' ((a -> a) -> b -> b) -> (Bool -> a -> a) -> Bool -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> a -> a
set) (a -> Maybe Bool
get (a -> Maybe Bool) -> (b -> a) -> b -> Maybe Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
get')
liftSet :: (b -> a) -> (a -> (b -> b)) -> (a -> a) -> b -> b
liftSet :: forall b a. (b -> a) -> (a -> b -> b) -> (a -> a) -> b -> b
liftSet b -> a
get' a -> b -> b
set' a -> a
set b
x = a -> b -> b
set' (a -> a
set (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ b -> a
get' b
x) b
x
commandShowOptions :: CommandUI flags -> flags -> [String]
commandShowOptions :: forall flags. CommandUI flags -> flags -> LFlags
commandShowOptions CommandUI flags
command flags
v = [LFlags] -> LFlags
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ flags -> OptDescr flags -> LFlags
forall a. a -> OptDescr a -> LFlags
showOptDescr flags
v OptDescr flags
od | OptionField flags
o <- CommandUI flags -> ShowOrParseArgs -> [OptionField flags]
forall flags.
CommandUI flags -> ShowOrParseArgs -> [OptionField flags]
commandOptions CommandUI flags
command ShowOrParseArgs
ParseArgs
, OptDescr flags
od <- OptionField flags -> [OptDescr flags]
forall a. OptionField a -> [OptDescr a]
optionDescr OptionField flags
o]
where
maybePrefix :: LFlags -> LFlags
maybePrefix [] = []
maybePrefix (String
lOpt:LFlags
_) = [String
"--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lOpt]
showOptDescr :: a -> OptDescr a -> [String]
showOptDescr :: forall a. a -> OptDescr a -> LFlags
showOptDescr a
x (BoolOpt String
_ (String
_,LFlags
lfTs) (String
_,LFlags
lfFs) Bool -> a -> a
_ a -> Maybe Bool
enabled)
= case a -> Maybe Bool
enabled a
x of
Maybe Bool
Nothing -> []
Just Bool
True -> LFlags -> LFlags
maybePrefix LFlags
lfTs
Just Bool
False -> LFlags -> LFlags
maybePrefix LFlags
lfFs
showOptDescr a
x c :: OptDescr a
c@ChoiceOpt{}
= [String
"--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
val | String
val <- OptDescr a -> a -> LFlags
forall a. OptDescr a -> a -> LFlags
getCurrentChoice OptDescr a
c a
x]
showOptDescr a
x (ReqArg String
_ (String
_ssff,String
lf:LFlags
_) String
_ ReadE (a -> a)
_ a -> LFlags
showflag)
= [ String
"--"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
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 :: forall flags. CommandUI flags -> LFlags
commandListOptions CommandUI flags
command =
(OptDescr (Either CommonFlag (flags -> flags)) -> LFlags)
-> [OptDescr (Either CommonFlag (flags -> flags))] -> LFlags
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap OptDescr (Either CommonFlag (flags -> flags)) -> LFlags
forall {a}. OptDescr a -> LFlags
listOption ([OptDescr (Either CommonFlag (flags -> flags))] -> LFlags)
-> [OptDescr (Either CommonFlag (flags -> flags))] -> LFlags
forall a b. (a -> b) -> a -> b
$
ShowOrParseArgs
-> [OptDescr (flags -> flags)]
-> [OptDescr (Either CommonFlag (flags -> flags))]
forall a.
ShowOrParseArgs -> [OptDescr a] -> [OptDescr (Either CommonFlag a)]
addCommonFlags ShowOrParseArgs
ShowArgs ([OptDescr (flags -> flags)]
-> [OptDescr (Either CommonFlag (flags -> flags))])
-> [OptDescr (flags -> flags)]
-> [OptDescr (Either CommonFlag (flags -> flags))]
forall a b. (a -> b) -> a -> b
$
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 ]
commandHelp :: CommandUI flags -> String -> String
commandHelp :: forall flags. CommandUI flags -> String -> String
commandHelp CommandUI flags
command String
pname =
CommandUI flags -> String
forall flags. CommandUI flags -> String
commandSynopsis CommandUI flags
command
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ CommandUI flags -> String -> String
forall flags. CommandUI flags -> String -> String
commandUsage CommandUI flags
command String
pname
String -> String -> String
forall a. [a] -> [a] -> [a]
++ ( case CommandUI flags -> Maybe (String -> String)
forall flags. CommandUI flags -> Maybe (String -> String)
commandDescription CommandUI flags
command of
Maybe (String -> String)
Nothing -> String
""
Just String -> String
desc -> Char
'\n'Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
desc String
pname)
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ ( if String
cname String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
""
then String
"Global flags:"
else String
"Flags for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" )
String -> String -> String
forall a. [a] -> [a] -> [a]
++ ( String -> [OptDescr (Either CommonFlag (flags -> flags))] -> String
forall a. String -> [OptDescr a] -> String
GetOpt.usageInfo String
""
([OptDescr (Either CommonFlag (flags -> flags))] -> String)
-> ([OptDescr (flags -> flags)]
-> [OptDescr (Either CommonFlag (flags -> flags))])
-> [OptDescr (flags -> flags)]
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowOrParseArgs
-> [OptDescr (flags -> flags)]
-> [OptDescr (Either CommonFlag (flags -> flags))]
forall a.
ShowOrParseArgs -> [OptDescr a] -> [OptDescr (Either CommonFlag a)]
addCommonFlags ShowOrParseArgs
ShowArgs
([OptDescr (flags -> flags)] -> String)
-> [OptDescr (flags -> flags)] -> String
forall a b. (a -> b) -> a -> b
$ ShowOrParseArgs -> CommandUI flags -> [OptDescr (flags -> flags)]
forall flags.
ShowOrParseArgs -> CommandUI flags -> [OptDescr (flags -> flags)]
commandGetOpts ShowOrParseArgs
ShowArgs CommandUI flags
command )
String -> String -> String
forall a. [a] -> [a] -> [a]
++ ( case CommandUI flags -> Maybe (String -> String)
forall flags. CommandUI flags -> Maybe (String -> String)
commandNotes CommandUI flags
command of
Maybe (String -> String)
Nothing -> String
""
Just String -> String
notes -> Char
'\n'Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
notes String
pname)
where cname :: String
cname = CommandUI flags -> String
forall flags. CommandUI flags -> String
commandName CommandUI flags
command
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
":"
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
]
mkCommandUI :: String
-> String
-> [String]
-> flags
-> (ShowOrParseArgs -> [OptionField flags])
-> CommandUI flags
mkCommandUI :: forall flags.
String
-> String
-> LFlags
-> flags
-> (ShowOrParseArgs -> [OptionField flags])
-> CommandUI flags
mkCommandUI String
name String
synopsis LFlags
usages flags
flags ShowOrParseArgs -> [OptionField flags]
options = CommandUI
{ commandName :: String
commandName = String
name
, commandSynopsis :: String
commandSynopsis = String
synopsis
, commandDescription :: Maybe (String -> String)
commandDescription = Maybe (String -> String)
forall a. Maybe a
Nothing
, commandNotes :: Maybe (String -> String)
commandNotes = Maybe (String -> String)
forall a. Maybe a
Nothing
, commandUsage :: String -> String
commandUsage = String -> LFlags -> String -> String
usageAlternatives String
name LFlags
usages
, commandDefaultFlags :: flags
commandDefaultFlags = flags
flags
, commandOptions :: ShowOrParseArgs -> [OptionField flags]
commandOptions = ShowOrParseArgs -> [OptionField flags]
options
}
data CommonFlag = HelpFlag | ListOptionsFlag
commonFlags :: ShowOrParseArgs -> [GetOpt.OptDescr CommonFlag]
commonFlags :: ShowOrParseArgs -> [OptDescr CommonFlag]
commonFlags ShowOrParseArgs
showOrParseArgs = case ShowOrParseArgs
showOrParseArgs of
ShowOrParseArgs
ShowArgs -> [OptDescr CommonFlag
help]
ShowOrParseArgs
ParseArgs -> [OptDescr CommonFlag
help, OptDescr CommonFlag
list]
where
help :: OptDescr CommonFlag
help = String
-> LFlags -> ArgDescr CommonFlag -> String -> OptDescr CommonFlag
forall a. String -> LFlags -> ArgDescr a -> String -> OptDescr a
GetOpt.Option String
helpShortFlags [String
"help"] (CommonFlag -> ArgDescr CommonFlag
forall a. a -> ArgDescr a
GetOpt.NoArg CommonFlag
HelpFlag)
String
"Show this help text"
helpShortFlags :: String
helpShortFlags = case ShowOrParseArgs
showOrParseArgs of
ShowOrParseArgs
ShowArgs -> [Char
'h']
ShowOrParseArgs
ParseArgs -> [Char
'h', Char
'?']
list :: OptDescr CommonFlag
list = String
-> LFlags -> ArgDescr CommonFlag -> String -> OptDescr CommonFlag
forall a. String -> LFlags -> ArgDescr a -> String -> OptDescr a
GetOpt.Option [] [String
"list-options"] (CommonFlag -> ArgDescr CommonFlag
forall a. a -> ArgDescr a
GetOpt.NoArg CommonFlag
ListOptionsFlag)
String
"Print a list of command line flags"
addCommonFlags :: ShowOrParseArgs
-> [GetOpt.OptDescr a]
-> [GetOpt.OptDescr (Either CommonFlag a)]
addCommonFlags :: forall a.
ShowOrParseArgs -> [OptDescr a] -> [OptDescr (Either CommonFlag a)]
addCommonFlags ShowOrParseArgs
showOrParseArgs [OptDescr a]
options =
(OptDescr CommonFlag -> OptDescr (Either CommonFlag a))
-> [OptDescr CommonFlag] -> [OptDescr (Either CommonFlag a)]
forall a b. (a -> b) -> [a] -> [b]
map ((CommonFlag -> Either CommonFlag a)
-> OptDescr CommonFlag -> OptDescr (Either CommonFlag a)
forall a b. (a -> b) -> OptDescr a -> OptDescr b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CommonFlag -> Either CommonFlag a
forall a b. a -> Either a b
Left) (ShowOrParseArgs -> [OptDescr CommonFlag]
commonFlags ShowOrParseArgs
showOrParseArgs)
[OptDescr (Either CommonFlag a)]
-> [OptDescr (Either CommonFlag a)]
-> [OptDescr (Either CommonFlag a)]
forall a. [a] -> [a] -> [a]
++ (OptDescr a -> OptDescr (Either CommonFlag a))
-> [OptDescr a] -> [OptDescr (Either CommonFlag a)]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> Either CommonFlag a)
-> OptDescr a -> OptDescr (Either CommonFlag a)
forall a b. (a -> b) -> OptDescr a -> OptDescr b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either CommonFlag a
forall a b. b -> Either a b
Right) [OptDescr a]
options
commandParseArgs :: CommandUI flags
-> Bool
-> [String]
-> CommandParse (flags -> flags, [String])
commandParseArgs :: forall flags.
CommandUI flags
-> Bool -> LFlags -> CommandParse (flags -> flags, LFlags)
commandParseArgs CommandUI flags
command Bool
global LFlags
args =
let options :: [OptDescr (Either CommonFlag (flags -> flags))]
options = ShowOrParseArgs
-> [OptDescr (flags -> flags)]
-> [OptDescr (Either CommonFlag (flags -> flags))]
forall a.
ShowOrParseArgs -> [OptDescr a] -> [OptDescr (Either CommonFlag a)]
addCommonFlags ShowOrParseArgs
ParseArgs
([OptDescr (flags -> flags)]
-> [OptDescr (Either CommonFlag (flags -> flags))])
-> [OptDescr (flags -> flags)]
-> [OptDescr (Either CommonFlag (flags -> flags))]
forall a b. (a -> b) -> a -> b
$ ShowOrParseArgs -> CommandUI flags -> [OptDescr (flags -> flags)]
forall flags.
ShowOrParseArgs -> CommandUI flags -> [OptDescr (flags -> flags)]
commandGetOpts ShowOrParseArgs
ParseArgs CommandUI flags
command
order :: ArgOrder a
order | Bool
global = ArgOrder a
forall a. ArgOrder a
GetOpt.RequireOrder
| Bool
otherwise = ArgOrder a
forall a. ArgOrder a
GetOpt.Permute
in case ArgOrder (Either CommonFlag (flags -> flags))
-> [OptDescr (Either CommonFlag (flags -> flags))]
-> LFlags
-> ([Either CommonFlag (flags -> flags)], LFlags, LFlags, LFlags)
forall a.
ArgOrder a
-> [OptDescr a] -> LFlags -> ([a], LFlags, LFlags, LFlags)
GetOpt.getOpt' ArgOrder (Either CommonFlag (flags -> flags))
forall a. ArgOrder a
order [OptDescr (Either CommonFlag (flags -> flags))]
options LFlags
args of
([Either CommonFlag (flags -> flags)]
flags, LFlags
_, LFlags
_, LFlags
_)
| (Either CommonFlag (flags -> flags) -> Bool)
-> [Either CommonFlag (flags -> flags)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Either CommonFlag (flags -> flags) -> Bool
forall {b}. Either CommonFlag b -> Bool
listFlag [Either CommonFlag (flags -> flags)]
flags -> LFlags -> CommandParse (flags -> flags, LFlags)
forall flags. LFlags -> CommandParse flags
CommandList (CommandUI flags -> LFlags
forall flags. CommandUI flags -> LFlags
commandListOptions CommandUI flags
command)
| (Either CommonFlag (flags -> flags) -> Bool)
-> [Either CommonFlag (flags -> flags)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Either CommonFlag (flags -> flags) -> Bool
forall {b}. Either CommonFlag b -> Bool
helpFlag [Either CommonFlag (flags -> flags)]
flags -> (String -> String) -> CommandParse (flags -> flags, LFlags)
forall flags. (String -> String) -> CommandParse flags
CommandHelp (CommandUI flags -> String -> String
forall flags. CommandUI flags -> String -> String
commandHelp CommandUI flags
command)
where listFlag :: Either CommonFlag b -> Bool
listFlag (Left CommonFlag
ListOptionsFlag) = Bool
True; listFlag Either CommonFlag b
_ = Bool
False
helpFlag :: Either CommonFlag b -> Bool
helpFlag (Left CommonFlag
HelpFlag) = Bool
True; helpFlag Either CommonFlag b
_ = Bool
False
([Either CommonFlag (flags -> flags)]
flags, LFlags
opts, LFlags
opts', [])
| Bool
global Bool -> Bool -> Bool
|| LFlags -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null LFlags
opts' -> (flags -> flags, LFlags) -> CommandParse (flags -> flags, LFlags)
forall flags. flags -> CommandParse flags
CommandReadyToGo ([Either CommonFlag (flags -> flags)] -> flags -> flags
forall {a} {c}. [Either a (c -> c)] -> c -> c
accum [Either CommonFlag (flags -> flags)]
flags, LFlags -> LFlags -> LFlags
forall a. [a] -> [a] -> [a]
mix LFlags
opts LFlags
opts')
| Bool
otherwise -> LFlags -> CommandParse (flags -> flags, LFlags)
forall flags. LFlags -> CommandParse flags
CommandErrors (LFlags -> LFlags
unrecognised LFlags
opts')
([Either CommonFlag (flags -> flags)]
_, LFlags
_, LFlags
_, LFlags
errs) -> LFlags -> CommandParse (flags -> flags, LFlags)
forall flags. LFlags -> CommandParse flags
CommandErrors LFlags
errs
where
accum :: [Either a (c -> c)] -> c -> c
accum [Either a (c -> c)]
flags = ((c -> c) -> (c -> c) -> c -> c) -> (c -> c) -> [c -> c] -> c -> c
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (((c -> c) -> (c -> c) -> c -> c) -> (c -> c) -> (c -> c) -> c -> c
forall a b c. (a -> b -> c) -> b -> a -> c
flip (c -> c) -> (c -> c) -> c -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)) c -> c
forall a. a -> a
id [ c -> c
f | Right c -> c
f <- [Either a (c -> c)]
flags ]
unrecognised :: LFlags -> LFlags
unrecognised LFlags
opts = [ String
"unrecognized "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (CommandUI flags -> String
forall flags. CommandUI flags -> String
commandName CommandUI flags
command) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" option `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
opt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'\n"
| String
opt <- LFlags
opts ]
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 :: forall a b. (a -> b) -> CommandParse a -> CommandParse b
fmap a -> b
_ (CommandHelp String -> String
help) = (String -> String) -> CommandParse b
forall flags. (String -> String) -> CommandParse flags
CommandHelp String -> String
help
fmap a -> b
_ (CommandList LFlags
opts) = LFlags -> CommandParse b
forall flags. LFlags -> CommandParse flags
CommandList LFlags
opts
fmap a -> b
_ (CommandErrors LFlags
errs) = LFlags -> CommandParse b
forall flags. LFlags -> CommandParse flags
CommandErrors LFlags
errs
fmap a -> b
f (CommandReadyToGo a
flags) = b -> CommandParse b
forall flags. flags -> CommandParse flags
CommandReadyToGo (a -> b
f a
flags)
data CommandType = NormalCommand | HiddenCommand
data Command action =
Command String String ([String] -> CommandParse action) CommandType
hiddenCommand :: Command action -> Command action
hiddenCommand :: forall action. Command action -> Command action
hiddenCommand (Command String
name String
synopsys LFlags -> CommandParse action
f CommandType
_cmdType) =
String
-> String
-> (LFlags -> CommandParse action)
-> CommandType
-> Command action
forall action.
String
-> String
-> (LFlags -> CommandParse action)
-> CommandType
-> Command action
Command String
name String
synopsys LFlags -> CommandParse action
f CommandType
HiddenCommand
commandAddAction :: CommandUI flags
-> (flags -> [String] -> action)
-> Command action
commandAddAction :: forall flags action.
CommandUI flags -> (flags -> LFlags -> action) -> Command action
commandAddAction CommandUI flags
command flags -> LFlags -> action
action =
String
-> String
-> (LFlags -> CommandParse action)
-> CommandType
-> Command action
forall action.
String
-> String
-> (LFlags -> CommandParse action)
-> CommandType
-> Command action
Command (CommandUI flags -> String
forall flags. CommandUI flags -> String
commandName CommandUI flags
command)
(CommandUI flags -> String
forall flags. CommandUI flags -> String
commandSynopsis CommandUI flags
command)
(((flags -> flags, LFlags) -> action)
-> CommandParse (flags -> flags, LFlags) -> CommandParse action
forall a b. (a -> b) -> CommandParse a -> CommandParse b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((flags -> flags) -> LFlags -> action)
-> (flags -> flags, LFlags) -> action
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (flags -> flags) -> LFlags -> action
applyDefaultArgs) (CommandParse (flags -> flags, LFlags) -> CommandParse action)
-> (LFlags -> CommandParse (flags -> flags, LFlags))
-> LFlags
-> CommandParse action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommandUI flags
-> Bool -> LFlags -> CommandParse (flags -> flags, LFlags)
forall flags.
CommandUI flags
-> Bool -> LFlags -> CommandParse (flags -> flags, LFlags)
commandParseArgs CommandUI flags
command Bool
False)
CommandType
NormalCommand
where applyDefaultArgs :: (flags -> flags) -> LFlags -> action
applyDefaultArgs flags -> flags
mkflags LFlags
args =
let flags :: flags
flags = flags -> flags
mkflags (CommandUI flags -> flags
forall flags. CommandUI flags -> flags
commandDefaultFlags CommandUI flags
command)
in flags -> LFlags -> action
action flags
flags LFlags
args
commandsRun :: CommandUI a
-> [Command action]
-> [String]
-> CommandParse (a, CommandParse action)
commandsRun :: forall a action.
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 a. String -> CommandParse a
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 a
badCommand :: forall a. String -> CommandParse a
badCommand String
cname =
case LFlags
eDists of
[] -> LFlags -> CommandParse a
forall flags. LFlags -> CommandParse flags
CommandErrors [String
unErr]
(String
s:LFlags
_) -> LFlags -> CommandParse a
forall flags. LFlags -> CommandParse flags
CommandErrors [ String
unErr
, String
"Maybe you meant `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"`?\n"]
where
eDists :: LFlags
eDists = ((String, Int) -> String) -> [(String, Int)] -> LFlags
forall a b. (a -> b) -> [a] -> [b]
map (String, Int) -> String
forall a b. (a, b) -> a
fst ([(String, Int)] -> LFlags)
-> ([(String, Int)] -> [(String, Int)])
-> [(String, Int)]
-> LFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, Int) -> (String, Int) -> Ordering)
-> [(String, Int)] -> [(String, Int)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
List.sortBy (((String, Int) -> Int)
-> (String, Int) -> (String, Int) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (String, Int) -> Int
forall a b. (a, b) -> b
snd) ([(String, Int)] -> LFlags) -> [(String, Int)] -> LFlags
forall a b. (a -> b) -> a -> b
$
[ (String
cname', Int
dist)
| (Command String
cname' String
_ LFlags -> CommandParse action
_ CommandType
_) <- [Command action]
commands'
, let dist :: Int
dist = String -> String -> Int
forall a. Eq a => [a] -> [a] -> Int
editDistance String
cname' String
cname
, Int
dist Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
5 ]
unErr :: String
unErr = String
"unrecognised command: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (try --help)"
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' ]
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 a. String -> CommandParse a
badCommand String
name
where globalHelp :: String -> String
globalHelp = CommandUI a -> String -> String
forall flags. CommandUI flags -> String -> String
commandHelp CommandUI a
globalCommand
editDistance :: Eq a => [a] -> [a] -> Int
editDistance :: forall a. Eq a => [a] -> [a] -> Int
editDistance [a]
xs [a]
ys = Array (Int, Int) Int
table Array (Int, Int) Int -> (Int, Int) -> Int
forall i e. Ix i => Array i e -> i -> e
Array.! (Int
m,Int
n)
where
(Int
m,Int
n) = ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs, [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
ys)
x :: Array Int a
x = (Int, Int) -> [(Int, a)] -> Array Int a
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
Array.array (Int
1,Int
m) ([Int] -> [a] -> [(Int, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [a]
xs)
y :: Array Int a
y = (Int, Int) -> [(Int, a)] -> Array Int a
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
Array.array (Int
1,Int
n) ([Int] -> [a] -> [(Int, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [a]
ys)
table :: Array.Array (Int,Int) Int
table :: Array (Int, Int) Int
table = ((Int, Int), (Int, Int))
-> [((Int, Int), Int)] -> Array (Int, Int) Int
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
Array.array ((Int, Int), (Int, Int))
bnds [((Int, Int)
ij, (Int, Int) -> Int
dist (Int, Int)
ij) | (Int, Int)
ij <- ((Int, Int), (Int, Int)) -> [(Int, Int)]
forall a. Ix a => (a, a) -> [a]
Array.range ((Int, Int), (Int, Int))
bnds]
bnds :: ((Int, Int), (Int, Int))
bnds = ((Int
0,Int
0),(Int
m,Int
n))
dist :: (Int, Int) -> Int
dist (Int
0,Int
j) = Int
j
dist (Int
i,Int
0) = Int
i
dist (Int
i,Int
j) = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum
[ Array (Int, Int) Int
table Array (Int, Int) Int -> (Int, Int) -> Int
forall i e. Ix i => Array i e -> i -> e
Array.! (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1,Int
j) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
, Array (Int, Int) Int
table Array (Int, Int) Int -> (Int, Int) -> Int
forall i e. Ix i => Array i e -> i -> e
Array.! (Int
i,Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
, if Array Int a
x Array Int a -> Int -> a
forall i e. Ix i => Array i e -> i -> e
Array.! Int
i a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== Array Int a
y Array Int a -> Int -> a
forall i e. Ix i => Array i e -> i -> e
Array.! Int
j
then Array (Int, Int) Int
table Array (Int, Int) Int -> (Int, Int) -> Int
forall i e. Ix i => Array i e -> i -> e
Array.! (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1,Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
else Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Array (Int, Int) Int
table Array (Int, Int) Int -> (Int, Int) -> Int
forall i e. Ix i => Array i e -> i -> e
Array.! (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1,Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
]
noExtraFlags :: [String] -> IO ()
[] = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
noExtraFlags LFlags
extraFlags =
String -> IO ()
forall a. String -> IO a
dieNoVerbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Unrecognised flags: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> LFlags -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " LFlags
extraFlags
getNormalCommandDescriptions :: [Command action] -> [(String, String)]
getNormalCommandDescriptions :: forall action. [Command action] -> [(String, String)]
getNormalCommandDescriptions [Command action]
cmds =
[ (String
name, String
description)
| Command String
name String
description LFlags -> CommandParse action
_ CommandType
NormalCommand <- [Command action]
cmds ]
helpCommandUI :: CommandUI ()
helpCommandUI :: CommandUI ()
helpCommandUI =
(String
-> String
-> LFlags
-> ()
-> (ShowOrParseArgs -> [OptionField ()])
-> CommandUI ()
forall flags.
String
-> String
-> LFlags
-> flags
-> (ShowOrParseArgs -> [OptionField flags])
-> CommandUI flags
mkCommandUI
String
"help"
String
"Help about commands."
[String
"[FLAGS]", String
"COMMAND [FLAGS]"]
()
([OptionField ()] -> ShowOrParseArgs -> [OptionField ()]
forall a b. a -> b -> a
const []))
{
commandNotes :: 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"
}
data CommandSpec action
= forall flags. CommandSpec (CommandUI flags) (CommandUI flags -> Command action) CommandType
commandFromSpec :: CommandSpec a -> Command a
commandFromSpec :: forall a. CommandSpec a -> Command a
commandFromSpec (CommandSpec CommandUI flags
ui CommandUI flags -> Command a
action CommandType
_) = CommandUI flags -> Command a
action CommandUI flags
ui