{-# LANGUAGE FlexibleInstances, DeriveDataTypeable, CPP #-}
#if __GLASGOW_HASKELL__ > 720
{-# LANGUAGE Safe #-}
#endif
------------------------------------------------------------
-- |
-- Module      :  System.Console.ParseArgs
-- Description :  Full-featured command-line argument parsing library.
-- Copyright   :  (c) 2007 Bart Massey
-- License     :  BSD-style (see the file COPYING)
-- Maintainer  :  Bart Massey <bart.massey@gmail.com>
-- Stability   :  stable
-- Portability :  portable
--
-- `ParseArgs` is a full-featured command-line argument
-- parsing library.
--
-- This module supplies an argument parser.  Given a
-- description of type [`Arg`] of the legal arguments to the
-- program, a list of argument strings, and a bit of extra
-- information, the `parseArgs` function in this module
-- returns an `Args` data structure suitable for querying
-- using the provided functions `gotArg`, `getArg`, etc.
------------------------------------------------------------

module System.Console.ParseArgs (
  -- * Describing allowed arguments
  -- |The argument parser requires a description of
  -- the arguments that will be parsed.  This is
  -- supplied as a list of `Arg` records, built up
  -- using the functions described here.
  Arg(..),
  Argtype(..), 
  ArgsComplete(..),
  ArgsDash(..),
  APCData(..),
  ArgsParseControl(..),
  -- ** DataArg and its pseudo-constructors
  DataArg,
  argDataRequired, argDataOptional, argDataDefaulted,
  -- * Argument processing
  -- |The argument descriptions are used to parse
  -- the command line arguments, and the results
  -- of the parse can later be (efficiently) queried
  -- to determine program behavior.

  -- ** Getting parse results
  -- |The argument parser returns an opaque map
  -- from argument index to parsed argument data
  -- (plus some convenience information).
  Args(..),
  parseArgs, parseArgsIO,
  -- ** Using parse results
  -- |Query functions permit checking for the existence
  -- and values of command-line arguments.
  gotArg, ArgType(..),
  getArgString, getArgFile, getArgStdio,
  getArgInteger, getArgInt,
  getArgDouble, getArgFloat,
  ArgFileOpener(..),
  -- * Misc
  ParseArgsException(..),
  baseName, parseError, usageError,
  System.IO.IOMode(ReadMode, WriteMode, AppendMode))
where

import Control.Exception
import Control.Monad
import Control.Monad.ST
import Data.List
import qualified Data.Map as Map
import Data.Maybe
import Data.Typeable
import System.Environment
import System.IO

-- The main job of this module is to provide parseArgs.
-- See below for its contract.

--
-- Provided datatypes.
--

-- |The description of an argument, suitable for
-- messages and for parsing.  The `argData` field
-- is used both for flags with a data argument, and
-- for positional data arguments.
-- 
-- There are two cases:
--
--     (1) The argument is a flag, in which case at least
--     one of `argAbbr` and `argName` is provided;
--
--     (2) The argument is positional, in which case neither
--     `argAbbr` nor `argName` are provided, but `argData` is.
-- 
-- If none of `argAbbr`, `argName`, or `argData` are
-- provided, this is an error.  See also the
-- `argDataRequired`, `argDataOptional`, and
-- `argDataDefaulted` functions below, which are used to
-- generate `argData`.
data (Ord a) => Arg a =
    Arg { forall a. Ord a => Arg a -> a
argIndex :: a              -- ^Connects the input description
                                     -- to the output argument.
        , forall a. Ord a => Arg a -> Maybe Char
argAbbr :: Maybe Char      -- ^One-character flag name.
        , forall a. Ord a => Arg a -> Maybe [Char]
argName :: Maybe String    -- ^\"Long name\" of flag.
        , forall a. Ord a => Arg a -> Maybe DataArg
argData :: Maybe DataArg   -- ^Datum description.
        , forall a. Ord a => Arg a -> [Char]
argDesc :: String          -- ^Documentation for the argument.
        } 


-- |The types of an argument carrying data.  The constructor
-- argument is used to carry a default value.
--
-- The constructor argument should really be hidden.
-- Values of this type are normally constructed within
-- the pseudo-constructors pseudo-constructors
-- `argDataRequired`, `argDataOptional`, and
-- `argDataDefaulted`, to which only the constructor
-- function itself is passed.
data Argtype = ArgtypeString (Maybe String)
             | ArgtypeInteger (Maybe Integer)
             | ArgtypeInt (Maybe Int)
             | ArgtypeDouble (Maybe Double)
             | ArgtypeFloat (Maybe Float)


-- |Information specific to an argument carrying a datum.  This
-- is an opaque type, whose instances are constructed using the
-- pseudo-constructors `argDataRequired`, `argDataOptional`,
-- and `argDataDefaulted`.
data DataArg = DataArg { DataArg -> [Char]
dataArgName :: String       -- ^Print name of datum.
                       , DataArg -> Argtype
dataArgArgtype :: Argtype   -- ^Type of datum.
                       , DataArg -> Bool
dataArgOptional :: Bool     -- ^Datum is not required.
                       }

-- |Generate the `argData` for the given non-optional argument.
argDataRequired :: String                 -- ^Datum print name.
                -> (Maybe a -> Argtype)   -- ^Type constructor for datum.
                -> Maybe DataArg          -- ^Result is `argData`-ready.
argDataRequired :: forall a. [Char] -> (Maybe a -> Argtype) -> Maybe DataArg
argDataRequired [Char]
s Maybe a -> Argtype
c = DataArg -> Maybe DataArg
forall a. a -> Maybe a
Just (DataArg :: [Char] -> Argtype -> Bool -> DataArg
DataArg { dataArgName :: [Char]
dataArgName = [Char]
s,
                                      dataArgArgtype :: Argtype
dataArgArgtype = Maybe a -> Argtype
c Maybe a
forall a. Maybe a
Nothing,
                                      dataArgOptional :: Bool
dataArgOptional = Bool
False })

-- |Generate the `argData` for the given optional argument with no default.
argDataOptional :: String                 -- ^Datum print name.
                -> (Maybe a -> Argtype)   -- ^Type constructor for datum.
                -> Maybe DataArg          -- ^Result is `argData`-ready.
argDataOptional :: forall a. [Char] -> (Maybe a -> Argtype) -> Maybe DataArg
argDataOptional [Char]
s Maybe a -> Argtype
c = DataArg -> Maybe DataArg
forall a. a -> Maybe a
Just (DataArg :: [Char] -> Argtype -> Bool -> DataArg
DataArg { dataArgName :: [Char]
dataArgName = [Char]
s,
                                      dataArgArgtype :: Argtype
dataArgArgtype = Maybe a -> Argtype
c Maybe a
forall a. Maybe a
Nothing,
                                      dataArgOptional :: Bool
dataArgOptional = Bool
True })

-- |Generate the `argData` for the given optional argument with the
-- given default.
argDataDefaulted :: String                 -- ^Datum print name.
                 -> (Maybe a -> Argtype)   -- ^Type constructor for datum.
                 -> a                      -- ^Datum default value.
                 -> Maybe DataArg          -- ^Result is `argData`-ready.
argDataDefaulted :: forall a. [Char] -> (Maybe a -> Argtype) -> a -> Maybe DataArg
argDataDefaulted [Char]
s Maybe a -> Argtype
c a
d = DataArg -> Maybe DataArg
forall a. a -> Maybe a
Just (DataArg :: [Char] -> Argtype -> Bool -> DataArg
DataArg { dataArgName :: [Char]
dataArgName = [Char]
s,
                                         dataArgArgtype :: Argtype
dataArgArgtype = Maybe a -> Argtype
c (a -> Maybe a
forall a. a -> Maybe a
Just a
d),
                                         dataArgOptional :: Bool
dataArgOptional = Bool
True })
--
-- Returned datatypes.
--

-- |The \"kinds of values\" an argument can have.
data Argval = ArgvalFlag   -- ^For simple present vs not-present flags.
            | ArgvalString String
            | ArgvalInteger Integer
            | ArgvalInt Int
            | ArgvalDouble Double
            | ArgvalFloat Float

-- |The type of the mapping from argument index to value.
newtype ArgRecord a = ArgRecord (Map.Map a Argval)

-- |The data structure `parseArgs` produces. There is a should-be-hidden
-- field that describes the parse.
data (Ord a) => Args a =
    Args { forall a. Ord a => Args a -> ArgRecord a
__args :: ArgRecord a    -- ^The argument parse, only listed here
                                    -- to work around a Haddock bug. See
                                    -- <https://github.com/haskell/haddock/issues/456>.
         , forall a. Ord a => Args a -> [Char]
argsProgName :: String   -- ^Basename of 0th argument.
         , forall a. Ord a => Args a -> [Char]
argsUsage :: String      -- ^Full usage string.
         , forall a. Ord a => Args a -> [[Char]]
argsRest :: [ String ]   -- ^Remaining unprocessed arguments.
         }

--
-- Exception type.
--

-- |This exception is raised with an appropriate error message
-- when argument parsing fails.  The first argument is the usage
-- message, the second the actual error message from the parser.
data ParseArgsException = ParseArgsException String String
     deriving (ParseArgsException -> ParseArgsException -> Bool
(ParseArgsException -> ParseArgsException -> Bool)
-> (ParseArgsException -> ParseArgsException -> Bool)
-> Eq ParseArgsException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParseArgsException -> ParseArgsException -> Bool
$c/= :: ParseArgsException -> ParseArgsException -> Bool
== :: ParseArgsException -> ParseArgsException -> Bool
$c== :: ParseArgsException -> ParseArgsException -> Bool
Eq, Typeable)

instance Exception ParseArgsException

instance Show ParseArgsException where
    show :: ParseArgsException -> [Char]
show (ParseArgsException [Char]
usage [Char]
msg) = [Char]
msg [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
usage

--
-- Implementation.
--

-- |True if the described argument is positional.
arg_posn :: (Ord a) =>
            Arg a   -- ^Argument.
         -> Bool    -- ^True if argument is positional.
arg_posn :: forall a. Ord a => Arg a -> Bool
arg_posn (Arg { argAbbr :: forall a. Ord a => Arg a -> Maybe Char
argAbbr = Maybe Char
Nothing,
                argName :: forall a. Ord a => Arg a -> Maybe [Char]
argName = Maybe [Char]
Nothing }) = Bool
True
arg_posn Arg a
_ = Bool
False

-- |True if the described argument is a flag.
arg_flag :: (Ord a) =>
            Arg a   -- ^Argument.
         -> Bool    -- ^True if argument is a flag.
arg_flag :: forall a. Ord a => Arg a -> Bool
arg_flag Arg a
a = Bool -> Bool
not (Arg a -> Bool
forall a. Ord a => Arg a -> Bool
arg_posn Arg a
a)

-- |True if the described argument is optional.
arg_optional :: (Ord a) =>
                Arg a   -- ^Argument.
             -> Bool    -- ^False if argument is required to be present.
arg_optional :: forall a. Ord a => Arg a -> Bool
arg_optional (Arg { argData :: forall a. Ord a => Arg a -> Maybe DataArg
argData = Just (DataArg { dataArgOptional :: DataArg -> Bool
dataArgOptional = Bool
b }) }) = Bool
b
arg_optional Arg a
_ = Bool
True

arg_required :: (Ord a) =>
                Arg a   -- ^Argument.
             -> Bool    -- ^True if argument is required to be present.
arg_required :: forall a. Ord a => Arg a -> Bool
arg_required Arg a
a = Bool -> Bool
not (Arg a -> Bool
forall a. Ord a => Arg a -> Bool
arg_optional Arg a
a)

-- |Return the value of a defaulted argument.
arg_default_value :: (Ord a)
                  => Arg a         -- ^Argument.
                  -> Maybe Argval  -- ^Optional default value.
arg_default_value :: forall a. Ord a => Arg a -> Maybe Argval
arg_default_value arg :: Arg a
arg@(Arg { argData :: forall a. Ord a => Arg a -> Maybe DataArg
argData = Just
                             (DataArg { dataArgArgtype :: DataArg -> Argtype
dataArgArgtype = Argtype
da }) }) |
                             Arg a -> Bool
forall a. Ord a => Arg a -> Bool
arg_optional Arg a
arg =
    Argtype -> Maybe Argval
defval Argtype
da
    where
      defval :: Argtype -> Maybe Argval
defval (ArgtypeString (Just [Char]
v)) = Argval -> Maybe Argval
forall a. a -> Maybe a
Just ([Char] -> Argval
ArgvalString [Char]
v)
      defval (ArgtypeInteger (Just Integer
v)) = Argval -> Maybe Argval
forall a. a -> Maybe a
Just (Integer -> Argval
ArgvalInteger Integer
v)
      defval (ArgtypeInt (Just Int
v)) = Argval -> Maybe Argval
forall a. a -> Maybe a
Just (Int -> Argval
ArgvalInt Int
v)
      defval (ArgtypeDouble (Just Double
v)) = Argval -> Maybe Argval
forall a. a -> Maybe a
Just (Double -> Argval
ArgvalDouble Double
v)
      defval (ArgtypeFloat (Just Float
v)) = Argval -> Maybe Argval
forall a. a -> Maybe a
Just (Float -> Argval
ArgvalFloat Float
v)
      defval Argtype
_ = Maybe Argval
forall a. Maybe a
Nothing
arg_default_value Arg a
_ = Maybe Argval
forall a. Maybe a
Nothing

-- |There's probably a better way to do this.
perhaps :: Bool -> String -> String
perhaps :: Bool -> ShowS
perhaps Bool
b [Char]
s = if Bool
b then [Char]
s else [Char]
""

-- |Format the described argument as a string.
arg_string :: (Ord a) =>
              Arg a    -- ^Argument to be described.
           -> String   -- ^String describing argument.
arg_string :: forall a. Ord a => Arg a -> [Char]
arg_string a :: Arg a
a@(Arg { argAbbr :: forall a. Ord a => Arg a -> Maybe Char
argAbbr = Maybe Char
abbr,
                    argName :: forall a. Ord a => Arg a -> Maybe [Char]
argName = Maybe [Char]
name,
                    argData :: forall a. Ord a => Arg a -> Maybe DataArg
argData = Maybe DataArg
arg }) =
               (ShowS
optionally [Char]
"[") [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
               ((Char -> [Char]) -> Maybe Char -> [Char]
forall {a}. (a -> [Char]) -> Maybe a -> [Char]
sometimes Char -> [Char]
flag_abbr Maybe Char
abbr) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
               (Bool -> ShowS
perhaps ((Maybe Char -> Bool
forall a. Maybe a -> Bool
isJust Maybe Char
abbr) Bool -> Bool -> Bool
&& (Maybe [Char] -> Bool
forall a. Maybe a -> Bool
isJust Maybe [Char]
name)) [Char]
",") [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
               (ShowS -> Maybe [Char] -> [Char]
forall {a}. (a -> [Char]) -> Maybe a -> [Char]
sometimes ShowS
flag_name Maybe [Char]
name) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
               (Bool -> ShowS
perhaps ((Arg a -> Bool
forall a. Ord a => Arg a -> Bool
arg_flag Arg a
a) Bool -> Bool -> Bool
&& (Maybe DataArg -> Bool
forall a. Maybe a -> Bool
isJust Maybe DataArg
arg)) [Char]
" ") [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
               ((DataArg -> [Char]) -> Maybe DataArg -> [Char]
forall {a}. (a -> [Char]) -> Maybe a -> [Char]
sometimes DataArg -> [Char]
data_arg Maybe DataArg
arg) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
               (ShowS
optionally [Char]
"]")
    where
      sometimes :: (a -> [Char]) -> Maybe a -> [Char]
sometimes = [Char] -> (a -> [Char]) -> Maybe a -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
""
      optionally :: ShowS
optionally [Char]
s = Bool -> ShowS
perhaps (Arg a -> Bool
forall a. Ord a => Arg a -> Bool
arg_optional Arg a
a) [Char]
s
      flag_name :: ShowS
flag_name [Char]
s = [Char]
"--" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
s
      flag_abbr :: Char -> [Char]
flag_abbr Char
c = [ Char
'-', Char
c ]
      data_arg :: DataArg -> [Char]
data_arg (DataArg {dataArgName :: DataArg -> [Char]
dataArgName = [Char]
s}) = [Char]
"<" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
">"

-- |Filter out the empty keys for a hash.
filter_keys :: [ (Maybe a, b) ]   -- ^List of (optional key, value) pairs.
            -> [ (a, b) ]         -- ^Pairs with actual keys.
filter_keys :: forall a b. [(Maybe a, b)] -> [(a, b)]
filter_keys [(Maybe a, b)]
l =
    ((Maybe a, b) -> [(a, b)] -> [(a, b)])
-> [(a, b)] -> [(Maybe a, b)] -> [(a, b)]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Maybe a, b) -> [(a, b)] -> [(a, b)]
forall {a} {b}. (Maybe a, b) -> [(a, b)] -> [(a, b)]
check_key [] [(Maybe a, b)]
l
    where
      check_key :: (Maybe a, b) -> [(a, b)] -> [(a, b)]
check_key (Maybe a
Nothing, b
_) [(a, b)]
rest = [(a, b)]
rest
      check_key (Just a
k, b
v) [(a, b)]
rest = (a
k, b
v) (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: [(a, b)]
rest

-- |Fail with an error if the argument description is bad
-- for some reason.
argdesc_error :: String   -- ^Error message.
              -> a        -- ^Bogus polymorphic result.
argdesc_error :: forall a. [Char] -> a
argdesc_error [Char]
msg =
    [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char]
"internal error: argument description: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
msg)

-- |Make a keymap.
keymap_from_list :: (Ord k, Show k) =>
                    [ (k, a) ]    -- ^List of key-value pairs.
                                  -- Will be checked for duplicate keys.
                 -> Map.Map k a   -- ^Key-value map.
keymap_from_list :: forall k a. (Ord k, Show k) => [(k, a)] -> Map k a
keymap_from_list [(k, a)]
l =
    (Map k a -> (k, a) -> Map k a) -> Map k a -> [(k, a)] -> Map k a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Map k a -> (k, a) -> Map k a
forall {a} {a}. (Ord a, Show a) => Map a a -> (a, a) -> Map a a
add_entry Map k a
forall k a. Map k a
Map.empty [(k, a)]
l
    where
      add_entry :: Map a a -> (a, a) -> Map a a
add_entry Map a a
m (a
k, a
a) = 
          case a -> Map a a -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member a
k Map a a
m of
            Bool
False -> a -> a -> Map a a -> Map a a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert a
k a
a Map a a
m
            Bool
True -> [Char] -> Map a a
forall a. [Char] -> a
argdesc_error ([Char]
"duplicate argument description name " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
                                   (a -> [Char]
forall a. Show a => a -> [Char]
show a
k))

-- |Make a keymap for looking up a flag argument.
make_keymap :: (Ord k, Show k) =>
               (Arg a -> Maybe k)   -- ^Mapping from argdesc to flag key.
            -> [Arg a]              -- ^List of argdesc.
            -> Map.Map k (Arg a)    -- ^Map from key to argdesc.
make_keymap :: forall k a.
(Ord k, Show k) =>
(Arg a -> Maybe k) -> [Arg a] -> Map k (Arg a)
make_keymap Arg a -> Maybe k
f_field [Arg a]
ads =
    ([(k, Arg a)] -> Map k (Arg a)
forall k a. (Ord k, Show k) => [(k, a)] -> Map k a
keymap_from_list ([(k, Arg a)] -> Map k (Arg a))
-> ([Arg a] -> [(k, Arg a)]) -> [Arg a] -> Map k (Arg a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
     [(Maybe k, Arg a)] -> [(k, Arg a)]
forall a b. [(Maybe a, b)] -> [(a, b)]
filter_keys ([(Maybe k, Arg a)] -> [(k, Arg a)])
-> ([Arg a] -> [(Maybe k, Arg a)]) -> [Arg a] -> [(k, Arg a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
     (Arg a -> (Maybe k, Arg a)) -> [Arg a] -> [(Maybe k, Arg a)]
forall a b. (a -> b) -> [a] -> [b]
map (\Arg a
arg -> (Arg a -> Maybe k
f_field Arg a
arg, Arg a
arg))) [Arg a]
ads

-- |How \"sloppy\" the parse is.
data ArgsComplete = ArgsComplete         -- ^Any extraneous arguments
                                         -- (unparseable from description)
                                         -- will cause the parser to fail.
                  | ArgsTrailing String  -- ^Trailing extraneous arguments are
                                         -- permitted, and will be skipped,
                                         -- saved, and returned.  The
                                         -- constructor argument is the
                                         -- name of the args.
                  | ArgsInterspersed     -- ^All extraneous arguments are
                                         -- permitted, and will be skipped,
                                         -- saved, and returned.

-- |Whether to always treat an unknown argument beginning
-- with \"-\" as an error, or to allow it to be used as a
-- positional argument when possible.
data ArgsDash = ArgsHardDash   -- ^If an argument begins with
                               -- a \"-\", it will always be
                               -- treated as an error unless
                               -- it corresponds to a flag description.
              | ArgsSoftDash   -- ^If an argument beginning with
                               -- a \"-\" is unrecognized as a flag,
                               -- treat it as a positional argument
                               -- if possible. Otherwise it is an error.
              deriving ArgsDash -> ArgsDash -> Bool
(ArgsDash -> ArgsDash -> Bool)
-> (ArgsDash -> ArgsDash -> Bool) -> Eq ArgsDash
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ArgsDash -> ArgsDash -> Bool
$c/= :: ArgsDash -> ArgsDash -> Bool
== :: ArgsDash -> ArgsDash -> Bool
$c== :: ArgsDash -> ArgsDash -> Bool
Eq

-- |Record containing the collective parse control information.
data ArgsParseControl = ArgsParseControl {
  -- |Level of completeness of parse.
  ArgsParseControl -> ArgsComplete
apcComplete :: ArgsComplete,
  -- |Handling of dashes in parse.
  ArgsParseControl -> ArgsDash
apcDash :: ArgsDash }

-- |Class for building parse control information,
-- for backward compatibility.
class APCData a where
  getAPCData :: a -> ArgsParseControl  -- ^Build an 'ArgsParseControl'
                                       -- structure from the given info.

instance APCData ArgsParseControl where
  getAPCData :: ArgsParseControl -> ArgsParseControl
getAPCData ArgsParseControl
a = ArgsParseControl
a

instance APCData ArgsComplete where
  getAPCData :: ArgsComplete -> ArgsParseControl
getAPCData ArgsComplete
a = ArgsComplete -> ArgsDash -> ArgsParseControl
ArgsParseControl ArgsComplete
a ArgsDash
ArgsHardDash

-- |The iteration function is given a state and a list, and
-- expected to produce a new state and list.  The function
-- is again invoked with the resulting state and list.  When
-- the supplied function returns the empty list, this
-- function returns the final state produced.
exhaust :: (s -> [e] -> ([e], s))   -- ^Function to iterate.
        -> s                        -- ^Initial state.
        -> [e]                      -- ^Initial list.
        -> s                        -- ^Final state.
exhaust :: forall s e. (s -> [e] -> ([e], s)) -> s -> [e] -> s
exhaust s -> [e] -> ([e], s)
_ s
s [] = s
s
exhaust s -> [e] -> ([e], s)
f s
s [e]
l =
  let ([e]
l', s
s') = s -> [e] -> ([e], s)
f s
s [e]
l
  in (s -> [e] -> ([e], s)) -> s -> [e] -> s
forall s e. (s -> [e] -> ([e], s)) -> s -> [e] -> s
exhaust s -> [e] -> ([e], s)
f s
s' [e]
l'

-- |Generate a usage error with the given supplementary message string.
parseError :: String    -- ^Usage message.
            -> String    -- ^Specific error message.
            -> a         -- ^Bogus polymorphic result.
parseError :: forall a. [Char] -> [Char] -> a
parseError [Char]
usage [Char]
msg =
  ParseArgsException -> a
forall a e. Exception e => e -> a
throw ([Char] -> [Char] -> ParseArgsException
ParseArgsException [Char]
usage [Char]
msg)

-- |Given a description of the arguments, `parseArgs`
-- produces a map from the arguments to their \"values\" and
-- some other useful byproducts.  `parseArgs` requires that
-- the argument descriptions occur in the order 1) flag
-- arguments, then 2) positional arguments; otherwise a
-- runtime error will be thrown.
parseArgs :: (Show a, Ord a, APCData b) =>
             b              -- ^Configuration for parse.
          -> [ Arg a ]      -- ^Argument descriptions.
          -> String         -- ^Full program pathname.
          -> [ String ]     -- ^Incoming program argument list.
          -> Args a         -- ^Outgoing argument parse results.
parseArgs :: forall a b.
(Show a, Ord a, APCData b) =>
b -> [Arg a] -> [Char] -> [[Char]] -> Args a
parseArgs b
apcData [Arg a]
argd [Char]
pathname [[Char]]
argv =
  (forall s. ST s (Args a)) -> Args a
forall a. (forall s. ST s a) -> a
runST (do
           ST s ()
forall s. ST s ()
check_argd
           let ([Arg a]
flag_args, [Arg a]
posn_args) = (Arg a -> Bool) -> [Arg a] -> ([Arg a], [Arg a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Arg a -> Bool
forall a. Ord a => Arg a -> Bool
arg_flag [Arg a]
argd
           let name_hash :: Map [Char] (Arg a)
name_hash = (Arg a -> Maybe [Char]) -> [Arg a] -> Map [Char] (Arg a)
forall k a.
(Ord k, Show k) =>
(Arg a -> Maybe k) -> [Arg a] -> Map k (Arg a)
make_keymap Arg a -> Maybe [Char]
forall a. Ord a => Arg a -> Maybe [Char]
argName [Arg a]
flag_args
           let abbr_hash :: Map Char (Arg a)
abbr_hash = (Arg a -> Maybe Char) -> [Arg a] -> Map Char (Arg a)
forall k a.
(Ord k, Show k) =>
(Arg a -> Maybe k) -> [Arg a] -> Map k (Arg a)
make_keymap Arg a -> Maybe Char
forall a. Ord a => Arg a -> Maybe Char
argAbbr [Arg a]
flag_args
           let prog_name :: [Char]
prog_name = ShowS
baseName [Char]
pathname
           let usage :: [Char]
usage = ShowS
make_usage_string [Char]
prog_name
           let (Map a Argval
am, [Arg a]
_, [[Char]]
rest) = ((Map a Argval, [Arg a], [[Char]])
 -> [[Char]] -> ([[Char]], (Map a Argval, [Arg a], [[Char]])))
-> (Map a Argval, [Arg a], [[Char]])
-> [[Char]]
-> (Map a Argval, [Arg a], [[Char]])
forall s e. (s -> [e] -> ([e], s)) -> s -> [e] -> s
exhaust ([Char]
-> Map [Char] (Arg a)
-> Map Char (Arg a)
-> (Map a Argval, [Arg a], [[Char]])
-> [[Char]]
-> ([[Char]], (Map a Argval, [Arg a], [[Char]]))
forall {a}.
Ord a =>
[Char]
-> Map [Char] (Arg a)
-> Map Char (Arg a)
-> (Map a Argval, [Arg a], [[Char]])
-> [[Char]]
-> ([[Char]], (Map a Argval, [Arg a], [[Char]]))
parse [Char]
usage Map [Char] (Arg a)
name_hash Map Char (Arg a)
abbr_hash)
                                (Map a Argval
forall k a. Map k a
Map.empty, [Arg a]
posn_args, [])
                                [[Char]]
argv
           let required_args :: [Arg a]
required_args = (Arg a -> Bool) -> [Arg a] -> [Arg a]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Arg a -> Bool) -> Arg a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg a -> Bool
forall a. Ord a => Arg a -> Bool
arg_optional) [Arg a]
argd
           Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Arg a -> Bool) -> [Arg a] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Map a Argval -> Arg a -> Bool
forall {a} {a}. Ord a => [Char] -> Map a a -> Arg a -> Bool
check_present [Char]
usage Map a Argval
am) [Arg a]
required_args))
                  ([Char] -> ST s ()
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error")
           let am' :: Map a Argval
am' = (Map a Argval -> Arg a -> Map a Argval)
-> Map a Argval -> [Arg a] -> Map a Argval
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Map a Argval -> Arg a -> Map a Argval
forall {k}. Ord k => Map k Argval -> Arg k -> Map k Argval
supply_defaults Map a Argval
am [Arg a]
argd
           Args a -> ST s (Args a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Args :: forall a. ArgRecord a -> [Char] -> [Char] -> [[Char]] -> Args a
Args { __args :: ArgRecord a
__args = Map a Argval -> ArgRecord a
forall a. Map a Argval -> ArgRecord a
ArgRecord Map a Argval
am',
                          argsProgName :: [Char]
argsProgName = [Char]
prog_name,
                          argsUsage :: [Char]
argsUsage = [Char]
usage,
                          argsRest :: [[Char]]
argsRest = [[Char]]
rest }))
  where
    supply_defaults :: Map k Argval -> Arg k -> Map k Argval
supply_defaults Map k Argval
am ad :: Arg k
ad@(Arg { argIndex :: forall a. Ord a => Arg a -> a
argIndex = k
k }) =
        case k -> Map k Argval -> Maybe Argval
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k Map k Argval
am of
          Just Argval
_ -> Map k Argval
am
          Maybe Argval
Nothing -> case Arg k -> Maybe Argval
forall a. Ord a => Arg a -> Maybe Argval
arg_default_value Arg k
ad of
                       Just Argval
v -> k -> Argval -> Map k Argval -> Map k Argval
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
k Argval
v Map k Argval
am
                       Maybe Argval
Nothing -> Map k Argval
am
    check_present :: [Char] -> Map a a -> Arg a -> Bool
check_present [Char]
usage Map a a
am ad :: Arg a
ad@(Arg { argIndex :: forall a. Ord a => Arg a -> a
argIndex = a
k }) =
        case a -> Map a a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
k Map a a
am of
          Just a
_ -> Bool
True
          Maybe a
Nothing -> [Char] -> [Char] -> Bool
forall a. [Char] -> [Char] -> a
parseError [Char]
usage ([Char]
"missing required argument " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
                                        (Arg a -> [Char]
forall a. Ord a => Arg a -> [Char]
arg_string Arg a
ad))
    --- Check for various possible misuses.
    check_argd :: ST s ()
    check_argd :: forall s. ST s ()
check_argd = do
      --- Order must be flags, then posn args
      let ([Arg a]
_, [Arg a]
posns) = (Arg a -> Bool) -> [Arg a] -> ([Arg a], [Arg a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Arg a -> Bool
forall a. Ord a => Arg a -> Bool
arg_flag [Arg a]
argd
      Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Arg a -> Bool) -> [Arg a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Arg a -> Bool
forall a. Ord a => Arg a -> Bool
arg_posn [Arg a]
posns)
             ([Char] -> ST s ()
forall a. [Char] -> a
argdesc_error [Char]
"argument description mixes flags and positionals")
      --- No argument may be "nullary".
      Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ((Arg a -> Bool) -> [Arg a] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map Arg a -> Bool
forall a. Ord a => Arg a -> Bool
arg_nullary [Arg a]
argd))
           ([Char] -> ST s ()
forall a. [Char] -> a
argdesc_error [Char]
"bogus 'nothing' argument")
      () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      where
        arg_nullary :: Arg a -> Bool
arg_nullary (Arg { argName :: forall a. Ord a => Arg a -> Maybe [Char]
argName = Maybe [Char]
Nothing,
                           argAbbr :: forall a. Ord a => Arg a -> Maybe Char
argAbbr = Maybe Char
Nothing,
                           argData :: forall a. Ord a => Arg a -> Maybe DataArg
argData = Maybe DataArg
Nothing }) = Bool
True
        arg_nullary Arg a
_ = Bool
False
    --- Generate a usage message string
    make_usage_string :: ShowS
make_usage_string [Char]
prog_name =
      [Char]
summary_line [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
arg_lines
      where
        flag_args :: [Arg a]
flag_args = (Arg a -> Bool) -> [Arg a] -> [Arg a]
forall a. (a -> Bool) -> [a] -> [a]
filter Arg a -> Bool
forall a. Ord a => Arg a -> Bool
arg_flag [Arg a]
argd
        posn_args :: [Arg a]
posn_args = (Arg a -> Bool) -> [Arg a] -> [Arg a]
forall a. (a -> Bool) -> [a] -> [a]
filter Arg a -> Bool
forall a. Ord a => Arg a -> Bool
arg_posn [Arg a]
argd
        n :: Int
n = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((Arg a -> Int) -> [Arg a] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Char] -> Int) -> (Arg a -> [Char]) -> Arg a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg a -> [Char]
forall a. Ord a => Arg a -> [Char]
arg_string) [Arg a]
argd)
        --- top (summary) line
        summary_line :: [Char]
summary_line = 
            [Char]
"usage: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
prog_name [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
            Bool -> ShowS
perhaps
              (Bool -> Bool
not ([Arg a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Arg a]
flag_args))
              [Char]
" [options]" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
            Bool -> ShowS
perhaps
              (Bool -> Bool
not ([Arg a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Arg a]
posn_args))
              ([Char]
" " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords ((Arg a -> [Char]) -> [Arg a] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Arg a -> [Char]
forall a. Ord a => Arg a -> [Char]
arg_string [Arg a]
posn_args)) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
            (case ArgsParseControl -> ArgsComplete
apcComplete (ArgsParseControl -> ArgsComplete)
-> ArgsParseControl -> ArgsComplete
forall a b. (a -> b) -> a -> b
$ b -> ArgsParseControl
forall a. APCData a => a -> ArgsParseControl
getAPCData b
apcData of
               ArgsComplete
ArgsComplete -> [Char]
""
               ArgsTrailing [Char]
s -> [Char]
" [--] [" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" ...]"
               ArgsComplete
ArgsInterspersed -> [Char]
" ... [--] ...") [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
        --- argument lines
        arg_lines :: [Char]
arg_lines = (Arg a -> [Char]) -> [Arg a] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> Arg a -> [Char]
forall {a}. Ord a => Int -> Arg a -> [Char]
arg_line Int
n) [Arg a]
argd where
            arg_line :: Int -> Arg a -> [Char]
arg_line Int
na Arg a
a =
                let s :: [Char]
s = Arg a -> [Char]
forall a. Ord a => Arg a -> [Char]
arg_string Arg a
a in
                [Char]
"  " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ 
                Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
na Int -> Int -> Int
forall a. Num a => a -> a -> a
- ([Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
s)) Char
' ' [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
                [Char]
"  " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Arg a -> [Char]
forall a. Ord a => Arg a -> [Char]
argDesc Arg a
a [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
    --- simple recursive-descent parser
    parse :: [Char]
-> Map [Char] (Arg a)
-> Map Char (Arg a)
-> (Map a Argval, [Arg a], [[Char]])
-> [[Char]]
-> ([[Char]], (Map a Argval, [Arg a], [[Char]]))
parse [Char]
_ Map [Char] (Arg a)
_ Map Char (Arg a)
_ av :: (Map a Argval, [Arg a], [[Char]])
av@(Map a Argval
_, [Arg a]
_, []) [] = ([], (Map a Argval, [Arg a], [[Char]])
av)
    parse [Char]
usage Map [Char] (Arg a)
_ Map Char (Arg a)
_ (Map a Argval, [Arg a], [[Char]])
av [] =
        case ArgsParseControl -> ArgsComplete
apcComplete (ArgsParseControl -> ArgsComplete)
-> ArgsParseControl -> ArgsComplete
forall a b. (a -> b) -> a -> b
$ b -> ArgsParseControl
forall a. APCData a => a -> ArgsParseControl
getAPCData b
apcData of
          ArgsComplete
ArgsComplete -> [Char] -> [Char] -> ([[Char]], (Map a Argval, [Arg a], [[Char]]))
forall a. [Char] -> [Char] -> a
parseError [Char]
usage [Char]
"unexpected extra arguments"
          ArgsComplete
_ -> ([], (Map a Argval, [Arg a], [[Char]])
av)
    parse [Char]
usage Map [Char] (Arg a)
name_hash Map Char (Arg a)
abbr_hash (Map a Argval
am, [Arg a]
posn, [[Char]]
rest) av :: [[Char]]
av@([Char]
aa : [[Char]]
aas) =
        case [Char]
aa of
          [Char]
"--" -> case b -> ArgsParseControl
forall a. APCData a => a -> ArgsParseControl
getAPCData b
apcData of
                    ArgsParseControl ArgsComplete
ArgsComplete ArgsDash
ArgsHardDash -> 
                      [Char] -> [Char] -> ([[Char]], (Map a Argval, [Arg a], [[Char]]))
forall a. [Char] -> [Char] -> a
parseError [Char]
usage ([Char]
"unexpected -- " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
                        [Char]
"(extra arguments not allowed)")
                    ArgsParseControl
_ -> ([], (Map a Argval
am, [Arg a]
posn, ([[Char]]
rest [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
aas)))
          s :: [Char]
s@(Char
'-' : Char
'-' : [Char]
name) 
            | Maybe (Arg a) -> Bool
forall a. Maybe a -> Bool
isJust ([Char] -> Map [Char] (Arg a) -> Maybe (Arg a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
name Map [Char] (Arg a)
name_hash) Bool -> Bool -> Bool
||
              ArgsParseControl -> ArgsDash
apcDash (b -> ArgsParseControl
forall a. APCData a => a -> ArgsParseControl
getAPCData b
apcData) ArgsDash -> ArgsDash -> Bool
forall a. Eq a => a -> a -> Bool
== ArgsDash
ArgsHardDash ->
              case [Char] -> Map [Char] (Arg a) -> Maybe (Arg a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
name Map [Char] (Arg a)
name_hash of
                Just Arg a
ad -> 
                  let ([[Char]]
args', Map a Argval
am') = [Char] -> Arg a -> [[Char]] -> ([[Char]], Map a Argval)
peel [Char]
s Arg a
ad [[Char]]
aas in
                  ([[Char]]
args', (Map a Argval
am', [Arg a]
posn, [[Char]]
rest))
                Maybe (Arg a)
Nothing ->
                  case b -> ArgsParseControl
forall a. APCData a => a -> ArgsParseControl
getAPCData b
apcData of
                    ArgsParseControl ArgsComplete
ArgsInterspersed ArgsDash
_ ->
                      ([[Char]]
aas, (Map a Argval
am, [Arg a]
posn, [[Char]]
rest [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"--" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
name]))
                    ArgsParseControl
_ -> 
                      [Char] -> [Char] -> ([[Char]], (Map a Argval, [Arg a], [[Char]]))
forall a. [Char] -> [Char] -> a
parseError [Char]
usage
                        ([Char]
"unknown argument --" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
name)
          (Char
'-' : Char
abbr : [Char]
abbrs)
            | Maybe (Arg a) -> Bool
forall a. Maybe a -> Bool
isJust (Char -> Map Char (Arg a) -> Maybe (Arg a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Char
abbr Map Char (Arg a)
abbr_hash) Bool -> Bool -> Bool
||
              ArgsParseControl -> ArgsDash
apcDash (b -> ArgsParseControl
forall a. APCData a => a -> ArgsParseControl
getAPCData b
apcData) ArgsDash -> ArgsDash -> Bool
forall a. Eq a => a -> a -> Bool
== ArgsDash
ArgsHardDash ->
              case Char -> Map Char (Arg a) -> Maybe (Arg a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Char
abbr Map Char (Arg a)
abbr_hash of
                Just Arg a
ad ->
                  let ([[Char]]
args', Map a Argval
am') = [Char] -> Arg a -> [[Char]] -> ([[Char]], Map a Argval)
peel [Char
'-', Char
abbr] Arg a
ad [[Char]]
aas
                      state' :: (Map a Argval, [Arg a], [[Char]])
state' = (Map a Argval
am', [Arg a]
posn, [[Char]]
rest)
                  in case [Char]
abbrs of
                    [] -> ([[Char]]
args', (Map a Argval, [Arg a], [[Char]])
state')
                    (Char
'-' : [Char]
_) -> [Char] -> [Char] -> ([[Char]], (Map a Argval, [Arg a], [[Char]]))
forall a. [Char] -> [Char] -> a
parseError [Char]
usage
                                 ([Char]
"bad internal '-' in argument " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
aa)
                    [Char]
_ -> ([Char
'-' Char -> ShowS
forall a. a -> [a] -> [a]
: [Char]
abbrs] [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
args', (Map a Argval, [Arg a], [[Char]])
state')
                Maybe (Arg a)
Nothing ->
                    case ArgsParseControl -> ArgsComplete
apcComplete (ArgsParseControl -> ArgsComplete)
-> ArgsParseControl -> ArgsComplete
forall a b. (a -> b) -> a -> b
$ b -> ArgsParseControl
forall a. APCData a => a -> ArgsParseControl
getAPCData b
apcData of
                      ArgsComplete
ArgsInterspersed ->
                          ([[Char]]
aas,
                           (Map a Argval
am, [Arg a]
posn, [[Char]]
rest [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [Char
'-' Char -> ShowS
forall a. a -> [a] -> [a]
: Char
abbr Char -> ShowS
forall a. a -> [a] -> [a]
: [Char]
abbrs]))
                      ArgsComplete
_ -> [Char] -> [Char] -> ([[Char]], (Map a Argval, [Arg a], [[Char]]))
forall a. [Char] -> [Char] -> a
parseError [Char]
usage
                           ([Char]
"unknown argument -" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
abbr])
          [Char]
_ ->
            case [Arg a]
posn of
              (Arg a
p : [Arg a]
ps) ->
                let ([Arg a]
_, [Arg a]
req_posn) = (Arg a -> Bool) -> [Arg a] -> ([Arg a], [Arg a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Arg a -> Bool
forall a. Ord a => Arg a -> Bool
arg_optional [Arg a]
posn in
                case [[Char]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Char]]
av Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Arg a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Arg a]
req_posn of
                  Int
n_extra | Int
n_extra Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
|| (Int
n_extra Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Arg a -> Bool
forall a. Ord a => Arg a -> Bool
arg_required Arg a
p) ->
                    let ([[Char]]
args', Map a Argval
am') = [Char] -> Arg a -> [[Char]] -> ([[Char]], Map a Argval)
peel (DataArg -> [Char]
dataArgName (DataArg -> [Char]) -> DataArg -> [Char]
forall a b. (a -> b) -> a -> b
$ Maybe DataArg -> DataArg
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe DataArg -> DataArg) -> Maybe DataArg -> DataArg
forall a b. (a -> b) -> a -> b
$ 
                                             Arg a -> Maybe DataArg
forall a. Ord a => Arg a -> Maybe DataArg
argData Arg a
p) Arg a
p [[Char]]
av in
                    ([[Char]]
args', (Map a Argval
am', [Arg a]
ps, [[Char]]
rest))
                  Int
0 -> ([[Char]]
av, (Map a Argval
am, [Arg a]
ps, [[Char]]
rest))
                  Int
_ -> [Char] -> [Char] -> ([[Char]], (Map a Argval, [Arg a], [[Char]]))
forall a. [Char] -> [Char] -> a
parseError [Char]
usage 
                         [Char]
"missing required positional argument(s)"
              [] -> ([], (Map a Argval
am, [], [[Char]]
rest [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
av))
        where
          add_entry :: [Char] -> Map k a -> (k, a) -> Map k a
add_entry [Char]
s Map k a
m (k
k, a
a) =
              case k -> Map k a -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member k
k Map k a
m of
                Bool
False -> k -> a -> Map k a -> Map k a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
k a
a Map k a
m
                Bool
True -> [Char] -> [Char] -> Map k a
forall a. [Char] -> [Char] -> a
parseError [Char]
usage ([Char]
"duplicate argument " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
s)
          peel :: [Char] -> Arg a -> [[Char]] -> ([[Char]], Map a Argval)
peel [Char]
name (Arg { argData :: forall a. Ord a => Arg a -> Maybe DataArg
argData = Maybe DataArg
Nothing, argIndex :: forall a. Ord a => Arg a -> a
argIndex = a
index }) [[Char]]
argl =
              let am' :: Map a Argval
am' = [Char] -> Map a Argval -> (a, Argval) -> Map a Argval
forall {k} {a}. Ord k => [Char] -> Map k a -> (k, a) -> Map k a
add_entry [Char]
name Map a Argval
am (a
index, Argval
ArgvalFlag)
              in ([[Char]]
argl, Map a Argval
am')
          peel [Char]
name (Arg { argData :: forall a. Ord a => Arg a -> Maybe DataArg
argData = Just (DataArg {}) }) [] =
              [Char] -> [Char] -> ([[Char]], Map a Argval)
forall a. [Char] -> [Char] -> a
parseError [Char]
usage ([Char]
name [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" is missing its argument")
          peel [Char]
name (Arg { argData :: forall a. Ord a => Arg a -> Maybe DataArg
argData = 
                                 Just (DataArg { dataArgArgtype :: DataArg -> Argtype
dataArgArgtype = Argtype
atype }),
                              argIndex :: forall a. Ord a => Arg a -> a
argIndex = a
index })
              ([Char]
a : [[Char]]
argl) =
                let v :: Argval
v = case Argtype
atype of
                          ArgtypeString Maybe [Char]
_ -> [Char] -> Argval
ArgvalString [Char]
a
                          ArgtypeInteger Maybe Integer
_ -> (Integer -> Argval) -> [Char] -> Argval
forall {t} {t}. Read t => (t -> t) -> [Char] -> t
read_arg Integer -> Argval
ArgvalInteger
                                                       [Char]
"an integer"
                          ArgtypeInt Maybe Int
_ -> (Int -> Argval) -> [Char] -> Argval
forall {t} {t}. Read t => (t -> t) -> [Char] -> t
read_arg Int -> Argval
ArgvalInt [Char]
"an int"
                          ArgtypeDouble Maybe Double
_ -> (Double -> Argval) -> [Char] -> Argval
forall {t} {t}. Read t => (t -> t) -> [Char] -> t
read_arg Double -> Argval
ArgvalDouble [Char]
"a double"
                          ArgtypeFloat Maybe Float
_ -> (Float -> Argval) -> [Char] -> Argval
forall {t} {t}. Read t => (t -> t) -> [Char] -> t
read_arg Float -> Argval
ArgvalFloat [Char]
"a float"
                        where
                          read_arg :: (t -> t) -> [Char] -> t
read_arg t -> t
constructor [Char]
kind =
                            case ReadS t
forall a. Read a => ReadS a
reads [Char]
a of
                              [(t
val, [Char]
"")] -> t -> t
constructor t
val
                              [(t, [Char])]
_ -> [Char] -> [Char] -> t
forall a. [Char] -> [Char] -> a
parseError [Char]
usage ([Char]
"argument " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
                                                     [Char]
a [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" to " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
name [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
                                                     [Char]
" is not " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
kind)
                    am' :: Map a Argval
am' = [Char] -> Map a Argval -> (a, Argval) -> Map a Argval
forall {k} {a}. Ord k => [Char] -> Map k a -> (k, a) -> Map k a
add_entry [Char]
name Map a Argval
am (a
index, Argval
v)
                in ([[Char]]
argl, Map a Argval
am')


-- |Most of the time, you just want the environment's
-- arguments and are willing to live in the IO monad.
-- This version of `parseArgs` digs the pathname and arguments
-- out of the system directly.
parseArgsIO :: (Show a, Ord a, APCData b) =>
               b             -- ^Degree of completeness of parse.
            -> [ Arg a ]     -- ^Argument descriptions.
            -> IO (Args a)   -- ^Argument parse results.
parseArgsIO :: forall a b.
(Show a, Ord a, APCData b) =>
b -> [Arg a] -> IO (Args a)
parseArgsIO b
apcData [Arg a]
argd = do
  [[Char]]
argv <- IO [[Char]]
getArgs
  [Char]
pathname <- IO [Char]
getProgName
  Args a -> IO (Args a)
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> [Arg a] -> [Char] -> [[Char]] -> Args a
forall a b.
(Show a, Ord a, APCData b) =>
b -> [Arg a] -> [Char] -> [[Char]] -> Args a
parseArgs b
apcData [Arg a]
argd [Char]
pathname [[Char]]
argv)


-- |Check whether a given optional argument was supplied. Works on all types.
gotArg :: (Ord a) =>
          Args a    -- ^Parsed arguments.
       -> a         -- ^Index of argument to be checked for.
       -> Bool      -- ^True if the arg was present.
gotArg :: forall a. Ord a => Args a -> a -> Bool
gotArg (Args { __args :: forall a. Ord a => Args a -> ArgRecord a
__args = ArgRecord Map a Argval
am }) a
k =
    case a -> Map a Argval -> Maybe Argval
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
k Map a Argval
am of
      Just Argval
_ -> Bool
True
      Maybe Argval
Nothing -> Bool
False

-- |Type of values that can be parsed by the argument parser.
class ArgType b where

    -- |Fetch an argument's value if it is present.
    getArg :: (Show a, Ord a)
           => Args a    -- ^Parsed arguments.
           -> a         -- ^Index of argument to be retrieved.
           -> Maybe b   -- ^Argument value if present.

    -- |Fetch the value of a required argument.
    getRequiredArg :: (Show a, Ord a)
           => Args a    -- ^Parsed arguments.
           -> a         -- ^Index of argument to be retrieved.
           -> b   -- ^Argument value.

    getRequiredArg Args a
ads a
index =
        case Args a -> a -> Maybe b
forall b a. (ArgType b, Show a, Ord a) => Args a -> a -> Maybe b
getArg Args a
ads a
index of
          Just b
v -> b
v
          Maybe b
Nothing -> [Char] -> b
forall a. HasCallStack => [Char] -> a
error ([Char]
"internal error: required argument "
                          [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
index [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"not supplied")

getArgPrimitive :: Ord a => (Argval -> Maybe b) -> Args a -> a -> Maybe b
getArgPrimitive :: forall a b. Ord a => (Argval -> Maybe b) -> Args a -> a -> Maybe b
getArgPrimitive Argval -> Maybe b
decons (Args { __args :: forall a. Ord a => Args a -> ArgRecord a
__args = ArgRecord Map a Argval
am }) a
k =
  a -> Map a Argval -> Maybe Argval
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
k Map a Argval
am Maybe Argval -> (Argval -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Argval -> Maybe b
decons

instance ArgType () where
  getArg :: forall a. (Show a, Ord a) => Args a -> a -> Maybe ()
getArg =
      (Argval -> Maybe ()) -> Args a -> a -> Maybe ()
forall a b. Ord a => (Argval -> Maybe b) -> Args a -> a -> Maybe b
getArgPrimitive Argval -> Maybe ()
forall {m :: * -> *}. Monad m => Argval -> m ()
flagArg
      where
        flagArg :: Argval -> m ()
flagArg Argval
ArgvalFlag = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        flagArg Argval
_ = [Char] -> m ()
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error: flag arg at wrong type"

instance ArgType ([] Char) where
  getArg :: forall a. (Show a, Ord a) => Args a -> a -> Maybe [Char]
getArg =
      (Argval -> Maybe [Char]) -> Args a -> a -> Maybe [Char]
forall a b. Ord a => (Argval -> Maybe b) -> Args a -> a -> Maybe b
getArgPrimitive Argval -> Maybe [Char]
forall {m :: * -> *}. Monad m => Argval -> m [Char]
stringArg
      where
        stringArg :: Argval -> m [Char]
stringArg (ArgvalString [Char]
s) = [Char] -> m [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
s
        stringArg Argval
_ = [Char] -> m [Char]
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error: string arg at wrong type"

-- |[Deprecated]  Return the `String` value, if any, of the given argument.
getArgString :: (Show a, Ord a) =>
                Args a         -- ^Parsed arguments.
             -> a              -- ^Index of argument to be retrieved.
             -> Maybe String   -- ^Argument value if present.
getArgString :: forall a. (Show a, Ord a) => Args a -> a -> Maybe [Char]
getArgString = Args a -> a -> Maybe [Char]
forall b a. (ArgType b, Show a, Ord a) => Args a -> a -> Maybe b
getArg

instance ArgType Integer where
  getArg :: forall a. (Show a, Ord a) => Args a -> a -> Maybe Integer
getArg =
      (Argval -> Maybe Integer) -> Args a -> a -> Maybe Integer
forall a b. Ord a => (Argval -> Maybe b) -> Args a -> a -> Maybe b
getArgPrimitive Argval -> Maybe Integer
forall {m :: * -> *}. Monad m => Argval -> m Integer
integerArg
      where
        integerArg :: Argval -> m Integer
integerArg (ArgvalInteger Integer
i) = Integer -> m Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
i
        integerArg Argval
_ = [Char] -> m Integer
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error: integer arg at wrong type"

-- |[Deprecated] Return the `Integer` value, if any, of the given argument.
getArgInteger :: (Show a, Ord a) =>
                 Args a          -- ^Parsed arguments.
              -> a               -- ^Index of argument to be retrieved.
              -> Maybe Integer   -- ^Argument value if present.
getArgInteger :: forall a. (Show a, Ord a) => Args a -> a -> Maybe Integer
getArgInteger = Args a -> a -> Maybe Integer
forall b a. (ArgType b, Show a, Ord a) => Args a -> a -> Maybe b
getArg

instance ArgType Int where
  getArg :: forall a. (Show a, Ord a) => Args a -> a -> Maybe Int
getArg =
      (Argval -> Maybe Int) -> Args a -> a -> Maybe Int
forall a b. Ord a => (Argval -> Maybe b) -> Args a -> a -> Maybe b
getArgPrimitive Argval -> Maybe Int
forall {m :: * -> *}. Monad m => Argval -> m Int
intArg
      where
        intArg :: Argval -> m Int
intArg (ArgvalInt Int
i) = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
i
        intArg Argval
_ = [Char] -> m Int
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error: int arg at wrong type"

-- |[Deprecated] Return the `Int` value, if any, of the given argument.
getArgInt :: (Show a, Ord a) =>
             Args a      -- ^Parsed arguments.
          -> a           -- ^Index of argument to be retrieved.
          -> Maybe Int   -- ^Argument value if present.
getArgInt :: forall a. (Show a, Ord a) => Args a -> a -> Maybe Int
getArgInt = Args a -> a -> Maybe Int
forall b a. (ArgType b, Show a, Ord a) => Args a -> a -> Maybe b
getArg

instance ArgType Double where
  getArg :: forall a. (Show a, Ord a) => Args a -> a -> Maybe Double
getArg =
      (Argval -> Maybe Double) -> Args a -> a -> Maybe Double
forall a b. Ord a => (Argval -> Maybe b) -> Args a -> a -> Maybe b
getArgPrimitive Argval -> Maybe Double
forall {m :: * -> *}. Monad m => Argval -> m Double
doubleArg
      where
        doubleArg :: Argval -> m Double
doubleArg (ArgvalDouble Double
d) = Double -> m Double
forall (m :: * -> *) a. Monad m => a -> m a
return Double
d
        doubleArg Argval
_ = [Char] -> m Double
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error: double arg at wrong type"

-- |[Deprecated] Return the `Double` value, if any, of the given argument.
getArgDouble :: (Show a, Ord a) =>
                Args a         -- ^Parsed arguments.
             -> a              -- ^Index of argument to be retrieved.
             -> Maybe Double   -- ^Argument value if present.
getArgDouble :: forall a. (Show a, Ord a) => Args a -> a -> Maybe Double
getArgDouble = Args a -> a -> Maybe Double
forall b a. (ArgType b, Show a, Ord a) => Args a -> a -> Maybe b
getArg

instance ArgType Float where
  getArg :: forall a. (Show a, Ord a) => Args a -> a -> Maybe Float
getArg =
      (Argval -> Maybe Float) -> Args a -> a -> Maybe Float
forall a b. Ord a => (Argval -> Maybe b) -> Args a -> a -> Maybe b
getArgPrimitive Argval -> Maybe Float
forall {m :: * -> *}. Monad m => Argval -> m Float
floatArg
      where
        floatArg :: Argval -> m Float
floatArg (ArgvalFloat Float
f) = Float -> m Float
forall (m :: * -> *) a. Monad m => a -> m a
return Float
f
        floatArg Argval
_ = [Char] -> m Float
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error: float arg at wrong type"

-- |[Deprecated] Return the `Float` value, if any, of the given argument.
getArgFloat :: (Show a, Ord a) =>
               Args a        -- ^Parsed arguments.
            -> a             -- ^Index of argument to be retrieved.
            -> Maybe Float   -- ^Argument value if present.
getArgFloat :: forall a. (Show a, Ord a) => Args a -> a -> Maybe Float
getArgFloat = Args a -> a -> Maybe Float
forall b a. (ArgType b, Show a, Ord a) => Args a -> a -> Maybe b
getArg

-- |`ArgType` instance for opening a file from its string name.
newtype ArgFileOpener = ArgFileOpener {
      ArgFileOpener -> IOMode -> IO Handle
argFileOpener :: IOMode -> IO Handle  -- ^Function to open the file
    }

instance ArgType ArgFileOpener where
    getArg :: forall a. (Show a, Ord a) => Args a -> a -> Maybe ArgFileOpener
getArg Args a
ads a
index =
        Args a -> a -> Maybe [Char]
forall b a. (ArgType b, Show a, Ord a) => Args a -> a -> Maybe b
getArg Args a
ads a
index Maybe [Char]
-> ([Char] -> Maybe ArgFileOpener) -> Maybe ArgFileOpener
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 
          (\[Char]
s -> ArgFileOpener -> Maybe ArgFileOpener
forall (m :: * -> *) a. Monad m => a -> m a
return (ArgFileOpener -> Maybe ArgFileOpener)
-> ArgFileOpener -> Maybe ArgFileOpener
forall a b. (a -> b) -> a -> b
$ ArgFileOpener :: (IOMode -> IO Handle) -> ArgFileOpener
ArgFileOpener { argFileOpener :: IOMode -> IO Handle
argFileOpener = [Char] -> IOMode -> IO Handle
openFile [Char]
s })

-- |[Deprecated] Treat the `String` value, if any, of the given argument as
-- a file handle and try to open it as requested.
getArgFile :: (Show a, Ord a) =>
              Args a              -- ^Parsed arguments.
           -> a                   -- ^Index of argument to be retrieved.
           -> IOMode              -- ^IO mode the file should be opened in.
           -> IO (Maybe Handle)   -- ^Handle of opened file, if the argument
                                  -- was present.
getArgFile :: forall a.
(Show a, Ord a) =>
Args a -> a -> IOMode -> IO (Maybe Handle)
getArgFile Args a
ads a
k IOMode
m =
  case Args a -> a -> Maybe ArgFileOpener
forall b a. (ArgType b, Show a, Ord a) => Args a -> a -> Maybe b
getArg Args a
ads a
k of
    Just ArgFileOpener
fo -> (do Handle
h <- ArgFileOpener -> IOMode -> IO Handle
argFileOpener ArgFileOpener
fo IOMode
m; Maybe Handle -> IO (Maybe Handle)
forall (m :: * -> *) a. Monad m => a -> m a
return (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
h))
    Maybe ArgFileOpener
Nothing -> Maybe Handle -> IO (Maybe Handle)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Handle
forall a. Maybe a
Nothing


-- |Treat the `String` value, if any, of the given argument as a
-- file handle and try to open it as requested.  If not
-- present, substitute the appropriate one of stdin or
-- stdout as indicated by `IOMode`.
getArgStdio :: (Show a, Ord a) =>
               Args a      -- ^Parsed arguments.
            -> a           -- ^Index of argument to be retrieved.
            -> IOMode      -- ^IO mode the file should be opened in.
                           -- Must not be `ReadWriteMode`.
            -> IO Handle   -- ^Appropriate file handle.
getArgStdio :: forall a. (Show a, Ord a) => Args a -> a -> IOMode -> IO Handle
getArgStdio Args a
ads a
k IOMode
m =
    case Args a -> a -> Maybe [Char]
forall b a. (ArgType b, Show a, Ord a) => Args a -> a -> Maybe b
getArg Args a
ads a
k of
      Just [Char]
s -> [Char] -> IOMode -> IO Handle
openFile [Char]
s IOMode
m
      Maybe [Char]
Nothing ->
          case IOMode
m of
            IOMode
ReadMode -> Handle -> IO Handle
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
stdin
            IOMode
WriteMode -> Handle -> IO Handle
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
stdout
            IOMode
AppendMode -> Handle -> IO Handle
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
stdout
            IOMode
ReadWriteMode ->
                     [Char] -> IO Handle
forall a. HasCallStack => [Char] -> a
error ([Char]
"internal error: tried to open stdio "
                            [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"in ReadWriteMode")

---
--- Misc
---

-- |Return the filename part of a pathname.
-- Unnecessarily efficient implementation does a single
-- tail-call traversal with no construction.
baseName :: String   -- ^Pathname.
         -> String   -- ^Rightmost component of pathname.
baseName :: ShowS
baseName [Char]
s =
    let s' :: [Char]
s' = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/') [Char]
s in
    if [Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
s' then [Char]
s else ShowS
baseName (ShowS
forall a. [a] -> [a]
tail [Char]
s')


-- |Generate a usage error with the given supplementary message string.
usageError :: (Ord a) => Args a -> String -> b
usageError :: forall a b. Ord a => Args a -> [Char] -> b
usageError Args a
ads [Char]
msg = [Char] -> b
forall a. HasCallStack => [Char] -> a
error (Args a -> [Char]
forall a. Ord a => Args a -> [Char]
argsUsage Args a
ads [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
msg)