-- Command-line option parsing using applicative functors.
-- Parsers are represented as values of type OptionParser a,
-- and run using the function
--   parseCommandLine :: String -> OptionParser a -> IO a.
-- OptionParsers are built from ArgParsers, which parse a single
-- option (e.g. --verbosity 3).

{-# LANGUAGE FlexibleContexts, CPP #-}
module Jukebox.Options where

import Data.Char
import Data.List
import System.Environment
import System.Exit
import System.IO
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
import Data.Monoid
#endif
import Data.Semigroup(Semigroup(..))
import Control.Monad

----------------------------------------------------------------------
-- A parser of some kind annotated with a help text of some kind
data Annotated d p a = Annotated
  { Annotated d p a -> d
descr :: d,
    Annotated d p a -> p a
parser :: p a }

instance Functor p => Functor (Annotated d p) where
  fmap :: (a -> b) -> Annotated d p a -> Annotated d p b
fmap a -> b
f (Annotated d
d p a
x) = d -> p b -> Annotated d p b
forall d (p :: * -> *) a. d -> p a -> Annotated d p a
Annotated d
d ((a -> b) -> p a -> p b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f p a
x)

instance (Monoid d, Applicative p) => Applicative (Annotated d p) where
  pure :: a -> Annotated d p a
pure = d -> p a -> Annotated d p a
forall d (p :: * -> *) a. d -> p a -> Annotated d p a
Annotated d
forall a. Monoid a => a
mempty (p a -> Annotated d p a) -> (a -> p a) -> a -> Annotated d p a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> p a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Annotated d
d p (a -> b)
f <*> :: Annotated d p (a -> b) -> Annotated d p a -> Annotated d p b
<*> Annotated d
d' p a
x =
    d -> p b -> Annotated d p b
forall d (p :: * -> *) a. d -> p a -> Annotated d p a
Annotated (d
d d -> d -> d
forall a. Monoid a => a -> a -> a
`mappend` d
d') (p (a -> b)
f p (a -> b) -> p a -> p b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> p a
x)

instance (Semigroup d, Monoid d, Semigroup (p a), Monoid (p a)) => Monoid (Annotated d p a) where
  mempty :: Annotated d p a
mempty = d -> p a -> Annotated d p a
forall d (p :: * -> *) a. d -> p a -> Annotated d p a
Annotated d
forall a. Monoid a => a
mempty p a
forall a. Monoid a => a
mempty
  mappend :: Annotated d p a -> Annotated d p a -> Annotated d p a
mappend = Annotated d p a -> Annotated d p a -> Annotated d p a
forall a. Semigroup a => a -> a -> a
(<>)

instance (Semigroup d, Semigroup (p a)) => Semigroup (Annotated d p a) where
  Annotated d
d p a
p <> :: Annotated d p a -> Annotated d p a -> Annotated d p a
<> Annotated d
d' p a
p' =
    d -> p a -> Annotated d p a
forall d (p :: * -> *) a. d -> p a -> Annotated d p a
Annotated (d
d d -> d -> d
forall a. Semigroup a => a -> a -> a
<> d
d') (p a
p p a -> p a -> p a
forall a. Semigroup a => a -> a -> a
<> p a
p')

----------------------------------------------------------------------
-- The ArgParser type: parsing of single flags.

type ArgParser = Annotated [String] SeqParser
  -- annotated with a description, e.g. "<number>"

-- Called SeqParser because <*> is sequential composition.
data SeqParser a = SeqParser
  { SeqParser a -> Int
args :: Int, -- How many arguments will be consumed
    SeqParser a -> [String] -> Either Error a
consume :: [String] -> Either Error a }

instance Functor SeqParser where
  fmap :: (a -> b) -> SeqParser a -> SeqParser b
fmap a -> b
f (SeqParser Int
a [String] -> Either Error a
c) = Int -> ([String] -> Either Error b) -> SeqParser b
forall a. Int -> ([String] -> Either Error a) -> SeqParser a
SeqParser Int
a ((a -> b) -> Either Error a -> Either Error b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Either Error a -> Either Error b)
-> ([String] -> Either Error a) -> [String] -> Either Error b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Either Error a
c)

instance Applicative SeqParser where
  pure :: a -> SeqParser a
pure = Int -> ([String] -> Either Error a) -> SeqParser a
forall a. Int -> ([String] -> Either Error a) -> SeqParser a
SeqParser Int
0 (([String] -> Either Error a) -> SeqParser a)
-> (a -> [String] -> Either Error a) -> a -> SeqParser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Error a -> [String] -> Either Error a
forall a b. a -> b -> a
const (Either Error a -> [String] -> Either Error a)
-> (a -> Either Error a) -> a -> [String] -> Either Error a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  SeqParser Int
a [String] -> Either Error (a -> b)
c <*> :: SeqParser (a -> b) -> SeqParser a -> SeqParser b
<*> SeqParser Int
a' [String] -> Either Error a
c' = Int -> ([String] -> Either Error b) -> SeqParser b
forall a. Int -> ([String] -> Either Error a) -> SeqParser a
SeqParser (Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
a') [String] -> Either Error b
f
    where f :: [String] -> Either Error b
f [String]
xs = [String] -> Either Error (a -> b)
c [String]
xs Either Error (a -> b) -> Either Error a -> Either Error b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [String] -> Either Error a
c' (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop Int
a [String]
xs)

----------------------------------------------------------------------
-- Combinators for building ArgParsers.

arg :: String -> String -> (String -> Maybe a) -> ArgParser a
arg :: String -> String -> (String -> Maybe a) -> ArgParser a
arg String
desc String
err String -> Maybe a
f = [String] -> SeqParser a -> ArgParser a
forall d (p :: * -> *) a. d -> p a -> Annotated d p a
Annotated [String
desc] (Int -> ([String] -> Either Error a) -> SeqParser a
forall a. Int -> ([String] -> Either Error a) -> SeqParser a
SeqParser Int
1 [String] -> Either Error a
c)
  where c :: [String] -> Either Error a
c [] = Error -> Either Error a
forall a b. a -> Either a b
Left (String -> Error
Mistake String
err)
        c (String
x:[String]
_) | String
"-" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
x = Error -> Either Error a
forall a b. a -> Either a b
Left (String -> Error
Mistake String
err)
        c (String
x:[String]
_) =
          case String -> Maybe a
f String
x of
            Maybe a
Nothing -> Error -> Either Error a
forall a b. a -> Either a b
Left (String -> Error
Mistake String
err)
            Just a
ok -> a -> Either Error a
forall a b. b -> Either a b
Right a
ok

argNum :: (Read a, Num a) => ArgParser a
argNum :: ArgParser a
argNum = String -> String -> (String -> Maybe a) -> ArgParser a
forall a. String -> String -> (String -> Maybe a) -> ArgParser a
arg String
"<num>" String
"expected a number" String -> Maybe a
forall a. Read a => String -> Maybe a
f
  where f :: String -> Maybe a
f String
x =
          case ReadS a
forall a. Read a => ReadS a
reads String
x of
            [(a
y, String
"")] -> a -> Maybe a
forall a. a -> Maybe a
Just a
y
            [(a, String)]
_ -> Maybe a
forall a. Maybe a
Nothing

argFile :: ArgParser FilePath
argFile :: ArgParser String
argFile = String -> String -> (String -> Maybe String) -> ArgParser String
forall a. String -> String -> (String -> Maybe a) -> ArgParser a
arg String
"<file>" String
"expected a file" String -> Maybe String
forall a. a -> Maybe a
Just

argFiles :: ArgParser [FilePath]
argFiles :: ArgParser [String]
argFiles = String
-> String -> (String -> Maybe [String]) -> ArgParser [String]
forall a. String -> String -> (String -> Maybe a) -> ArgParser a
arg String
"<files>" String
"expected a list of files" ((String -> Maybe [String]) -> ArgParser [String])
-> (String -> Maybe [String]) -> ArgParser [String]
forall a b. (a -> b) -> a -> b
$ \String
x ->
  [String] -> Maybe [String]
forall a. a -> Maybe a
Just ([String] -> Maybe [String]) -> [String] -> Maybe [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
elts (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
","
  where
    elts :: String -> [String]
elts [] = []
    elts String
s  = String
wString -> [String] -> [String]
forall a. a -> [a] -> [a]
:String -> [String]
elts String
r
      where
        w :: String
w = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
',') String
s
        r :: String
r = String -> String
forall a. [a] -> [a]
tail ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
',') String
s)

argName :: ArgParser String
argName :: ArgParser String
argName = String -> String -> (String -> Maybe String) -> ArgParser String
forall a. String -> String -> (String -> Maybe a) -> ArgParser a
arg String
"<name>" String
"expected a name" String -> Maybe String
forall a. a -> Maybe a
Just

argNums :: ArgParser [Int]
argNums :: ArgParser [Int]
argNums = String -> String -> (String -> Maybe [Int]) -> ArgParser [Int]
forall a. String -> String -> (String -> Maybe a) -> ArgParser a
arg String
"<nums>" String
"expected a number list" ((String -> Maybe [Int]) -> ArgParser [Int])
-> (String -> Maybe [Int]) -> ArgParser [Int]
forall a b. (a -> b) -> a -> b
$ \String
x ->
  [String] -> Maybe [Int]
forall a. (Read a, Enum a) => [String] -> Maybe [a]
nums ([String] -> Maybe [Int])
-> (String -> [String]) -> String -> Maybe [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char -> Bool) -> String -> [String]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\Char
x Char
y -> Char -> Bool
isDigit Char
x Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Bool
isDigit Char
y) (String -> Maybe [Int]) -> String -> Maybe [Int]
forall a b. (a -> b) -> a -> b
$ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
","
  where
    nums :: [String] -> Maybe [a]
nums []                = [a] -> Maybe [a]
forall a. a -> Maybe a
Just []
    nums (String
n:String
",":[String]
ns)        = (String -> a
forall a. Read a => String -> a
read String
n a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a]) -> Maybe [a] -> Maybe [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` [String] -> Maybe [a]
nums [String]
ns
    nums (String
n:String
"..":String
m:String
",":[String]
ns) = ([String -> a
forall a. Read a => String -> a
read String
n .. String -> a
forall a. Read a => String -> a
read String
m] [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++) ([a] -> [a]) -> Maybe [a] -> Maybe [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` [String] -> Maybe [a]
nums [String]
ns
    nums [String]
_                 = Maybe [a]
forall a. Maybe a
Nothing

argOption :: [(String, a)] -> ArgParser a
argOption :: [(String, a)] -> ArgParser a
argOption [(String, a)]
as =
  String
-> String
-> String
-> [String]
-> (String -> Maybe a)
-> ArgParser a
forall a.
String
-> String
-> String
-> [String]
-> (String -> Maybe a)
-> ArgParser a
argOptionWith String
"one" String
"or" String
"" (((String, a) -> String) -> [(String, a)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, a) -> String
forall a b. (a, b) -> a
fst [(String, a)]
as) (String -> [(String, a)] -> Maybe a
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(String, a)]
as)

argList :: [String] -> ArgParser [String]
argList :: [String] -> ArgParser [String]
argList [String]
as =
  String
-> String
-> String
-> [String]
-> (String -> Maybe [String])
-> ArgParser [String]
forall a.
String
-> String
-> String
-> [String]
-> (String -> Maybe a)
-> ArgParser a
argOptionWith String
"several" String
"and" String
"*" [String]
as ((String -> Maybe [String]) -> ArgParser [String])
-> (String -> Maybe [String]) -> ArgParser [String]
forall a b. (a -> b) -> a -> b
$ \String
x -> String -> Maybe [String]
elts (String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
",")
  where
    elts :: String -> Maybe [String]
elts []              = [String] -> Maybe [String]
forall a. a -> Maybe a
Just []
    elts String
s | String
w String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
as = (String
wString -> [String] -> [String]
forall a. a -> [a] -> [a]
:) ([String] -> [String]) -> Maybe [String] -> Maybe [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> Maybe [String]
elts String
r
      where
        w :: String
w = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
',') String
s
        r :: String
r = String -> String
forall a. [a] -> [a]
tail ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
',') String
s)
    
    elts String
_ = Maybe [String]
forall a. Maybe a
Nothing

argOptionWith :: String -> String -> String -> [String] -> (String -> Maybe a) -> ArgParser a
argOptionWith :: String
-> String
-> String
-> [String]
-> (String -> Maybe a)
-> ArgParser a
argOptionWith String
one String
or String
suff [String]
opts String -> Maybe a
p =
  String -> String -> (String -> Maybe a) -> ArgParser a
forall a. String -> String -> (String -> Maybe a) -> ArgParser a
arg (String
"<" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" | " [String]
opts String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
suff)
    (String
"expected " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
one String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
list) String -> Maybe a
p
  where
    list :: String
list =
      case [String]
opts of
        [] -> String
"<empty list>" -- ??
        [String]
_ ->
          String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([String] -> [String]
forall a. [a] -> [a]
init [String]
opts) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
or String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. [a] -> a
last [String]
opts

-- A parser that always fails but produces an error message (useful for --help etc.)
argUsage :: ExitCode -> [String] -> ArgParser a
argUsage :: ExitCode -> [String] -> ArgParser a
argUsage ExitCode
code [String]
err = [String] -> SeqParser a -> ArgParser a
forall d (p :: * -> *) a. d -> p a -> Annotated d p a
Annotated [] (Int -> ([String] -> Either Error a) -> SeqParser a
forall a. Int -> ([String] -> Either Error a) -> SeqParser a
SeqParser Int
0 (Either Error a -> [String] -> Either Error a
forall a b. a -> b -> a
const (Error -> Either Error a
forall a b. a -> Either a b
Left (ExitCode -> [String] -> Error
Usage ExitCode
code [String]
err))))

----------------------------------------------------------------------
-- The OptionParser type: parsing of whole command lines.

type OptionParser = Annotated [Flag] ParParser

-- The help information for a flag.
data Flag = Flag
  { Flag -> String
flagName :: String,
    Flag -> String
flagGroup :: String,
    Flag -> FlagMode
flagMode :: FlagMode,
    Flag -> [String]
flagHelp :: [String],
    Flag -> String
flagArgs :: String } deriving (Flag -> Flag -> Bool
(Flag -> Flag -> Bool) -> (Flag -> Flag -> Bool) -> Eq Flag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Flag -> Flag -> Bool
$c/= :: Flag -> Flag -> Bool
== :: Flag -> Flag -> Bool
$c== :: Flag -> Flag -> Bool
Eq, Int -> Flag -> String -> String
[Flag] -> String -> String
Flag -> String
(Int -> Flag -> String -> String)
-> (Flag -> String) -> ([Flag] -> String -> String) -> Show Flag
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Flag] -> String -> String
$cshowList :: [Flag] -> String -> String
show :: Flag -> String
$cshow :: Flag -> String
showsPrec :: Int -> Flag -> String -> String
$cshowsPrec :: Int -> Flag -> String -> String
Show)
data FlagMode = NormalMode | ExpertMode | HiddenMode deriving (FlagMode -> FlagMode -> Bool
(FlagMode -> FlagMode -> Bool)
-> (FlagMode -> FlagMode -> Bool) -> Eq FlagMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FlagMode -> FlagMode -> Bool
$c/= :: FlagMode -> FlagMode -> Bool
== :: FlagMode -> FlagMode -> Bool
$c== :: FlagMode -> FlagMode -> Bool
Eq, Int -> FlagMode -> String -> String
[FlagMode] -> String -> String
FlagMode -> String
(Int -> FlagMode -> String -> String)
-> (FlagMode -> String)
-> ([FlagMode] -> String -> String)
-> Show FlagMode
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [FlagMode] -> String -> String
$cshowList :: [FlagMode] -> String -> String
show :: FlagMode -> String
$cshow :: FlagMode -> String
showsPrec :: Int -> FlagMode -> String -> String
$cshowsPrec :: Int -> FlagMode -> String -> String
Show)

flagExpert :: Flag -> Bool
flagExpert :: Flag -> Bool
flagExpert Flag
f = Flag -> FlagMode
flagMode Flag
f FlagMode -> FlagMode -> Bool
forall a. Eq a => a -> a -> Bool
== FlagMode
ExpertMode

-- Called ParParser because <*> is parallel composition.
-- In other words, in f <*> x, f and x both see the whole command line.
-- We want this when parsing command lines because
-- it doesn't matter what order we write the options in,
-- and because f and x might understand the same flags.
data ParParser a = ParParser
  { ParParser a -> Either Error (IO a)
val :: Either Error (IO a), -- impure so we can put system information in our options records
    ParParser a -> [String] -> ParseResult a
peek :: [String] -> ParseResult a }

data ParseResult a
    -- Yes n x: consumed n arguments, continue parsing with x
  = Yes Int (ParParser a)
    -- No x: didn't understand this flag, continue parsing with x
  | No (ParParser a)
    -- Error
  | Error Error

data Error =
    Mistake String
  | Usage ExitCode [String]

instance Functor ParParser where
  fmap :: (a -> b) -> ParParser a -> ParParser b
fmap a -> b
f ParParser a
x = (a -> b) -> ParParser (a -> b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> b
f ParParser (a -> b) -> ParParser a -> ParParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParParser a
x

instance Applicative ParParser where
  pure :: a -> ParParser a
pure a
x = Either Error (IO a) -> ([String] -> ParseResult a) -> ParParser a
forall a.
Either Error (IO a) -> ([String] -> ParseResult a) -> ParParser a
ParParser (IO a -> Either Error (IO a)
forall a b. b -> Either a b
Right (a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x)) (ParseResult a -> [String] -> ParseResult a
forall a b. a -> b -> a
const (a -> ParseResult a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x))
  ParParser Either Error (IO (a -> b))
v [String] -> ParseResult (a -> b)
p <*> :: ParParser (a -> b) -> ParParser a -> ParParser b
<*> ParParser Either Error (IO a)
v' [String] -> ParseResult a
p' =
    Either Error (IO b) -> ([String] -> ParseResult b) -> ParParser b
forall a.
Either Error (IO a) -> ([String] -> ParseResult a) -> ParParser a
ParParser ((IO (a -> b) -> IO a -> IO b)
-> Either Error (IO (a -> b))
-> Either Error (IO a)
-> Either Error (IO b)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) Either Error (IO (a -> b))
v Either Error (IO a)
v') (\[String]
xs -> [String] -> ParseResult (a -> b)
p [String]
xs ParseResult (a -> b) -> ParseResult a -> ParseResult b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [String] -> ParseResult a
p' [String]
xs)

instance Functor ParseResult where
  fmap :: (a -> b) -> ParseResult a -> ParseResult b
fmap a -> b
f ParseResult a
x = (a -> b) -> ParseResult (a -> b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> b
f ParseResult (a -> b) -> ParseResult a -> ParseResult b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParseResult a
x

instance Applicative ParseResult where
  pure :: a -> ParseResult a
pure = ParParser a -> ParseResult a
forall a. ParParser a -> ParseResult a
No (ParParser a -> ParseResult a)
-> (a -> ParParser a) -> a -> ParseResult a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ParParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Yes Int
n ParParser (a -> b)
r <*> :: ParseResult (a -> b) -> ParseResult a -> ParseResult b
<*> Yes Int
n' ParParser a
r'
    | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n' = Int -> ParParser b -> ParseResult b
forall a. Int -> ParParser a -> ParseResult a
Yes Int
n (ParParser (a -> b)
r ParParser (a -> b) -> ParParser a -> ParParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParParser a
r')
    | Bool
otherwise = String -> ParseResult b
forall a. HasCallStack => String -> a
error String
"Options.ParseResult: inconsistent number of arguments"
  Error Error
s <*> ParseResult a
_ = Error -> ParseResult b
forall a. Error -> ParseResult a
Error Error
s
  ParseResult (a -> b)
_ <*> Error Error
s = Error -> ParseResult b
forall a. Error -> ParseResult a
Error Error
s
  Yes Int
n ParParser (a -> b)
r <*> No ParParser a
x = Int -> ParParser b -> ParseResult b
forall a. Int -> ParParser a -> ParseResult a
Yes Int
n (ParParser (a -> b)
r ParParser (a -> b) -> ParParser a -> ParParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParParser a
x)
  No ParParser (a -> b)
x <*> Yes Int
n ParParser a
r = Int -> ParParser b -> ParseResult b
forall a. Int -> ParParser a -> ParseResult a
Yes Int
n (ParParser (a -> b)
x ParParser (a -> b) -> ParParser a -> ParParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParParser a
r)
  No ParParser (a -> b)
f <*> No ParParser a
x = ParParser b -> ParseResult b
forall a. ParParser a -> ParseResult a
No (ParParser (a -> b)
f ParParser (a -> b) -> ParParser a -> ParParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParParser a
x)

runPar :: ParParser a -> [String] -> Either Error (IO a)
runPar :: ParParser a -> [String] -> Either Error (IO a)
runPar ParParser a
p [] = ParParser a -> Either Error (IO a)
forall a. ParParser a -> Either Error (IO a)
val ParParser a
p
runPar ParParser a
p xs :: [String]
xs@(String
x:[String]
_) =
  case ParParser a -> [String] -> ParseResult a
forall a. ParParser a -> [String] -> ParseResult a
peek ParParser a
p [String]
xs of
    Yes Int
n ParParser a
p' -> ParParser a -> [String] -> Either Error (IO a)
forall a. ParParser a -> [String] -> Either Error (IO a)
runPar ParParser a
p' (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop Int
n [String]
xs)
    No ParParser a
_ -> Error -> Either Error (IO a)
forall a b. a -> Either a b
Left (String -> Error
Mistake (String
"Didn't recognise option " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x))
    Error Error
err -> Error -> Either Error (IO a)
forall a b. a -> Either a b
Left Error
err

await :: (String -> Bool) -> Either Error a -> (String -> [String] -> ParseResult a) -> ParParser a
await :: (String -> Bool)
-> Either Error a
-> (String -> [String] -> ParseResult a)
-> ParParser a
await String -> Bool
p Either Error a
def String -> [String] -> ParseResult a
par = Either Error (IO a) -> ([String] -> ParseResult a) -> ParParser a
forall a.
Either Error (IO a) -> ([String] -> ParseResult a) -> ParParser a
ParParser (a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> Either Error a -> Either Error (IO a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error a
def) [String] -> ParseResult a
f
  where f :: [String] -> ParseResult a
f (String
x:[String]
xs) | String -> Bool
p String
x =
          case String -> [String] -> ParseResult a
par String
x [String]
xs of
            Yes Int
n ParParser a
r -> Int -> ParParser a -> ParseResult a
forall a. Int -> ParParser a -> ParseResult a
Yes (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) ParParser a
r
            No ParParser a
_ ->
              String -> ParseResult a
forall a. HasCallStack => String -> a
error String
"Options.await: got No"
            Error Error
err -> Error -> ParseResult a
forall a. Error -> ParseResult a
Error Error
err
        f [String]
_ = ParParser a -> ParseResult a
forall a. ParParser a -> ParseResult a
No ((String -> Bool)
-> Either Error a
-> (String -> [String] -> ParseResult a)
-> ParParser a
forall a.
(String -> Bool)
-> Either Error a
-> (String -> [String] -> ParseResult a)
-> ParParser a
await String -> Bool
p Either Error a
def String -> [String] -> ParseResult a
par)

----------------------------------------------------------------------
-- Low-level primitives for building OptionParsers.

-- Produce an OptionParser with maximum flexibility.
primFlag ::
  -- Name and description of options (for documentation)
  String -> [String] ->
  -- Predicate which checks if this argument is our option
  (String -> Bool) ->
  -- Handle repeated occurrences of the same option
  (a -> a -> Either Error a) ->
  -- Default argument value and argument parser
  -- The argument parser is given the option name.
  a -> ArgParser (String -> a) -> OptionParser a
primFlag :: String
-> [String]
-> (String -> Bool)
-> (a -> a -> Either Error a)
-> a
-> ArgParser (String -> a)
-> OptionParser a
primFlag String
name [String]
help String -> Bool
p a -> a -> Either Error a
combine a
def (Annotated [String]
desc (SeqParser Int
args [String] -> Either Error (String -> a)
f)) =
  [Flag] -> ParParser a -> OptionParser a
forall d (p :: * -> *) a. d -> p a -> Annotated d p a
Annotated [Flag
desc'] ((String -> Bool)
-> Either Error a
-> (String -> [String] -> ParseResult a)
-> ParParser a
forall a.
(String -> Bool)
-> Either Error a
-> (String -> [String] -> ParseResult a)
-> ParParser a
await String -> Bool
p (a -> Either Error a
forall a b. b -> Either a b
Right a
def) ((a -> Either Error a) -> String -> [String] -> ParseResult a
g a -> Either Error a
forall a b. b -> Either a b
Right))
  where desc' :: Flag
desc' = String -> String -> FlagMode -> [String] -> String -> Flag
Flag String
name String
"General options" FlagMode
NormalMode [String]
help ([String] -> String
unwords [String]
desc)
        g :: (a -> Either Error a) -> String -> [String] -> ParseResult a
g a -> Either Error a
comb String
x [String]
xs =
          case [String] -> Either Error (String -> a)
f [String]
xs Either Error (String -> a)
-> ((String -> a) -> Either Error a) -> Either Error a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Either Error a
comb (a -> Either Error a)
-> ((String -> a) -> a) -> (String -> a) -> Either Error a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
x) of
            Left (Mistake String
err) -> Error -> ParseResult a
forall a. Error -> ParseResult a
Error (String -> Error
Mistake (String
"Error in option --" 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
err))
            Left (Usage ExitCode
code [String]
err) -> Error -> ParseResult a
forall a. Error -> ParseResult a
Error (ExitCode -> [String] -> Error
Usage ExitCode
code [String]
err)
            Right a
y ->
              Int -> ParParser a -> ParseResult a
forall a. Int -> ParParser a -> ParseResult a
Yes Int
args ((String -> Bool)
-> Either Error a
-> (String -> [String] -> ParseResult a)
-> ParParser a
forall a.
(String -> Bool)
-> Either Error a
-> (String -> [String] -> ParseResult a)
-> ParParser a
await String -> Bool
p (a -> Either Error a
forall a b. b -> Either a b
Right a
y) ((a -> Either Error a) -> String -> [String] -> ParseResult a
g (a -> a -> Either Error a
combine a
y)))

----------------------------------------------------------------------
-- Combinators for building OptionParsers.

-- From a flag name and description and argument parser, produce an OptionParser.
flag :: String -> [String] -> a -> ArgParser a -> OptionParser a
flag :: String -> [String] -> a -> ArgParser a -> OptionParser a
flag String
name [String]
help a
def ArgParser a
p =
  String
-> [String]
-> (String -> Bool)
-> (a -> a -> Either Error a)
-> a
-> ArgParser (String -> a)
-> OptionParser a
forall a.
String
-> [String]
-> (String -> Bool)
-> (a -> a -> Either Error a)
-> a
-> ArgParser (String -> a)
-> OptionParser a
primFlag String
name [String]
help
    (\String
x -> String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name)
    (\a
_ a
y -> a -> Either Error a
forall (m :: * -> *) a. Monad m => a -> m a
return a
y) -- take second occurrence of flag
    a
def (a -> String -> a
forall a b. a -> b -> a
const (a -> String -> a) -> ArgParser a -> ArgParser (String -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgParser a
p)

-- A variant of 'flag' that allows repeated flags.
manyFlags :: String -> [String] -> ArgParser a -> OptionParser [a]
manyFlags :: String -> [String] -> ArgParser a -> OptionParser [a]
manyFlags String
name [String]
help ArgParser a
p =
  String
-> [String]
-> (String -> Bool)
-> ([a] -> [a] -> Either Error [a])
-> [a]
-> ArgParser (String -> [a])
-> OptionParser [a]
forall a.
String
-> [String]
-> (String -> Bool)
-> (a -> a -> Either Error a)
-> a
-> ArgParser (String -> a)
-> OptionParser a
primFlag String
name [String]
help
    (\String
x -> String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name)
    (\[a]
x [a]
y -> [a] -> Either Error [a]
forall (m :: * -> *) a. Monad m => a -> m a
return ([a]
x [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
y))
    [] ([a] -> String -> [a]
forall a b. a -> b -> a
const ([a] -> String -> [a]) -> (a -> [a]) -> a -> String -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> String -> [a]) -> ArgParser a -> ArgParser (String -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgParser a
p)

-- A boolean flag.
bool :: String -> [String] -> Bool -> OptionParser Bool
bool :: String -> [String] -> Bool -> OptionParser Bool
bool String
name [String]
help Bool
def =
  String
-> [String]
-> (String -> Bool)
-> (Bool -> Bool -> Either Error Bool)
-> Bool
-> ArgParser (String -> Bool)
-> OptionParser Bool
forall a.
String
-> [String]
-> (String -> Bool)
-> (a -> a -> Either Error a)
-> a
-> ArgParser (String -> a)
-> OptionParser a
primFlag (String
"(no-)" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name) [String]
help
    (\String
x -> String
x String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name, String
"--no-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name])
    (\Bool
_ Bool
y -> Bool -> Either Error Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
y)
    Bool
def
    ((String -> Bool) -> ArgParser (String -> Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\String
name' -> if String
"--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
name' then Bool
True else Bool
False))

-- A parser that reads all file names from the command line.
filenames :: OptionParser [String]
filenames :: OptionParser [String]
filenames = [Flag] -> ParParser [String] -> OptionParser [String]
forall d (p :: * -> *) a. d -> p a -> Annotated d p a
Annotated [] ((String -> Bool)
-> Either Error [String]
-> (String -> [String] -> ParseResult [String])
-> ParParser [String]
forall a.
(String -> Bool)
-> Either Error a
-> (String -> [String] -> ParseResult a)
-> ParParser a
await String -> Bool
p (Error -> Either Error [String]
forall a b. a -> Either a b
Left Error
err) ([String] -> String -> [String] -> ParseResult [String]
f []))
  where p :: String -> Bool
p String
x = Bool -> Bool
not (String
"-" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
x) Bool -> Bool -> Bool
|| String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"-"
        f :: [String] -> String -> [String] -> ParseResult [String]
f [String]
xs String
y [String]
_ = Int -> ParParser [String] -> ParseResult [String]
forall a. Int -> ParParser a -> ParseResult a
Yes Int
0 (let ys :: [String]
ys = [String]
xs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
y] in (String -> Bool)
-> Either Error [String]
-> (String -> [String] -> ParseResult [String])
-> ParParser [String]
forall a.
(String -> Bool)
-> Either Error a
-> (String -> [String] -> ParseResult a)
-> ParParser a
await String -> Bool
p ([String] -> Either Error [String]
forall a b. b -> Either a b
Right [String]
ys) ([String] -> String -> [String] -> ParseResult [String]
f [String]
ys))

        err :: Error
err =
          ExitCode -> [String] -> Error
Usage (Int -> ExitCode
ExitFailure Int
1)
            [String
"No input files specified! Try --help.",
             String
"You can use \"-\" to read from standard input."]

-- Take a value from the environment.
io :: IO a -> OptionParser a
io :: IO a -> OptionParser a
io IO a
m = [Flag] -> ParParser a -> OptionParser a
forall d (p :: * -> *) a. d -> p a -> Annotated d p a
Annotated [] ParParser a
p
  where p :: ParParser a
p = Either Error (IO a) -> ([String] -> ParseResult a) -> ParParser a
forall a.
Either Error (IO a) -> ([String] -> ParseResult a) -> ParParser a
ParParser (IO a -> Either Error (IO a)
forall a b. b -> Either a b
Right IO a
m) (ParseResult a -> [String] -> ParseResult a
forall a b. a -> b -> a
const (ParParser a -> ParseResult a
forall a. ParParser a -> ParseResult a
No ParParser a
p))

-- Change the group associated with a set of flags.
inGroup :: String -> OptionParser a -> OptionParser a
inGroup :: String -> OptionParser a -> OptionParser a
inGroup String
x (Annotated [Flag]
fls ParParser a
f) = [Flag] -> ParParser a -> OptionParser a
forall d (p :: * -> *) a. d -> p a -> Annotated d p a
Annotated [Flag
fl{ flagGroup :: String
flagGroup = String
x } | Flag
fl <- [Flag]
fls] ParParser a
f

-- Mark a flag as being for experts only.
expert :: OptionParser a -> OptionParser a
expert :: OptionParser a -> OptionParser a
expert (Annotated [Flag]
fls ParParser a
f) = [Flag] -> ParParser a -> OptionParser a
forall d (p :: * -> *) a. d -> p a -> Annotated d p a
Annotated [Flag
fl{ flagMode :: FlagMode
flagMode = FlagMode
ExpertMode } | Flag
fl <- [Flag]
fls] ParParser a
f

-- Mark a flag as being hidden.
hidden :: OptionParser a -> OptionParser a
hidden :: OptionParser a -> OptionParser a
hidden (Annotated [Flag]
fls ParParser a
f) = [Flag] -> ParParser a -> OptionParser a
forall d (p :: * -> *) a. d -> p a -> Annotated d p a
Annotated [Flag
fl{ flagMode :: FlagMode
flagMode = FlagMode
HiddenMode } | Flag
fl <- [Flag]
fls] ParParser a
f

-- Add a --version flag.
version :: String -> OptionParser a -> OptionParser a
version :: String -> OptionParser a -> OptionParser a
version String
x OptionParser a
p =
  OptionParser a
p OptionParser a -> Annotated [Flag] ParParser () -> OptionParser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*
    String
-> Annotated [Flag] ParParser () -> Annotated [Flag] ParParser ()
forall a. String -> OptionParser a -> OptionParser a
inGroup String
"Miscellaneous options"
      (String
-> [String] -> () -> ArgParser () -> Annotated [Flag] ParParser ()
forall a. String -> [String] -> a -> ArgParser a -> OptionParser a
flag String
"version" [String
"Show the version number."] ()
        (ExitCode -> [String] -> ArgParser ()
forall a. ExitCode -> [String] -> ArgParser a
argUsage ExitCode
ExitSuccess [String
x]))

----------------------------------------------------------------------
-- Help screens, error messages and so on.

printHelp :: ExitCode -> [String] -> IO a
printHelp :: ExitCode -> [String] -> IO a
printHelp ExitCode
code [String]
xs = do
  (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> String -> IO ()
hPutStrLn Handle
stderr) [String]
xs
  ExitCode -> IO a
forall a. ExitCode -> IO a
exitWith ExitCode
code

printError :: String -> String -> IO a
printError :: String -> String -> IO a
printError String
name String
err =
  ExitCode -> [String] -> IO a
forall a. ExitCode -> [String] -> IO a
printHelp (Int -> ExitCode
ExitFailure Int
1) ([String] -> IO a) -> [String] -> IO a
forall a b. (a -> b) -> a -> b
$
    [String
err String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".", String
"Try " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" --help."]

help :: String -> String -> OptionParser a -> OptionParser a
help :: String -> String -> OptionParser a -> OptionParser a
help String
name String
description OptionParser a
p = OptionParser a
p'
  where
    p' :: OptionParser a
p' =
      OptionParser a
p OptionParser a -> Annotated [Flag] ParParser () -> OptionParser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*
        (String
-> Annotated [Flag] ParParser () -> Annotated [Flag] ParParser ()
forall a. String -> OptionParser a -> OptionParser a
inGroup String
"Miscellaneous options" (Annotated [Flag] ParParser () -> Annotated [Flag] ParParser ())
-> Annotated [Flag] ParParser () -> Annotated [Flag] ParParser ()
forall a b. (a -> b) -> a -> b
$
         String
-> [String] -> () -> ArgParser () -> Annotated [Flag] ParParser ()
forall a. String -> [String] -> a -> ArgParser a -> OptionParser a
flag String
"help" [String
"Show help text."] ()
        
           (ExitCode -> [String] -> ArgParser ()
forall a. ExitCode -> [String] -> ArgParser a
argUsage ExitCode
ExitSuccess (Bool -> String -> String -> OptionParser a -> [String]
forall a. Bool -> String -> String -> OptionParser a -> [String]
helpText Bool
False String
name String
description OptionParser a
p')))
        OptionParser a -> Annotated [Flag] ParParser () -> OptionParser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*
        (if (Flag -> Bool) -> [Flag] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Flag -> Bool
flagExpert (OptionParser a -> [Flag]
forall d (p :: * -> *) a. Annotated d p a -> d
descr OptionParser a
p) then
          (String
-> Annotated [Flag] ParParser () -> Annotated [Flag] ParParser ()
forall a. String -> OptionParser a -> OptionParser a
inGroup String
"Miscellaneous options" (Annotated [Flag] ParParser () -> Annotated [Flag] ParParser ())
-> Annotated [Flag] ParParser () -> Annotated [Flag] ParParser ()
forall a b. (a -> b) -> a -> b
$
           String
-> [String] -> () -> ArgParser () -> Annotated [Flag] ParParser ()
forall a. String -> [String] -> a -> ArgParser a -> OptionParser a
flag String
"expert-help" [String
"Show help text for hidden options."] ()
             (ExitCode -> [String] -> ArgParser ()
forall a. ExitCode -> [String] -> ArgParser a
argUsage ExitCode
ExitSuccess (Bool -> String -> String -> OptionParser a -> [String]
forall a. Bool -> String -> String -> OptionParser a -> [String]
helpText Bool
True String
name String
description OptionParser a
p')))
         else () -> Annotated [Flag] ParParser ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

usageText :: String -> String -> [String]
usageText :: String -> String -> [String]
usageText String
name String
descr =
  [String
descr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".",
   String
"Usage: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" <option>* <file>*, where <file> is in TPTP format."]

helpText :: Bool -> String -> String -> OptionParser a -> [String]
helpText :: Bool -> String -> String -> OptionParser a -> [String]
helpText Bool
expert String
name String
description OptionParser a
p =
  [String] -> [[String]] -> [String]
forall a. [a] -> [[a]] -> [a]
intercalate [String
""] ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$
    [String -> String -> [String]
usageText String
name String
description] [[String]] -> [[String]] -> [[String]]
forall a. [a] -> [a] -> [a]
++
    [[Flag -> String
flagGroup Flag
f0 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
     [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String -> [String] -> [String]
justify (String
"--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Flag -> String
flagName Flag
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Flag -> String
flagArgs Flag
f) (Flag -> [String]
flagHelp Flag
f) | Flag
f <- [Flag]
fs]
     | fs :: [Flag]
fs@(Flag
f0:[Flag]
_) <- [Flag] -> [[Flag]]
groups ((Flag -> Bool) -> [Flag] -> [Flag]
forall a. (a -> Bool) -> [a] -> [a]
filter Flag -> Bool
ok ([Flag] -> [Flag]
forall a. Eq a => [a] -> [a]
nub (OptionParser a -> [Flag]
forall d (p :: * -> *) a. Annotated d p a -> d
descr OptionParser a
p))) ] [[String]] -> [[String]] -> [[String]]
forall a. [a] -> [a] -> [a]
++
    [ [String
"To see hidden options too, try --expert-help."]
    | (Flag -> Bool) -> [Flag] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Flag -> Bool
flagExpert (OptionParser a -> [Flag]
forall d (p :: * -> *) a. Annotated d p a -> d
descr OptionParser a
p), Bool -> Bool
not Bool
expert ]
  where
    groups :: [Flag] -> [[Flag]]
groups [] = []
    groups (Flag
f:[Flag]
fs) =
      (Flag
fFlag -> [Flag] -> [Flag]
forall a. a -> [a] -> [a]
:[Flag
f' | Flag
f' <- [Flag]
fs, Flag -> String
flagGroup Flag
f String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Flag -> String
flagGroup Flag
f'])[Flag] -> [[Flag]] -> [[Flag]]
forall a. a -> [a] -> [a]
:
      [Flag] -> [[Flag]]
groups [Flag
f' | Flag
f' <- [Flag]
fs, Flag -> String
flagGroup Flag
f String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= Flag -> String
flagGroup Flag
f']
    ok :: Flag -> Bool
ok Flag
flag =
      case Flag -> FlagMode
flagMode Flag
flag of
        FlagMode
NormalMode -> Bool
True
        FlagMode
ExpertMode -> Bool
expert
        FlagMode
HiddenMode -> Bool
False

justify :: String -> [String] -> [String]
justify :: String -> [String] -> [String]
justify String
name [String]
help = [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 b. (a -> b) -> [a] -> [b]
map (String
"    " String -> String -> String
forall a. [a] -> [a] -> [a]
++) [String]
help

----------------------------------------------------------------------
-- Running the parser.

parseCommandLine :: String -> OptionParser a -> IO a
parseCommandLine :: String -> OptionParser a -> IO a
parseCommandLine String
description OptionParser a
p =
  [String] -> String -> OptionParser a -> IO a
forall a. [String] -> String -> OptionParser a -> IO a
parseCommandLineWithExtraArgs [] String
description OptionParser a
p

parseCommandLineWithExtraArgs :: [String] -> String -> OptionParser a -> IO a
parseCommandLineWithExtraArgs :: [String] -> String -> OptionParser a -> IO a
parseCommandLineWithExtraArgs [String]
args0 String
description OptionParser a
p = do
  String
name <- IO String
getProgName
  [String]
args <- IO [String]
getArgs
  String -> [String] -> String -> OptionParser a -> IO a
forall a. String -> [String] -> String -> OptionParser a -> IO a
parseCommandLineWithArgs String
name ([String]
args0 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
args) String
description OptionParser a
p

parseCommandLineWithArgs :: String -> [String] -> String -> OptionParser a -> IO a
parseCommandLineWithArgs :: String -> [String] -> String -> OptionParser a -> IO a
parseCommandLineWithArgs String
name [String]
args String
description OptionParser a
p = do
  case ParParser a -> [String] -> Either Error (IO a)
forall a. ParParser a -> [String] -> Either Error (IO a)
runPar (OptionParser a -> ParParser a
forall d (p :: * -> *) a. Annotated d p a -> p a
parser (String -> String -> OptionParser a -> OptionParser a
forall a. String -> String -> OptionParser a -> OptionParser a
help String
name String
description OptionParser a
p)) [String]
args of
    Left (Mistake String
err) -> String -> String -> IO a
forall a. String -> String -> IO a
printError String
name String
err
    Left (Usage ExitCode
code [String]
err) -> ExitCode -> [String] -> IO a
forall a. ExitCode -> [String] -> IO a
printHelp ExitCode
code [String]
err
    Right IO a
x -> IO a
x