{-# LANGUAGE FlexibleInstances #-}
-- Full-featured argument parsing library for Haskell programs
-- Bart Massey <bart@cs.pdx.edu>

-- Copyright © 2007-2010 Bart Massey
-- ALL RIGHTS RESERVED

-- You can redistribute and/or modify this library under the
-- terms of the "3-clause BSD LICENSE", as stated in the file
-- COPYING in the top-level directory of this distribution.
-- 
-- This library is distributed in the hope that it will be
-- useful, but WITHOUT ANY WARRANTY; without even the
-- implied warranty of MERCHANTABILITY or FITNESS FOR A
-- PARTICULAR PURPOSE.

-- |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(..),
  -- ** 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).
  ArgRecord, 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.  The key
-- element is the `ArgRecord` `args`.
data (Ord a) => Args a =
    Args { args :: ArgRecord a      -- ^The argument map.
         , 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

instance Typeable ParseArgsException where
    typeOf _ = mkTyConApp e [s, s] where
        e = mkTyCon "ParseArgsException"
        s = typeOf ""

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

-- |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 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 a, 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 args =
    (keymap_from_list .
     filter_keys .
     map (\arg -> (f_field arg, arg))) args

-- |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.

-- |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 function returns the empty list, `exhaust` returns
-- the final state produced.
exhaust :: (s -> [e] -> ([e], s))   -- ^Function to iterate.
        -> s                        -- ^Initial state.
        -> [e]                      -- ^Initial list.
        -> s                        -- ^Final state.
exhaust f 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, 2) required
-- positional arguments, 3) optional positional arguments; otherwise
-- a runtime error will be thrown.
parseArgs :: (Show a, Ord a) =>
             ArgsComplete   -- ^Degree of completeness of parse.
          -> [ Arg a ]      -- ^Argument descriptions.
          -> String         -- ^Full program pathname.
          -> [ String ]     -- ^Incoming program argument list.
          -> Args a         -- ^Outgoing argument parse results.
parseArgs acomplete argd pathname argv =
  runST (do
           check_argd
           let flag_args = takeWhile arg_flag argd
           let posn_args = dropWhile 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, posn, 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, posn args, optional posn args
      let residue = dropWhile arg_flag argd
      let residue' = dropWhile arg_fixed_posn residue
      let residue'' = dropWhile arg_opt_posn residue'
      unless (null residue'')
             (argdesc_error "argument description in wrong order")
      --- No argument may be "nullary".
      when (or (map arg_nullary argd))
           (argdesc_error "bogus 'nothing' argument")
      return ()
      where
        arg_fixed_posn a = (arg_posn a) && (not (arg_optional a))
        arg_opt_posn a = (arg_posn a) && (arg_optional a)
        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 acomplete of
               ArgsComplete -> ""
               ArgsTrailing s -> " [--] [" ++ s ++ " ...]"
               ArgsInterspersed -> " ... [--] ...") ++ "\n"
        --- argument lines
        arg_lines = concatMap (arg_line n) argd where
            arg_line n a =
                let s = arg_string a in
                "  " ++ s ++ 
                replicate (n - (length s)) ' ' ++
                "  " ++ argDesc a ++ "\n"
    --- simple recursive-descent parser
    parse _ _ _ av@(_, _, []) [] = ([], av)
    parse usage _ _ av [] =
        case acomplete of
          ArgsComplete -> parseError usage "unexpected extra arguments"
          _ -> ([], av)
    parse usage name_hash abbr_hash (am, posn, rest) av@(aa : aas) =
        case aa of
          "--" -> case acomplete of
                    ArgsComplete -> parseError usage
                                      ("unexpected -- " ++
                                      "(extra arguments not allowed)")
                    _ -> ([], (am, posn, (rest ++ aas)))
          s@('-' : '-' : name) ->
              case Map.lookup name name_hash of
                Just ad -> peel s ad aas
                Nothing ->
                    case acomplete of
                      ArgsInterspersed ->
                          (aas, (am, posn, rest ++ ["--" ++ name]))
                      _ -> parseError usage
                           ("unknown argument --" ++ name)
          ('-' : abbr : abbrs) ->
              case Map.lookup abbr abbr_hash of
                Just ad ->
                  let p@(args', state') = peel ['-', abbr] ad aas
                  in case abbrs of
                    [] -> p
                    ('-' : _) -> parseError usage
                                 ("bad internal '-' in argument " ++ aa)
                    _ -> (['-' : abbrs] ++ args', state')
                Nothing ->
                    case acomplete of
                      ArgsInterspersed ->
                          (['-' : abbrs] ++ aas,
                           (am, posn, rest ++ [['-', abbr]]))
                      _ -> parseError usage
                           ("unknown argument -" ++ [abbr])
          aa -> case posn of
                  (ad@(Arg { argData = Just adata }) : ps) ->
                          let (argl', (am', _, rest')) =
                                  peel_process (dataArgName adata) ad av
                          in (argl', (am', ps, rest'))
                  [] -> case acomplete of
                          ArgsComplete -> parseError usage
                                          ("unexpected argument " ++ aa)
                          _ -> (aas, (am, [], rest ++ [aa]))
        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 ad@(Arg { argData = Nothing, argIndex = index }) argl =
              let am' = add_entry name am (index, ArgvalFlag)
              in (argl, (am', posn, rest))
          peel name (Arg { argData = Just (DataArg {}) }) [] =
              parseError usage (name ++ " is missing its argument")
          peel name ad argl = peel_process name ad argl
          peel_process name
               ad@(Arg { argData = Just (DataArg {
                                     dataArgArgtype = atype }),
                         argIndex = index })
               (a : argl) =
                 let read_arg constructor kind =
                         case reads a of
                           [(v, "")] -> constructor v
                           _ -> parseError usage ("argument " ++
                                                   a ++ " to " ++ name ++
                                                   " is not " ++ kind)
                     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"
                     am' = add_entry name am (index, v)
                 in (argl, (am', posn, rest))


-- |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) =>
               ArgsComplete  -- ^Degree of completeness of parse.
            -> [ Arg a ]     -- ^Argument descriptions.
            -> IO (Args a)   -- ^Argument parse results.
parseArgsIO acomplete argd = do
  argv <- getArgs
  pathname <- getProgName
  return (parseArgs acomplete 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 args index =
        case getArg args index of
          Just v -> v
          Nothing -> error ("internal error: required argument "
                          ++ show index ++ "not supplied")

getArgPrimitive decons (Args { args = ArgRecord am }) k =
    case Map.lookup k am of
      Just v -> Just (decons v)
      Nothing -> Nothing

instance ArgType ([] Char) where
  getArg = getArgPrimitive (\(ArgvalString s) -> s)

-- |[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 (\(ArgvalInteger i) -> i)

-- |[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 (\(ArgvalInt i) -> i)

-- |[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 (\(ArgvalDouble i) -> i)

-- |[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 (\(ArgvalFloat i) -> i)

-- |[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 args index =
        case getArg args index of
          Nothing -> Nothing
          Just s -> Just (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 args k m =
  case getArg args 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 args k m =
    case getArg args 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 args msg = error (argsUsage args ++ "\n" ++ msg)
