{-# 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 { argIndex :: a              -- ^Connects the input description
                                     -- to the output argument.
        , argAbbr :: Maybe Char      -- ^One-character flag name.
        , argName :: Maybe String    -- ^\"Long name\" of flag.
        , argData :: Maybe DataArg   -- ^Datum description.
        , 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 { dataArgName :: String       -- ^Print name of datum.
                       , dataArgArgtype :: Argtype   -- ^Type of datum.
                       , 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 s c = Just (DataArg { dataArgName = s,
                                      dataArgArgtype = c Nothing,
                                      dataArgOptional = 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 s c = Just (DataArg { dataArgName = s,
                                      dataArgArgtype = c Nothing,
                                      dataArgOptional = 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 s c d = Just (DataArg { dataArgName = s,
                                         dataArgArgtype = c (Just d),
                                         dataArgOptional = 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 { __args :: ArgRecord a    -- ^The argument parse, only listed here
                                    -- to work around a Haddock bug. See
                                    -- <https://github.com/haskell/haddock/issues/456>.
         , argsProgName :: String   -- ^Basename of 0th argument.
         , argsUsage :: String      -- ^Full usage string.
         , 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 (Eq, Typeable)

instance Exception ParseArgsException

instance Show ParseArgsException where
    show (ParseArgsException usage msg) = msg ++ "\n" ++ usage

--
-- Implementation.
--

-- |True if the described argument is positional.
arg_posn :: (Ord a) =>
            Arg a   -- ^Argument.
         -> Bool    -- ^True if argument is positional.
arg_posn (Arg { argAbbr = Nothing,
                argName = Nothing }) = True
arg_posn _ = 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 a = not (arg_posn 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 (Arg { argData = Just (DataArg { dataArgOptional = b }) }) = b
arg_optional _ = True

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

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

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

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

-- |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 l =
    foldr check_key [] l
    where
      check_key (Nothing, _) rest = rest
      check_key (Just k, v) rest = (k, v) : 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 msg =
    error ("internal error: argument description: " ++ 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 l =
    foldl add_entry Map.empty l
    where
      add_entry m (k, a) = 
          case Map.member k m of
            False -> Map.insert k a m
            True -> argdesc_error ("duplicate argument description name " ++
                                   (show 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 f_field ads =
    (keymap_from_list .
     filter_keys .
     map (\arg -> (f_field arg, arg))) 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 Eq

-- |Record containing the collective parse control information.
data ArgsParseControl = ArgsParseControl {
  -- |Level of completeness of parse.
  apcComplete :: ArgsComplete,
  -- |Handling of dashes in parse.
  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 a = a

instance APCData ArgsComplete where
  getAPCData a = ArgsParseControl a 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 _ s [] = s
exhaust f s l =
  let (l', s') = f s l
  in exhaust f s' l'

-- |Generate a usage error with the given supplementary message string.
parseError :: String    -- ^Usage message.
            -> String    -- ^Specific error message.
            -> a         -- ^Bogus polymorphic result.
parseError usage msg =
  throw (ParseArgsException usage 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 apcData argd pathname argv =
  runST (do
           check_argd
           let (flag_args, posn_args) = span arg_flag argd
           let name_hash = make_keymap argName flag_args
           let abbr_hash = make_keymap argAbbr flag_args
           let prog_name = baseName pathname
           let usage = make_usage_string prog_name
           let (am, _, rest) = exhaust (parse usage name_hash abbr_hash)
                                (Map.empty, posn_args, [])
                                argv
           let required_args = filter (not . arg_optional) argd
           unless (and (map (check_present usage am) required_args))
                  (error "internal error")
           let am' = foldl supply_defaults am argd
           return (Args { __args = ArgRecord am',
                          argsProgName = prog_name,
                          argsUsage = usage,
                          argsRest = rest }))
  where
    supply_defaults am ad@(Arg { argIndex = k }) =
        case Map.lookup k am of
          Just _ -> am
          Nothing -> case arg_default_value ad of
                       Just v -> Map.insert k v am
                       Nothing -> am
    check_present usage am ad@(Arg { argIndex = k }) =
        case Map.lookup k am of
          Just _ -> True
          Nothing -> parseError usage ("missing required argument " ++
                                        (arg_string ad))
    --- Check for various possible misuses.
    check_argd :: ST s ()
    check_argd = do
      --- Order must be flags, then posn args
      let (_, posns) = span arg_flag argd
      unless (all arg_posn posns)
             (argdesc_error "argument description mixes flags and positionals")
      --- No argument may be "nullary".
      when (or (map arg_nullary argd))
           (argdesc_error "bogus 'nothing' argument")
      return ()
      where
        arg_nullary (Arg { argName = Nothing,
                           argAbbr = Nothing,
                           argData = Nothing }) = True
        arg_nullary _ = False
    --- Generate a usage message string
    make_usage_string prog_name =
      summary_line ++ arg_lines
      where
        flag_args = filter arg_flag argd
        posn_args = filter arg_posn argd
        n = maximum (map (length . arg_string) argd)
        --- top (summary) line
        summary_line = 
            "usage: " ++ prog_name ++
            perhaps
              (not (null flag_args))
              " [options]" ++
            perhaps
              (not (null posn_args))
              (" " ++ unwords (map arg_string posn_args)) ++
            (case apcComplete $ getAPCData apcData of
               ArgsComplete -> ""
               ArgsTrailing s -> " [--] [" ++ s ++ " ...]"
               ArgsInterspersed -> " ... [--] ...") ++ "\n"
        --- argument lines
        arg_lines = concatMap (arg_line n) argd where
            arg_line na a =
                let s = arg_string a in
                "  " ++ s ++ 
                replicate (na - (length s)) ' ' ++
                "  " ++ argDesc a ++ "\n"
    --- simple recursive-descent parser
    parse _ _ _ av@(_, _, []) [] = ([], av)
    parse usage _ _ av [] =
        case apcComplete $ getAPCData apcData of
          ArgsComplete -> parseError usage "unexpected extra arguments"
          _ -> ([], av)
    parse usage name_hash abbr_hash (am, posn, rest) av@(aa : aas) =
        case aa of
          "--" -> case getAPCData apcData of
                    ArgsParseControl ArgsComplete ArgsHardDash -> 
                      parseError usage ("unexpected -- " ++
                        "(extra arguments not allowed)")
                    _ -> ([], (am, posn, (rest ++ aas)))
          s@('-' : '-' : name) 
            | isJust (Map.lookup name name_hash) ||
              apcDash (getAPCData apcData) == ArgsHardDash ->
              case Map.lookup name name_hash of
                Just ad -> 
                  let (args', am') = peel s ad aas in
                  (args', (am', posn, rest))
                Nothing ->
                  case getAPCData apcData of
                    ArgsParseControl ArgsInterspersed _ ->
                      (aas, (am, posn, rest ++ ["--" ++ name]))
                    _ -> 
                      parseError usage
                        ("unknown argument --" ++ name)
          ('-' : abbr : abbrs)
            | isJust (Map.lookup abbr abbr_hash) ||
              apcDash (getAPCData apcData) == ArgsHardDash ->
              case Map.lookup abbr abbr_hash of
                Just ad ->
                  let (args', am') = peel ['-', abbr] ad aas
                      state' = (am', posn, rest)
                  in case abbrs of
                    [] -> (args', state')
                    ('-' : _) -> parseError usage
                                 ("bad internal '-' in argument " ++ aa)
                    _ -> (['-' : abbrs] ++ args', state')
                Nothing ->
                    case apcComplete $ getAPCData apcData of
                      ArgsInterspersed ->
                          (aas,
                           (am, posn, rest ++ ['-' : abbr : abbrs]))
                      _ -> parseError usage
                           ("unknown argument -" ++ [abbr])
          _ ->
            case posn of
              (p : ps) ->
                let (_, req_posn) = partition arg_optional posn in
                case length av - length req_posn of
                  n_extra | n_extra > 0 || (n_extra == 0 && arg_required p) ->
                    let (args', am') = peel (dataArgName $ fromJust $ 
                                             argData p) p av in
                    (args', (am', ps, rest))
                  0 -> (av, (am, ps, rest))
                  _ -> parseError usage 
                         "missing required positional argument(s)"
              [] -> ([], (am, [], rest ++ av))
        where
          add_entry s m (k, a) =
              case Map.member k m of
                False -> Map.insert k a m
                True -> parseError usage ("duplicate argument " ++ s)
          peel name (Arg { argData = Nothing, argIndex = index }) argl =
              let am' = add_entry name am (index, ArgvalFlag)
              in (argl, am')
          peel name (Arg { argData = Just (DataArg {}) }) [] =
              parseError usage (name ++ " is missing its argument")
          peel name (Arg { argData = 
                                 Just (DataArg { dataArgArgtype = atype }),
                              argIndex = index })
              (a : argl) =
                let v = case atype of
                          ArgtypeString _ -> ArgvalString a
                          ArgtypeInteger _ -> read_arg ArgvalInteger
                                                       "an integer"
                          ArgtypeInt _ -> read_arg ArgvalInt "an int"
                          ArgtypeDouble _ -> read_arg ArgvalDouble "a double"
                          ArgtypeFloat _ -> read_arg ArgvalFloat "a float"
                        where
                          read_arg constructor kind =
                            case reads a of
                              [(val, "")] -> constructor val
                              _ -> parseError usage ("argument " ++
                                                     a ++ " to " ++ name ++
                                                     " is not " ++ kind)
                    am' = add_entry name am (index, v)
                in (argl, 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 apcData argd = do
  argv <- getArgs
  pathname <- getProgName
  return (parseArgs apcData argd pathname 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 (Args { __args = ArgRecord am }) k =
    case Map.lookup k am of
      Just _ -> True
      Nothing -> 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 ads index =
        case getArg ads index of
          Just v -> v
          Nothing -> error ("internal error: required argument "
                          ++ show index ++ "not supplied")

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

instance ArgType () where
  getArg =
      getArgPrimitive flagArg
      where
        flagArg ArgvalFlag = return ()
        flagArg _ = error "internal error: flag arg at wrong type"

instance ArgType ([] Char) where
  getArg =
      getArgPrimitive stringArg
      where
        stringArg (ArgvalString s) = return s
        stringArg _ = error "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 = getArg

instance ArgType Integer where
  getArg =
      getArgPrimitive integerArg
      where
        integerArg (ArgvalInteger i) = return i
        integerArg _ = error "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 = getArg

instance ArgType Int where
  getArg =
      getArgPrimitive intArg
      where
        intArg (ArgvalInt i) = return i
        intArg _ = error "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 = getArg

instance ArgType Double where
  getArg =
      getArgPrimitive doubleArg
      where
        doubleArg (ArgvalDouble d) = return d
        doubleArg _ = error "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 = getArg

instance ArgType Float where
  getArg =
      getArgPrimitive floatArg
      where
        floatArg (ArgvalFloat f) = return f
        floatArg _ = error "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 = getArg

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

instance ArgType ArgFileOpener where
    getArg ads index =
        getArg ads index >>= 
          (\s -> return $ ArgFileOpener { argFileOpener = openFile 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 ads k m =
  case getArg ads k of
    Just fo -> (do h <- argFileOpener fo m; return (Just h))
    Nothing -> return 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 ads k m =
    case getArg ads k of
      Just s -> openFile s m
      Nothing ->
          case m of
            ReadMode -> return stdin
            WriteMode -> return stdout
            AppendMode -> return stdout
            ReadWriteMode ->
                     error ("internal error: tried to open stdio "
                            ++ "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 s =
    let s' = dropWhile (/= '/') s in
    if null s' then s else baseName (tail s')


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