{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

-- | This module implements a lightweight flags parser, inspired by @optparse-applicative@.
--
-- Sample usage (note the default log level and optional context):
--
-- @
-- module Main where
--
-- import Control.Applicative ((\<|\>), optional)
-- import Data.Text (Text)
-- import Flags.Applicative
--
-- -- Custom flags for our example.
-- data Flags = Flags
--   { rootPath :: Text
--   , logLevel :: Int
--   , context :: Maybe Text
--   } deriving Show
--
-- -- Returns a parser from CLI arguments to our custom flags.
-- flagsParser :: FlagsParser Flags
-- flagsParser = Flags
--   \<$\> flag textVal "root" "path to the root"
--   \<*\> (flag autoVal "log_level" "" \<|\> pure 0)
--   \<*\> (optional $ flag textVal "context" "")
--
-- main :: IO ()
-- main = do
--   (flags, args) <- parseSystemFlagsOrDie flagsParser
--   print flags
-- @
module Flags.Applicative (
  -- * Declaring flags
  Name, Description,
  -- ** Nullary flags
  switch, boolFlag,
  -- ** Unary flags
  flag, Reader,
  -- *** Common readers
  autoVal, textVal, stringVal, fracVal, intVal, enumVal, hostVal,
  -- *** Reader combinators
  listOf, mapOf,
  -- * Running parsers
  FlagsParser, FlagsError(..),
  parseFlags, parseSystemFlagsOrDie
) where

import Control.Applicative ((<|>), Alternative, empty)
import Control.Monad (when)
import Control.Monad.Except (Except, catchError, runExcept, throwError)
import Control.Monad.RWS.Strict (RWST, runRWST)
import Control.Monad.Reader (asks)
import Control.Monad.State.Strict (get, modify, put)
import Data.Bifunctor (second)
import Data.Foldable (foldl', toList)
import Data.List (isPrefixOf)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Set as Set
#if !MIN_VERSION_base(4, 11, 0)
import Data.Semigroup ((<>))
#endif
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Read as T
import Network.Socket (HostName, PortNumber)
import System.Exit (die)
import System.Environment (getArgs)
import Text.Casing (fromHumps, toScreamingSnake)
import Text.Read (readEither)

-- The prefix used to identify all flags.
prefix :: String
prefix :: String
prefix = String
"--"

-- | The name of a flag (without the @--@ prefix). Names can use all valid utf-8 characters except
-- @=@ (the value delimiter). In general, it's good practice for flag names to be lowercase ASCII
-- with underscores.
--
-- The following names are reserved and attempting to define a flag with the same name will cause an
-- error:
--
-- * @help@, displays usage when set.
-- * @swallowed_flags@, flags in this list which are set but undeclared will be ignored rather than
-- cause an error during parsing.
-- * @swallowed_switches@, similar to @swallowed_flags@ but for switches (nullary flags).
type Name = Text

-- Add the flag prefix to a name.
qualify :: Name -> Text
qualify :: Name -> Name
qualify Name
name = String -> Name
T.pack String
prefix Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
name

-- | An human-readable explanation of what the flag does. It is displayed when the parser is invoked
-- with the @--help@ flag.
type Description = Text

data Arity = Nullary | Unary deriving Arity -> Arity -> Bool
(Arity -> Arity -> Bool) -> (Arity -> Arity -> Bool) -> Eq Arity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Arity -> Arity -> Bool
$c/= :: Arity -> Arity -> Bool
== :: Arity -> Arity -> Bool
$c== :: Arity -> Arity -> Bool
Eq

data Flag = Flag Arity Description

-- The errors which can happen during flag parsing.
data ValueError
  = InvalidValue Name Text String
  | MissingValues (NonEmpty Name)

missingValue :: Name -> ValueError
missingValue :: Name -> ValueError
missingValue Name
name = NonEmpty Name -> ValueError
MissingValues (NonEmpty Name -> ValueError) -> NonEmpty Name -> ValueError
forall a b. (a -> b) -> a -> b
$ Name
name Name -> [Name] -> NonEmpty Name
forall a. a -> [a] -> NonEmpty a
:| []

type Action a = RWST
  (Map Name Text) -- Flag values (or empty for nullary flags).
  () -- Unused.
  (Set Name) -- Used flags.
  (Except ValueError) -- Eventual parsing error.
  a

data Usage
  = Exactly Name
  | AllOf (Set Usage)
  | OneOf (Set Usage)
  deriving (Usage -> Usage -> Bool
(Usage -> Usage -> Bool) -> (Usage -> Usage -> Bool) -> Eq Usage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Usage -> Usage -> Bool
$c/= :: Usage -> Usage -> Bool
== :: Usage -> Usage -> Bool
$c== :: Usage -> Usage -> Bool
Eq, Eq Usage
Eq Usage
-> (Usage -> Usage -> Ordering)
-> (Usage -> Usage -> Bool)
-> (Usage -> Usage -> Bool)
-> (Usage -> Usage -> Bool)
-> (Usage -> Usage -> Bool)
-> (Usage -> Usage -> Usage)
-> (Usage -> Usage -> Usage)
-> Ord Usage
Usage -> Usage -> Bool
Usage -> Usage -> Ordering
Usage -> Usage -> Usage
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Usage -> Usage -> Usage
$cmin :: Usage -> Usage -> Usage
max :: Usage -> Usage -> Usage
$cmax :: Usage -> Usage -> Usage
>= :: Usage -> Usage -> Bool
$c>= :: Usage -> Usage -> Bool
> :: Usage -> Usage -> Bool
$c> :: Usage -> Usage -> Bool
<= :: Usage -> Usage -> Bool
$c<= :: Usage -> Usage -> Bool
< :: Usage -> Usage -> Bool
$c< :: Usage -> Usage -> Bool
compare :: Usage -> Usage -> Ordering
$ccompare :: Usage -> Usage -> Ordering
$cp1Ord :: Eq Usage
Ord)

emptyUsage :: Usage
emptyUsage :: Usage
emptyUsage = Set Usage -> Usage
AllOf Set Usage
forall a. Set a
Set.empty

andAlso :: Usage -> Usage -> Usage
andAlso :: Usage -> Usage -> Usage
andAlso (AllOf Set Usage
s1) (AllOf Set Usage
s2) = Set Usage -> Usage
AllOf (Set Usage -> Usage) -> Set Usage -> Usage
forall a b. (a -> b) -> a -> b
$ Set Usage
s1 Set Usage -> Set Usage -> Set Usage
forall a. Semigroup a => a -> a -> a
<> Set Usage
s2
andAlso (AllOf Set Usage
s) Usage
u = Set Usage -> Usage
AllOf (Set Usage -> Usage) -> Set Usage -> Usage
forall a b. (a -> b) -> a -> b
$ Usage -> Set Usage -> Set Usage
forall a. Ord a => a -> Set a -> Set a
Set.insert Usage
u Set Usage
s
andAlso Usage
u (AllOf Set Usage
s) = Set Usage -> Usage
AllOf (Set Usage -> Usage) -> Set Usage -> Usage
forall a b. (a -> b) -> a -> b
$ Usage -> Set Usage -> Set Usage
forall a. Ord a => a -> Set a -> Set a
Set.insert Usage
u Set Usage
s
andAlso Usage
u1 Usage
u2 = Set Usage -> Usage
AllOf (Set Usage -> Usage) -> Set Usage -> Usage
forall a b. (a -> b) -> a -> b
$ [Usage] -> Set Usage
forall a. Ord a => [a] -> Set a
Set.fromList [Usage
u1, Usage
u2]

orElse :: Usage -> Usage -> Usage
orElse :: Usage -> Usage -> Usage
orElse (OneOf Set Usage
s1) (OneOf Set Usage
s2) = Set Usage -> Usage
OneOf (Set Usage -> Usage) -> Set Usage -> Usage
forall a b. (a -> b) -> a -> b
$ Set Usage
s1 Set Usage -> Set Usage -> Set Usage
forall a. Semigroup a => a -> a -> a
<> Set Usage
s2
orElse (OneOf Set Usage
s) Usage
u = Set Usage -> Usage
OneOf (Set Usage -> Usage) -> Set Usage -> Usage
forall a b. (a -> b) -> a -> b
$ Usage -> Set Usage -> Set Usage
forall a. Ord a => a -> Set a -> Set a
Set.insert Usage
u Set Usage
s
orElse Usage
u (OneOf Set Usage
s) = Set Usage -> Usage
OneOf (Set Usage -> Usage) -> Set Usage -> Usage
forall a b. (a -> b) -> a -> b
$ Usage -> Set Usage -> Set Usage
forall a. Ord a => a -> Set a -> Set a
Set.insert Usage
u Set Usage
s
orElse Usage
u1 Usage
u2 = Set Usage -> Usage
OneOf (Set Usage -> Usage) -> Set Usage -> Usage
forall a b. (a -> b) -> a -> b
$ [Usage] -> Set Usage
forall a. Ord a => [a] -> Set a
Set.fromList [Usage
u1, Usage
u2]

displayUsage :: Map Name Flag -> Usage -> Text
displayUsage :: Map Name Flag -> Usage -> Name
displayUsage Map Name Flag
flags Usage
usage = Name
"usage: " Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Usage -> Name
go Usage
usage Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
"\n" Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
details where
  go :: Usage -> Name
go (Exactly Name
name) = case Name -> Map Name Flag -> Maybe Flag
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
name Map Name Flag
flags of
    Just (Flag Arity
Unary Name
_) -> Name -> Name
qualify Name
name Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
"=*"
    Maybe Flag
_ -> Name -> Name
qualify Name
name
  go (AllOf Set Usage
s) =
    Name -> [Name] -> Name
T.intercalate Name
" " ([Name] -> Name) -> [Name] -> Name
forall a b. (a -> b) -> a -> b
$ (Usage -> Name) -> [Usage] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Usage -> Name
go ([Usage] -> [Name]) -> [Usage] -> [Name]
forall a b. (a -> b) -> a -> b
$ (Usage -> Bool) -> [Usage] -> [Usage]
forall a. (a -> Bool) -> [a] -> [a]
filter (Usage -> Usage -> Bool
forall a. Eq a => a -> a -> Bool
/= Usage
emptyUsage) ([Usage] -> [Usage]) -> [Usage] -> [Usage]
forall a b. (a -> b) -> a -> b
$ Set Usage -> [Usage]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set Usage
s
  go (OneOf Set Usage
s) =
    let contents :: t Usage -> Name
contents t Usage
s' = Name -> [Name] -> Name
T.intercalate Name
"|" ([Name] -> Name) -> [Name] -> Name
forall a b. (a -> b) -> a -> b
$ (Usage -> Name) -> [Usage] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Usage -> Name
go ([Usage] -> [Name]) -> [Usage] -> [Name]
forall a b. (a -> b) -> a -> b
$ t Usage -> [Usage]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (t Usage -> [Usage]) -> t Usage -> [Usage]
forall a b. (a -> b) -> a -> b
$ t Usage
s'
    in if Usage -> Set Usage -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Usage
emptyUsage Set Usage
s
      then Name
"[" Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Set Usage -> Name
forall (t :: * -> *). Foldable t => t Usage -> Name
contents (Usage -> Set Usage -> Set Usage
forall a. Ord a => a -> Set a -> Set a
Set.delete Usage
emptyUsage Set Usage
s) Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
"]"
      else Name
"(" Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Set Usage -> Name
forall (t :: * -> *). Foldable t => t Usage -> Name
contents Set Usage
s Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
")"
  describe :: (Name, Flag) -> Name
describe (Name
name, Flag Arity
_ Name
desc) = if Name -> Bool
T.null Name
desc then Name
"" else Name
"\n" Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name -> Name
qualify Name
name Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
"\t" Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
desc
  details :: Name
details = [Name] -> Name
T.concat ([Name] -> Name) -> [Name] -> Name
forall a b. (a -> b) -> a -> b
$ ((Name, Flag) -> Name) -> [(Name, Flag)] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name, Flag) -> Name
describe ([(Name, Flag)] -> [Name]) -> [(Name, Flag)] -> [Name]
forall a b. (a -> b) -> a -> b
$ Map Name Flag -> [(Name, Flag)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Name Flag
flags

-- Parser definition errors.
data ParserError
  = Duplicate Name
  | Empty
  deriving (ParserError -> ParserError -> Bool
(ParserError -> ParserError -> Bool)
-> (ParserError -> ParserError -> Bool) -> Eq ParserError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParserError -> ParserError -> Bool
$c/= :: ParserError -> ParserError -> Bool
== :: ParserError -> ParserError -> Bool
$c== :: ParserError -> ParserError -> Bool
Eq, Int -> ParserError -> ShowS
[ParserError] -> ShowS
ParserError -> String
(Int -> ParserError -> ShowS)
-> (ParserError -> String)
-> ([ParserError] -> ShowS)
-> Show ParserError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParserError] -> ShowS
$cshowList :: [ParserError] -> ShowS
show :: ParserError -> String
$cshow :: ParserError -> String
showsPrec :: Int -> ParserError -> ShowS
$cshowsPrec :: Int -> ParserError -> ShowS
Show)

-- | Flags parser.
--
-- There are two types of flags:
--
-- * Nullary flags created with 'switch' and 'boolFlag', which do not accept a value.
-- * Unary flags created with 'flag'. These expect a value to be passed in either after an equal
-- sign (@--foo=value@) or as the following input value (@--foo value@). If the value starts with
-- @--@, only the first form is accepted.
--
-- You can run a parser using 'parseFlags' or 'parseSystemFlagsOrDie'.
data FlagsParser a
  = Actionable (Action a) (Map Name Flag) Usage
  | Invalid ParserError
  deriving a -> FlagsParser b -> FlagsParser a
(a -> b) -> FlagsParser a -> FlagsParser b
(forall a b. (a -> b) -> FlagsParser a -> FlagsParser b)
-> (forall a b. a -> FlagsParser b -> FlagsParser a)
-> Functor FlagsParser
forall a b. a -> FlagsParser b -> FlagsParser a
forall a b. (a -> b) -> FlagsParser a -> FlagsParser b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> FlagsParser b -> FlagsParser a
$c<$ :: forall a b. a -> FlagsParser b -> FlagsParser a
fmap :: (a -> b) -> FlagsParser a -> FlagsParser b
$cfmap :: forall a b. (a -> b) -> FlagsParser a -> FlagsParser b
Functor

-- Returns the combined map of flags if there are no duplicates, otherwise the name of one of the
-- duplicate flags.
mergeFlags :: Map Name Flag -> Map Name Flag -> Either Name (Map Name Flag)
mergeFlags :: Map Name Flag -> Map Name Flag -> Either Name (Map Name Flag)
mergeFlags Map Name Flag
flags1 Map Name Flag
flags2 = case Map Name Flag -> Maybe ((Name, Flag), Map Name Flag)
forall k a. Map k a -> Maybe ((k, a), Map k a)
Map.minViewWithKey (Map Name Flag -> Maybe ((Name, Flag), Map Name Flag))
-> Map Name Flag -> Maybe ((Name, Flag), Map Name Flag)
forall a b. (a -> b) -> a -> b
$ Map Name Flag
flags1 Map Name Flag -> Map Name Flag -> Map Name Flag
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.intersection` Map Name Flag
flags2 of
  Just ((Name
name, Flag
_), Map Name Flag
_) -> Name -> Either Name (Map Name Flag)
forall a b. a -> Either a b
Left Name
name
  Maybe ((Name, Flag), Map Name Flag)
Nothing -> Map Name Flag -> Either Name (Map Name Flag)
forall a b. b -> Either a b
Right (Map Name Flag -> Either Name (Map Name Flag))
-> Map Name Flag -> Either Name (Map Name Flag)
forall a b. (a -> b) -> a -> b
$ Map Name Flag
flags1 Map Name Flag -> Map Name Flag -> Map Name Flag
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map Name Flag
flags2

instance Applicative FlagsParser where
  pure :: a -> FlagsParser a
pure a
res = Action a -> Map Name Flag -> Usage -> FlagsParser a
forall a. Action a -> Map Name Flag -> Usage -> FlagsParser a
Actionable (a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res) Map Name Flag
forall k a. Map k a
Map.empty Usage
emptyUsage

  Invalid ParserError
err <*> :: FlagsParser (a -> b) -> FlagsParser a -> FlagsParser b
<*> FlagsParser a
_ = ParserError -> FlagsParser b
forall a. ParserError -> FlagsParser a
Invalid ParserError
err
  FlagsParser (a -> b)
_ <*> Invalid ParserError
err = ParserError -> FlagsParser b
forall a. ParserError -> FlagsParser a
Invalid ParserError
err
  Actionable Action (a -> b)
action1 Map Name Flag
flags1 Usage
usage1 <*> Actionable Action a
action2 Map Name Flag
flags2 Usage
usage2 =
    case Map Name Flag -> Map Name Flag -> Either Name (Map Name Flag)
mergeFlags Map Name Flag
flags1 Map Name Flag
flags2 of
      Left Name
name -> ParserError -> FlagsParser b
forall a. ParserError -> FlagsParser a
Invalid (ParserError -> FlagsParser b) -> ParserError -> FlagsParser b
forall a b. (a -> b) -> a -> b
$ Name -> ParserError
Duplicate Name
name
      Right Map Name Flag
flags -> Action b -> Map Name Flag -> Usage -> FlagsParser b
forall a. Action a -> Map Name Flag -> Usage -> FlagsParser a
Actionable (Action (a -> b)
action1 Action (a -> b) -> Action a -> Action b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Action a
action2) Map Name Flag
flags (Usage
usage1 Usage -> Usage -> Usage
`andAlso` Usage
usage2)

instance Alternative FlagsParser where
  empty :: FlagsParser a
empty = ParserError -> FlagsParser a
forall a. ParserError -> FlagsParser a
Invalid ParserError
Empty

  Invalid ParserError
Empty <|> :: FlagsParser a -> FlagsParser a -> FlagsParser a
<|> FlagsParser a
parser = FlagsParser a
parser
  FlagsParser a
parser <|> Invalid ParserError
Empty = FlagsParser a
parser
  Invalid ParserError
err <|> FlagsParser a
_ = ParserError -> FlagsParser a
forall a. ParserError -> FlagsParser a
Invalid ParserError
err
  FlagsParser a
_ <|> Invalid ParserError
err = ParserError -> FlagsParser a
forall a. ParserError -> FlagsParser a
Invalid ParserError
err
  Actionable Action a
action1 Map Name Flag
flags1 Usage
usage1 <|> Actionable Action a
action2 Map Name Flag
flags2 Usage
usage2 =
    case Map Name Flag -> Map Name Flag -> Either Name (Map Name Flag)
mergeFlags Map Name Flag
flags1 Map Name Flag
flags2 of
      Left Name
name -> ParserError -> FlagsParser a
forall a. ParserError -> FlagsParser a
Invalid (ParserError -> FlagsParser a) -> ParserError -> FlagsParser a
forall a b. (a -> b) -> a -> b
$ Name -> ParserError
Duplicate Name
name
      Right Map Name Flag
flags -> Action a -> Map Name Flag -> Usage -> FlagsParser a
forall a. Action a -> Map Name Flag -> Usage -> FlagsParser a
Actionable Action a
action Map Name Flag
flags (Usage
usage1 Usage -> Usage -> Usage
`orElse` Usage
usage2) where
        wrap :: m b -> m (Either (NonEmpty Name) b)
wrap m b
a = m (Either (NonEmpty Name) b)
-> (ValueError -> m (Either (NonEmpty Name) b))
-> m (Either (NonEmpty Name) b)
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (b -> Either (NonEmpty Name) b
forall a b. b -> Either a b
Right (b -> Either (NonEmpty Name) b)
-> m b -> m (Either (NonEmpty Name) b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m b
a) ((ValueError -> m (Either (NonEmpty Name) b))
 -> m (Either (NonEmpty Name) b))
-> (ValueError -> m (Either (NonEmpty Name) b))
-> m (Either (NonEmpty Name) b)
forall a b. (a -> b) -> a -> b
$ \case
          (MissingValues NonEmpty Name
names) -> Either (NonEmpty Name) b -> m (Either (NonEmpty Name) b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (NonEmpty Name) b -> m (Either (NonEmpty Name) b))
-> Either (NonEmpty Name) b -> m (Either (NonEmpty Name) b)
forall a b. (a -> b) -> a -> b
$ NonEmpty Name -> Either (NonEmpty Name) b
forall a b. a -> Either a b
Left NonEmpty Name
names
          ValueError
err -> ValueError -> m (Either (NonEmpty Name) b)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ValueError
err
        action :: Action a
action = do
          Set Name
used <- RWST (Map Name Name) () (Set Name) (Except ValueError) (Set Name)
forall s (m :: * -> *). MonadState s m => m s
get
          Action a
-> RWST
     (Map Name Name)
     ()
     (Set Name)
     (Except ValueError)
     (Either (NonEmpty Name) a)
forall (m :: * -> *) b.
MonadError ValueError m =>
m b -> m (Either (NonEmpty Name) b)
wrap Action a
action1 RWST
  (Map Name Name)
  ()
  (Set Name)
  (Except ValueError)
  (Either (NonEmpty Name) a)
-> (Either (NonEmpty Name) a -> Action a) -> Action a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left NonEmpty Name
names -> do
              Set Name
-> RWST (Map Name Name) () (Set Name) (Except ValueError) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Set Name
used
              Action a
-> RWST
     (Map Name Name)
     ()
     (Set Name)
     (Except ValueError)
     (Either (NonEmpty Name) a)
forall (m :: * -> *) b.
MonadError ValueError m =>
m b -> m (Either (NonEmpty Name) b)
wrap Action a
action2 RWST
  (Map Name Name)
  ()
  (Set Name)
  (Except ValueError)
  (Either (NonEmpty Name) a)
-> (Either (NonEmpty Name) a -> Action a) -> Action a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Left NonEmpty Name
names' -> ValueError -> Action a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ValueError -> Action a) -> ValueError -> Action a
forall a b. (a -> b) -> a -> b
$ NonEmpty Name -> ValueError
MissingValues (NonEmpty Name -> ValueError) -> NonEmpty Name -> ValueError
forall a b. (a -> b) -> a -> b
$ NonEmpty Name
names NonEmpty Name -> NonEmpty Name -> NonEmpty Name
forall a. Semigroup a => a -> a -> a
<> NonEmpty Name
names'
                Right a
res -> a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res
            Right a
res -> do
              Set Name
used' <- RWST (Map Name Name) () (Set Name) (Except ValueError) (Set Name)
forall s (m :: * -> *). MonadState s m => m s
get
              Either (NonEmpty Name) a
_ <- Action a
-> RWST
     (Map Name Name)
     ()
     (Set Name)
     (Except ValueError)
     (Either (NonEmpty Name) a)
forall (m :: * -> *) b.
MonadError ValueError m =>
m b -> m (Either (NonEmpty Name) b)
wrap Action a
action2
              Set Name
-> RWST (Map Name Name) () (Set Name) (Except ValueError) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Set Name
used'
              a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res

-- | The possible parsing errors.
data FlagsError
  = DuplicateFlag Name
  -- ^ A flag was declared multiple times.
  | EmptyParser
  -- ^ The parser was empty.
  | Help Text
  -- ^ The input included the @--help@ flag.
  | InconsistentFlagValues Name
  -- ^ At least one unary flag was specified multiple times with different values.
  | InvalidFlagValue Name Text String
  -- ^ A unary flag's value failed to parse.
  | MissingFlags (NonEmpty Name)
  -- ^ A required flag was missing; at least one of the returned flags should be set.
  | MissingFlagValue Name
  -- ^ A unary flag was missing a value. This can happen either if a value-less unary flag was the
  -- last token or was followed by a value which is also a flag name (in which case you should use
  -- the single-token form: @--flag=--value@).
  | ReservedFlag Name
  -- ^ A flag with a reserved name was declared.
  | UnexpectedFlagValue Name
  -- ^ A nullary flag was given a value.
  | UnexpectedFlags (NonEmpty Name)
  -- ^ At least one flag was set but unused. This can happen when optional flags are set but their
  -- branch is not selected.
  | UnknownFlag Name
  -- ^ An unknown flag was set.
  deriving (FlagsError -> FlagsError -> Bool
(FlagsError -> FlagsError -> Bool)
-> (FlagsError -> FlagsError -> Bool) -> Eq FlagsError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FlagsError -> FlagsError -> Bool
$c/= :: FlagsError -> FlagsError -> Bool
== :: FlagsError -> FlagsError -> Bool
$c== :: FlagsError -> FlagsError -> Bool
Eq, Int -> FlagsError -> ShowS
[FlagsError] -> ShowS
FlagsError -> String
(Int -> FlagsError -> ShowS)
-> (FlagsError -> String)
-> ([FlagsError] -> ShowS)
-> Show FlagsError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FlagsError] -> ShowS
$cshowList :: [FlagsError] -> ShowS
show :: FlagsError -> String
$cshow :: FlagsError -> String
showsPrec :: Int -> FlagsError -> ShowS
$cshowsPrec :: Int -> FlagsError -> ShowS
Show)

displayFlags :: Foldable f => f Name -> Text
displayFlags :: f Name -> Name
displayFlags = Name -> [Name] -> Name
T.intercalate Name
" " ([Name] -> Name) -> (f Name -> [Name]) -> f Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Name) -> [Name] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Name
qualify ([Name] -> [Name]) -> (f Name -> [Name]) -> f Name -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f Name -> [Name]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

-- Pretty-print a 'FlagError'.
displayFlagError :: FlagsError -> Text
displayFlagError :: FlagsError -> Name
displayFlagError (DuplicateFlag Name
name) = Name -> Name
qualify Name
name Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
" was declared multiple times"
displayFlagError FlagsError
EmptyParser = Name
"empty parser"
displayFlagError (Help Name
usage) = Name
usage
displayFlagError (InconsistentFlagValues Name
name) = Name
"inconsistent values for " Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name -> Name
qualify Name
name
displayFlagError (InvalidFlagValue Name
name Name
val String
msg) =
  Name
"invalid value \"" Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
val Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
"\" for " Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name -> Name
qualify Name
name Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
" (" Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> String -> Name
T.pack String
msg Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
")"
displayFlagError (MissingFlags NonEmpty Name
names) =
  Name
"at least one of the following required flags must be set: " Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> NonEmpty Name -> Name
forall (f :: * -> *). Foldable f => f Name -> Name
displayFlags NonEmpty Name
names
displayFlagError (MissingFlagValue Name
name) = Name
"missing value for " Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name -> Name
qualify Name
name
displayFlagError (ReservedFlag Name
name) = Name -> Name
qualify Name
name Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
" was declared but is reserved"
displayFlagError (UnexpectedFlagValue Name
name) = Name
"unexpected value for " Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name -> Name
qualify Name
name
displayFlagError (UnexpectedFlags NonEmpty Name
names) = Name
"unexpected " Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> NonEmpty Name -> Name
forall (f :: * -> *). Foldable f => f Name -> Name
displayFlags NonEmpty Name
names
displayFlagError (UnknownFlag Name
name) = Name
"undeclared " Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name -> Name
qualify Name
name

-- Marks a flag as used. This is useful to check for unexpected flags after parsing is complete.
useFlag :: Name -> Action ()
useFlag :: Name -> RWST (Map Name Name) () (Set Name) (Except ValueError) ()
useFlag Name
name = (Set Name -> Set Name)
-> RWST (Map Name Name) () (Set Name) (Except ValueError) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Name -> Set Name -> Set Name
forall a. Ord a => a -> Set a -> Set a
Set.insert Name
name)

-- | Returns a parser with the given name and description for a flag with no value, failing if the
-- flag is not present. See also 'boolFlag' for a variant which doesn't fail when the flag is
-- missing.
switch :: Name -> Description -> FlagsParser ()
switch :: Name -> Name -> FlagsParser ()
switch Name
name Name
desc = RWST (Map Name Name) () (Set Name) (Except ValueError) ()
-> Map Name Flag -> Usage -> FlagsParser ()
forall a. Action a -> Map Name Flag -> Usage -> FlagsParser a
Actionable RWST (Map Name Name) () (Set Name) (Except ValueError) ()
action Map Name Flag
flags Usage
usage where
  action :: RWST (Map Name Name) () (Set Name) (Except ValueError) ()
action = (Map Name Name -> Bool)
-> RWST (Map Name Name) () (Set Name) (Except ValueError) Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Name -> Map Name Name -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Name
name) RWST (Map Name Name) () (Set Name) (Except ValueError) Bool
-> (Bool
    -> RWST (Map Name Name) () (Set Name) (Except ValueError) ())
-> RWST (Map Name Name) () (Set Name) (Except ValueError) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
True -> Name -> RWST (Map Name Name) () (Set Name) (Except ValueError) ()
useFlag Name
name
    Bool
False -> ValueError
-> RWST (Map Name Name) () (Set Name) (Except ValueError) ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ValueError
 -> RWST (Map Name Name) () (Set Name) (Except ValueError) ())
-> ValueError
-> RWST (Map Name Name) () (Set Name) (Except ValueError) ()
forall a b. (a -> b) -> a -> b
$ Name -> ValueError
missingValue Name
name
  flags :: Map Name Flag
flags = Name -> Flag -> Map Name Flag
forall k a. k -> a -> Map k a
Map.singleton Name
name (Arity -> Name -> Flag
Flag Arity
Nullary Name
desc)
  usage :: Usage
usage = Name -> Usage
Exactly Name
name

-- | Returns a parser with the given name and description for a flag with no value, returning
-- whether the flag was present.
boolFlag :: Name -> Description -> FlagsParser Bool
boolFlag :: Name -> Name -> FlagsParser Bool
boolFlag Name
name Name
desc = (Bool
True Bool -> FlagsParser () -> FlagsParser Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Name -> Name -> FlagsParser ()
switch Name
name Name
desc) FlagsParser Bool -> FlagsParser Bool -> FlagsParser Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> FlagsParser Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

-- | The type used to read flag values.
type Reader a = Text -> Either String a

-- | Returns a parser using the given value reader, name, and description for a flag with an
-- associated value.
flag :: Reader a -> Name -> Description -> FlagsParser a
flag :: Reader a -> Name -> Name -> FlagsParser a
flag Reader a
convert Name
name Name
desc = Action a -> Map Name Flag -> Usage -> FlagsParser a
forall a. Action a -> Map Name Flag -> Usage -> FlagsParser a
Actionable Action a
action Map Name Flag
flags Usage
usage where
  action :: Action a
action = do
    Name -> RWST (Map Name Name) () (Set Name) (Except ValueError) ()
useFlag Name
name
    (Map Name Name -> Maybe Name)
-> RWST
     (Map Name Name) () (Set Name) (Except ValueError) (Maybe Name)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Name -> Map Name Name -> Maybe Name
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
name) RWST (Map Name Name) () (Set Name) (Except ValueError) (Maybe Name)
-> (Maybe Name -> Action a) -> Action a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe Name
Nothing -> ValueError -> Action a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ValueError -> Action a) -> ValueError -> Action a
forall a b. (a -> b) -> a -> b
$ Name -> ValueError
missingValue Name
name
      Just Name
val -> case Reader a
convert Name
val of
        Left String
err -> ValueError -> Action a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ValueError -> Action a) -> ValueError -> Action a
forall a b. (a -> b) -> a -> b
$ Name -> Name -> String -> ValueError
InvalidValue Name
name Name
val String
err
        Right a
res -> a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res
  flags :: Map Name Flag
flags = Name -> Flag -> Map Name Flag
forall k a. k -> a -> Map k a
Map.singleton Name
name (Arity -> Name -> Flag
Flag Arity
Unary Name
desc)
  usage :: Usage
usage = Name -> Usage
Exactly Name
name

-- | Returns a reader for any value with a 'Read' instance. Prefer 'textVal' for textual values
-- since 'autoVal'  will expect its values to be double-quoted and might not work as expected.
autoVal :: Read a => Reader a
autoVal :: Reader a
autoVal = String -> Either String a
forall a. Read a => String -> Either String a
readEither (String -> Either String a) -> (Name -> String) -> Reader a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
T.unpack

-- | Returns a reader for a single string value. This can useful when interfacing with non-text APIs
-- (e.g. 'FilePath') but in general prefer 'textVal'.
stringVal :: Reader String
stringVal :: Reader String
stringVal = String -> Either String String
forall a b. b -> Either a b
Right (String -> Either String String)
-> (Name -> String) -> Reader String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
T.unpack

-- | Returns a reader for a single text value.
textVal :: Reader Text
textVal :: Reader Name
textVal = Reader Name
forall a b. b -> Either a b
Right

-- Fully executes a reader. This function is useful for interacting with "Data.Text.Read".
readingFully :: (Text -> Either String (a, Text)) -> Reader a
readingFully :: (Name -> Either String (a, Name)) -> Reader a
readingFully Name -> Either String (a, Name)
f Name
t = case Name -> Either String (a, Name)
f Name
t of
  Left String
e -> String -> Either String a
forall a b. a -> Either a b
Left String
e
  Right (a
v, Name
t') -> if Name -> Bool
T.null Name
t' then a -> Either String a
forall a b. b -> Either a b
Right a
v else String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a) -> String -> Either String a
forall a b. (a -> b) -> a -> b
$ Name -> String
T.unpack (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ Name
"trailing chars: " Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
t'

-- | Returns a reader for any number with a 'Fractional' instance (e.g. 'Double', 'Float').
fracVal :: Fractional a => Reader a
fracVal :: Reader a
fracVal = (Name -> Either String (a, Name)) -> Reader a
forall a. (Name -> Either String (a, Name)) -> Reader a
readingFully Name -> Either String (a, Name)
forall a. Fractional a => Reader a
T.rational

-- | Returns a reader for any number with an 'Integral instance (e.g. 'Int', 'Integer').
intVal :: Integral a => Reader a
intVal :: Reader a
intVal = (Name -> Either String (a, Name)) -> Reader a
forall a. (Name -> Either String (a, Name)) -> Reader a
readingFully ((Name -> Either String (a, Name)) -> Reader a)
-> (Name -> Either String (a, Name)) -> Reader a
forall a b. (a -> b) -> a -> b
$ (Name -> Either String (a, Name))
-> Name -> Either String (a, Name)
forall a. Num a => Reader a -> Reader a
T.signed Name -> Either String (a, Name)
forall a. Integral a => Reader a
T.decimal

-- | Returns a reader for 'Enum' instances. This reader assumes that enum (Haskell) constructors are
-- written in PascalCase and expects UPPER_SNAKE_CASE as command-line flag values. For example:
--
-- > data Mode = Flexible | Strict deriving (Bounded, Enum, Show)
-- > modeFlag = flag enumVal "mode" "the mode" :: FlagsParser Mode
--
-- The above flag will accept values @--mode=FLEXIBLE@ and @--mode=STRICT@.
enumVal :: (Bounded a, Enum a, Show a) => Reader a
enumVal :: Reader a
enumVal = Reader a
parse where
  write :: a -> Name
write = String -> Name
T.pack (String -> Name) -> (a -> String) -> a -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier String -> String
toScreamingSnake (Identifier String -> String)
-> (a -> Identifier String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Identifier String
fromHumps (String -> Identifier String)
-> (a -> String) -> a -> Identifier String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show -- Serializes an enum value.
  m :: Map Name a
m = [(Name, a)] -> Map Name a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, a)] -> Map Name a) -> [(Name, a)] -> Map Name a
forall a b. (a -> b) -> a -> b
$ (a -> (Name, a)) -> [a] -> [(Name, a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
v -> (a -> Name
write a
v, a
v)) [a
forall a. Bounded a => a
minBound .. a
forall a. Bounded a => a
maxBound]
  parse :: Reader a
parse Name
t = case Name -> Map Name a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
t Map Name a
m of
    Maybe a
Nothing ->
      let e :: Name
e = Name
t Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
" is not in " Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name -> [Name] -> Name
T.intercalate Name
"," (Map Name a -> [Name]
forall k a. Map k a -> [k]
Map.keys Map Name a
m)
      in String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a) -> String -> Either String a
forall a b. (a -> b) -> a -> b
$ Name -> String
T.unpack Name
e
    Just a
v -> a -> Either String a
forall a b. b -> Either a b
Right a
v

-- | Returns a reader for network hosts of the form @hostname:port@. The port part is optional.
hostVal :: Reader (HostName, Maybe PortNumber)
hostVal :: Reader (String, Maybe PortNumber)
hostVal Name
txt = do
  let (Name
hostname, Name
suffix) = Name -> Name -> (Name, Name)
T.breakOn Name
":" Name
txt
  Maybe PortNumber
mbPort <- case Name -> Name -> Maybe Name
T.stripPrefix Name
":" Name
suffix of
      Maybe Name
Nothing -> Maybe PortNumber -> Either String (Maybe PortNumber)
forall a b. b -> Either a b
Right Maybe PortNumber
forall a. Maybe a
Nothing
      Just Name
portStr -> PortNumber -> Maybe PortNumber
forall a. a -> Maybe a
Just (PortNumber -> Maybe PortNumber)
-> Either String PortNumber -> Either String (Maybe PortNumber)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Either String PortNumber
forall a. Read a => String -> Either String a
readEither (Name -> String
T.unpack Name
portStr)
  (String, Maybe PortNumber)
-> Either String (String, Maybe PortNumber)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> String
T.unpack Name
hostname, Maybe PortNumber
mbPort)

-- | Transforms a single-valued unary flag into one which accepts multiple comma-separated values.
-- For example, to parse a comma-separated list of integers:
--
-- > countsFlag = flag (listOf intVal) "counts" "the counts"
--
-- Empty text values are ignored, which means both that trailing commas are supported and that an
-- empty list can be specified simply by specifying an empty value on the command line. Note that
-- escapes are not supported, so values should not contain any commas.
listOf :: Reader a -> Reader [a]
listOf :: Reader a -> Reader [a]
listOf Reader a
f = Reader a -> [Name] -> Either String [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Reader a
f ([Name] -> Either String [a]) -> (Name -> [Name]) -> Reader [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Name -> Bool) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Bool
T.null) ([Name] -> [Name]) -> (Name -> [Name]) -> Name -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name -> [Name]
T.splitOn Name
","

-- | Transforms a single-valued unary flag into one which accepts a comma-separated list of
-- colon-delimited key-value pairs. The syntax is @key:value[,key:value...]@. Note that escapes are
-- not supported, so neither keys not values should contain colons or commas.
mapOf :: Ord a => Reader a -> Reader b -> Reader (Map a b)
mapOf :: Reader a -> Reader b -> Reader (Map a b)
mapOf Reader a
f Reader b
g = ([(a, b)] -> Map a b)
-> Either String [(a, b)] -> Either String (Map a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(a, b)] -> Map a b
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (Either String [(a, b)] -> Either String (Map a b))
-> (Name -> Either String [(a, b)]) -> Reader (Map a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Reader (a, b) -> Name -> Either String [(a, b)]
forall a. Reader a -> Reader [a]
listOf ((Name, Name) -> Either String (a, b)
h ((Name, Name) -> Either String (a, b))
-> (Name -> (Name, Name)) -> Reader (a, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name -> (Name, Name)
T.breakOn Name
":") where
  h :: (Name, Name) -> Either String (a, b)
h (Name
k, Name
v) = case Name -> Maybe (Char, Name)
T.uncons Name
v of
    Maybe (Char, Name)
Nothing -> String -> Either String (a, b)
forall a b. a -> Either a b
Left (String -> Either String (a, b)) -> String -> Either String (a, b)
forall a b. (a -> b) -> a -> b
$ Name -> String
T.unpack (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ Name
"empty value for key " Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
k
    Just (Char
_, Name
v') -> (,) (a -> b -> (a, b))
-> Either String a -> Either String (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Reader a
f Name
k Either String (b -> (a, b))
-> Either String b -> Either String (a, b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Reader b
g Name
v'

-- Tries to gather all raw flag values into a map. When @ignoreUnknown@ is true, this function will
-- pass through any unknown flags into the returned argument list( and pass through any @--@ value),
-- otherwise it will throw a 'FlagError'.
gatherValues :: Bool -> Map Name Flag -> [String] -> Either FlagsError ((Map Name Text), [String])
gatherValues :: Bool
-> Map Name Flag
-> [String]
-> Either FlagsError (Map Name Name, [String])
gatherValues Bool
ignoreUnknown Map Name Flag
flags = [String] -> Either FlagsError (Map Name Name, [String])
go where
  go :: [String] -> Either FlagsError (Map Name Name, [String])
go [] = (Map Name Name, [String])
-> Either FlagsError (Map Name Name, [String])
forall a b. b -> Either a b
Right (Map Name Name
forall k a. Map k a
Map.empty, [])
  go (String
token:[String]
tokens) = if Bool -> Bool
not (String
prefix String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
token)
    then ([String] -> [String])
-> (Map Name Name, [String]) -> (Map Name Name, [String])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (String
tokenString -> [String] -> [String]
forall a. a -> [a] -> [a]
:) ((Map Name Name, [String]) -> (Map Name Name, [String]))
-> Either FlagsError (Map Name Name, [String])
-> Either FlagsError (Map Name Name, [String])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> Either FlagsError (Map Name Name, [String])
go [String]
tokens
    else
      let entry :: String
entry = Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
2 String
token :: String
      in if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
entry
        then (Map Name Name, [String])
-> Either FlagsError (Map Name Name, [String])
forall a b. b -> Either a b
Right (Map Name Name
forall k a. Map k a
Map.empty, if Bool
ignoreUnknown then String
"--"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
tokens else [String]
tokens)
        else
          let
            (Name
name, Name
pval) = Name -> Name -> (Name, Name)
T.breakOn Name
"=" (String -> Name
T.pack String
entry)
            missing :: Either FlagsError b
missing = FlagsError -> Either FlagsError b
forall a b. a -> Either a b
Left (FlagsError -> Either FlagsError b)
-> FlagsError -> Either FlagsError b
forall a b. (a -> b) -> a -> b
$ Name -> FlagsError
MissingFlagValue Name
name
            insert :: Name -> [String] -> Either FlagsError (Map Name Name, [String])
insert Name
val [String]
tokens' = do
              (Map Name Name
vals', [String]
args') <- [String] -> Either FlagsError (Map Name Name, [String])
go [String]
tokens'
              case Name -> Map Name Name -> Maybe Name
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
name Map Name Name
vals' of
                Maybe Name
Nothing -> (Map Name Name, [String])
-> Either FlagsError (Map Name Name, [String])
forall a b. b -> Either a b
Right (Name -> Name -> Map Name Name -> Map Name Name
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
name Name
val Map Name Name
vals', [String]
args')
                Just Name
val' -> if Name
val Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
val'
                  then (Map Name Name, [String])
-> Either FlagsError (Map Name Name, [String])
forall a b. b -> Either a b
Right (Map Name Name
vals', [String]
args')
                  else FlagsError -> Either FlagsError (Map Name Name, [String])
forall a b. a -> Either a b
Left (FlagsError -> Either FlagsError (Map Name Name, [String]))
-> FlagsError -> Either FlagsError (Map Name Name, [String])
forall a b. (a -> b) -> a -> b
$ Name -> FlagsError
InconsistentFlagValues Name
name
          in case Name -> Map Name Flag -> Maybe Flag
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
name Map Name Flag
flags of
            Maybe Flag
Nothing -> if Bool
ignoreUnknown
              then ([String] -> [String])
-> (Map Name Name, [String]) -> (Map Name Name, [String])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (String
tokenString -> [String] -> [String]
forall a. a -> [a] -> [a]
:) ((Map Name Name, [String]) -> (Map Name Name, [String]))
-> Either FlagsError (Map Name Name, [String])
-> Either FlagsError (Map Name Name, [String])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> Either FlagsError (Map Name Name, [String])
go [String]
tokens
              else FlagsError -> Either FlagsError (Map Name Name, [String])
forall a b. a -> Either a b
Left (Name -> FlagsError
UnknownFlag Name
name)
            Just (Flag Arity
Nullary Name
_) -> if Name -> Bool
T.null Name
pval
              then Name -> [String] -> Either FlagsError (Map Name Name, [String])
insert Name
"" [String]
tokens
              else FlagsError -> Either FlagsError (Map Name Name, [String])
forall a b. a -> Either a b
Left (FlagsError -> Either FlagsError (Map Name Name, [String]))
-> FlagsError -> Either FlagsError (Map Name Name, [String])
forall a b. (a -> b) -> a -> b
$ Name -> FlagsError
UnexpectedFlagValue Name
name
            Just (Flag Arity
Unary Name
_) -> case Name -> Maybe (Char, Name)
T.uncons Name
pval of
              Maybe (Char, Name)
Nothing -> case [String]
tokens of
                (String
token':[String]
tokens') -> if String
prefix String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
token'
                  then Either FlagsError (Map Name Name, [String])
forall b. Either FlagsError b
missing
                  else Name -> [String] -> Either FlagsError (Map Name Name, [String])
insert (String -> Name
T.pack String
token') [String]
tokens'
                [String]
_ -> Either FlagsError (Map Name Name, [String])
forall b. Either FlagsError b
missing
              Just (Char
_, Name
val) -> Name -> [String] -> Either FlagsError (Map Name Name, [String])
insert Name
val [String]
tokens

-- Runs a single parsing pass.
runAction :: Bool -> Action a -> Map Name Flag -> [String] -> Either FlagsError (a, Set Name, [String])
runAction :: Bool
-> Action a
-> Map Name Flag
-> [String]
-> Either FlagsError (a, Set Name, [String])
runAction Bool
ignoreUnknown Action a
action Map Name Flag
flags [String]
tokens = case Bool
-> Map Name Flag
-> [String]
-> Either FlagsError (Map Name Name, [String])
gatherValues Bool
ignoreUnknown Map Name Flag
flags [String]
tokens of
  Left FlagsError
err -> FlagsError -> Either FlagsError (a, Set Name, [String])
forall a b. a -> Either a b
Left FlagsError
err
  Right (Map Name Name
values, [String]
args) -> case Except ValueError (a, Set Name, ())
-> Either ValueError (a, Set Name, ())
forall e a. Except e a -> Either e a
runExcept (Except ValueError (a, Set Name, ())
 -> Either ValueError (a, Set Name, ()))
-> Except ValueError (a, Set Name, ())
-> Either ValueError (a, Set Name, ())
forall a b. (a -> b) -> a -> b
$ Action a
-> Map Name Name -> Set Name -> Except ValueError (a, Set Name, ())
forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
runRWST Action a
action Map Name Name
values Set Name
forall a. Set a
Set.empty of
    Right (a
rv, Set Name
usedNames, ()
_) ->
      let unused :: Set Name
unused = Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
Set.difference (Map Name Name -> Set Name
forall k a. Map k a -> Set k
Map.keysSet Map Name Name
values) Set Name
usedNames
      in (a, Set Name, [String])
-> Either FlagsError (a, Set Name, [String])
forall a b. b -> Either a b
Right (a
rv, Set Name
unused, [String]
args)
    Left (MissingValues NonEmpty Name
names) -> FlagsError -> Either FlagsError (a, Set Name, [String])
forall a b. a -> Either a b
Left (FlagsError -> Either FlagsError (a, Set Name, [String]))
-> FlagsError -> Either FlagsError (a, Set Name, [String])
forall a b. (a -> b) -> a -> b
$ NonEmpty Name -> FlagsError
MissingFlags NonEmpty Name
names
    Left (InvalidValue Name
name Name
val String
msg) -> FlagsError -> Either FlagsError (a, Set Name, [String])
forall a b. a -> Either a b
Left (FlagsError -> Either FlagsError (a, Set Name, [String]))
-> FlagsError -> Either FlagsError (a, Set Name, [String])
forall a b. (a -> b) -> a -> b
$ Name -> Name -> String -> FlagsError
InvalidFlagValue Name
name Name
val String
msg

-- Preprocessing parser.
reservedParser :: FlagsParser (Bool, Set Name, Set Name)
reservedParser :: FlagsParser (Bool, Set Name, Set Name)
reservedParser =
  let textSetFlag :: Name -> FlagsParser (Set Name)
textSetFlag Name
name = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList ([Name] -> Set Name)
-> FlagsParser [Name] -> FlagsParser (Set Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Reader [Name] -> Name -> Name -> FlagsParser [Name]
forall a. Reader a -> Name -> Name -> FlagsParser a
flag ([Name] -> Either String [Name]
forall a b. b -> Either a b
Right ([Name] -> Either String [Name])
-> (Name -> [Name]) -> Reader [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name -> [Name]
T.splitOn Name
",") Name
name Name
"" FlagsParser [Name] -> FlagsParser [Name] -> FlagsParser [Name]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Name] -> FlagsParser [Name]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
  in (,,)
    (Bool -> Set Name -> Set Name -> (Bool, Set Name, Set Name))
-> FlagsParser Bool
-> FlagsParser (Set Name -> Set Name -> (Bool, Set Name, Set Name))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Name -> FlagsParser Bool
boolFlag Name
"help" Name
""
    FlagsParser (Set Name -> Set Name -> (Bool, Set Name, Set Name))
-> FlagsParser (Set Name)
-> FlagsParser (Set Name -> (Bool, Set Name, Set Name))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> FlagsParser (Set Name)
textSetFlag Name
"swallowed_flags"
    FlagsParser (Set Name -> (Bool, Set Name, Set Name))
-> FlagsParser (Set Name) -> FlagsParser (Bool, Set Name, Set Name)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> FlagsParser (Set Name)
textSetFlag Name
"swallowed_switches"

-- | Runs a parser on a list of tokens, returning the parsed flags alongside other non-flag
-- arguments (i.e. which don't start with @--@). If the special @--@ token is found, all following
-- tokens will be considered arguments even if they look like flags.
parseFlags :: FlagsParser a -> [String] -> Either FlagsError (a, [String])
parseFlags :: FlagsParser a -> [String] -> Either FlagsError (a, [String])
parseFlags FlagsParser a
parser [String]
tokens = case FlagsParser (Bool, Set Name, Set Name)
reservedParser of
  Invalid ParserError
_ -> String -> Either FlagsError (a, [String])
forall a. HasCallStack => String -> a
error String
"unreachable"
  Actionable Action (Bool, Set Name, Set Name)
action0 Map Name Flag
flags0 Usage
_ -> do
    ((Bool
showHelp, Set Name
sflags, Set Name
sswitches), Set Name
_, [String]
tokens') <- Bool
-> Action (Bool, Set Name, Set Name)
-> Map Name Flag
-> [String]
-> Either
     FlagsError ((Bool, Set Name, Set Name), Set Name, [String])
forall a.
Bool
-> Action a
-> Map Name Flag
-> [String]
-> Either FlagsError (a, Set Name, [String])
runAction Bool
True Action (Bool, Set Name, Set Name)
action0 Map Name Flag
flags0 [String]
tokens
    (Action a
action, Map Name Flag
flags) <- case FlagsParser a
parser of
      Invalid (Duplicate Name
name) -> FlagsError -> Either FlagsError (Action a, Map Name Flag)
forall a b. a -> Either a b
Left (FlagsError -> Either FlagsError (Action a, Map Name Flag))
-> FlagsError -> Either FlagsError (Action a, Map Name Flag)
forall a b. (a -> b) -> a -> b
$ Name -> FlagsError
DuplicateFlag Name
name
      Invalid ParserError
Empty -> FlagsError -> Either FlagsError (Action a, Map Name Flag)
forall a b. a -> Either a b
Left FlagsError
EmptyParser
      Actionable Action a
action Map Name Flag
flags Usage
usage -> do
        case Set Name -> Maybe Name
forall a. Set a -> Maybe a
Set.lookupMin (Map Name Flag -> Set Name
forall k a. Map k a -> Set k
Map.keysSet (Map Name Flag -> Set Name) -> Map Name Flag -> Set Name
forall a b. (a -> b) -> a -> b
$ Map Name Flag -> Map Name Flag -> Map Name Flag
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.intersection Map Name Flag
flags0 Map Name Flag
flags) of
          Maybe Name
Nothing -> () -> Either FlagsError ()
forall a b. b -> Either a b
Right ()
          Just Name
name -> FlagsError -> Either FlagsError ()
forall a b. a -> Either a b
Left (FlagsError -> Either FlagsError ())
-> FlagsError -> Either FlagsError ()
forall a b. (a -> b) -> a -> b
$ Name -> FlagsError
ReservedFlag Name
name
        Bool -> Either FlagsError () -> Either FlagsError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
showHelp (Either FlagsError () -> Either FlagsError ())
-> Either FlagsError () -> Either FlagsError ()
forall a b. (a -> b) -> a -> b
$  FlagsError -> Either FlagsError ()
forall a b. a -> Either a b
Left (Name -> FlagsError
Help (Name -> FlagsError) -> Name -> FlagsError
forall a b. (a -> b) -> a -> b
$ Map Name Flag -> Usage -> Name
displayUsage Map Name Flag
flags Usage
usage)
        let
          flags' :: Map Name Flag
flags' = (Map Name Flag -> Name -> Map Name Flag)
-> Map Name Flag -> Set Name -> Map Name Flag
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Map Name Flag
m Name
name -> Name -> Flag -> Map Name Flag -> Map Name Flag
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
name (Arity -> Name -> Flag
Flag Arity
Unary Name
"") Map Name Flag
m) Map Name Flag
flags Set Name
sflags
          flags'' :: Map Name Flag
flags'' = (Map Name Flag -> Name -> Map Name Flag)
-> Map Name Flag -> Set Name -> Map Name Flag
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Map Name Flag
m Name
name -> Name -> Flag -> Map Name Flag -> Map Name Flag
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
name (Arity -> Name -> Flag
Flag Arity
Nullary Name
"") Map Name Flag
m) Map Name Flag
flags' Set Name
sswitches
        (Action a, Map Name Flag)
-> Either FlagsError (Action a, Map Name Flag)
forall a b. b -> Either a b
Right (Action a
action, Map Name Flag
flags'')
    (a
rv, Set Name
unused, [String]
tokens'') <- Bool
-> Action a
-> Map Name Flag
-> [String]
-> Either FlagsError (a, Set Name, [String])
forall a.
Bool
-> Action a
-> Map Name Flag
-> [String]
-> Either FlagsError (a, Set Name, [String])
runAction Bool
False Action a
action Map Name Flag
flags [String]
tokens'
    case Set Name -> Maybe (Name, Set Name)
forall a. Set a -> Maybe (a, Set a)
Set.minView (Set Name -> Maybe (Name, Set Name))
-> Set Name -> Maybe (Name, Set Name)
forall a b. (a -> b) -> a -> b
$ Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set Name
unused (Set Name
sflags Set Name -> Set Name -> Set Name
forall a. Semigroup a => a -> a -> a
<> Set Name
sswitches) of
      Maybe (Name, Set Name)
Nothing -> (a, [String]) -> Either FlagsError (a, [String])
forall a b. b -> Either a b
Right (a
rv, [String]
tokens'')
      Just (Name
name, Set Name
names) -> FlagsError -> Either FlagsError (a, [String])
forall a b. a -> Either a b
Left (FlagsError -> Either FlagsError (a, [String]))
-> FlagsError -> Either FlagsError (a, [String])
forall a b. (a -> b) -> a -> b
$ NonEmpty Name -> FlagsError
UnexpectedFlags (NonEmpty Name -> FlagsError) -> NonEmpty Name -> FlagsError
forall a b. (a -> b) -> a -> b
$ Name
name Name -> [Name] -> NonEmpty Name
forall a. a -> [a] -> NonEmpty a
:| Set Name -> [Name]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set Name
names

-- | Runs a parser on the system's arguments, or exits with code 1 and prints the relevant error
-- message in case of failure.
parseSystemFlagsOrDie :: FlagsParser a -> IO (a, [String])
parseSystemFlagsOrDie :: FlagsParser a -> IO (a, [String])
parseSystemFlagsOrDie FlagsParser a
parser = FlagsParser a -> [String] -> Either FlagsError (a, [String])
forall a.
FlagsParser a -> [String] -> Either FlagsError (a, [String])
parseFlags FlagsParser a
parser ([String] -> Either FlagsError (a, [String]))
-> IO [String] -> IO (Either FlagsError (a, [String]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [String]
getArgs IO (Either FlagsError (a, [String]))
-> (Either FlagsError (a, [String]) -> IO (a, [String]))
-> IO (a, [String])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Left FlagsError
err -> String -> IO (a, [String])
forall a. String -> IO a
die (String -> IO (a, [String])) -> String -> IO (a, [String])
forall a b. (a -> b) -> a -> b
$ Name -> String
T.unpack (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ FlagsError -> Name
displayFlagError FlagsError
err
  Right (a, [String])
res -> (a, [String]) -> IO (a, [String])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a, [String])
res