-- |
-- This module provides a more convient way of parsing command line
-- arguments than the GHC GetOpt package. It uses GetOpt, but hides
-- it from the user. It is reexported from module HsShellScript.
--
-- For each command line argument, a description is to be created with
-- @argdesc@. Then the command line arguments are evaluated with
-- one of the @getargs@... functions. In case of an error, this will cause a
-- exception, which provides an expressive error message to be
-- printed. Then the @arg@... functions are used to extract the
-- values contained in the arguments, with the right type. The typical use
-- of HsShellScript.Args looks something like this:
--
-- >import HsShellScript
-- >
-- >main =
-- >   do let a_onevalue = argdesc [ desc_at_most_once, ... ]
-- >          a_values   = argdesc [ desc_direct, ... ]
-- >          a_switch   = argdesc [ ... ]
-- >          ...
-- >          header = "mclapep - My Command Line Argument Parser Example Program, version 1.0.0"
-- >
-- >      args <- getargs header [a_onevalue, a_values, a_switch, ...]
-- >
-- >      val  <- optarg_req a_onevalue args        -- val  :: Maybe String
-- >      vals <- args_req   a_values args          -- vals :: [String]
-- >      doit <- arg_switch a_switch args          -- doit :: Bool
-- >      ...
-- >   `catch` 
-- >      (\argerror -> do
-- >          hPutStrLn stderr $ (argerror_message argerror) ++ "\n\n" ++ (argerror_usageinfo argerror)
-- >          exitFailure
-- >      )
--
-- Errors in the argument descriptions are regarded as bugs, and handled
-- by aborting the program with a message which is meaningful to the
-- programmer. It is assumed that the argument description is a constant for
-- a given program.
--
-- Errors in the arguments are reported using HsShellScript's error handling
-- scheme. An error description
-- value is generated, and either returned via an @Either@
-- value, or thrown as an exception.

module HsShellScript.Args ( -- ** Argument Properties
                    ArgumentProperty
                  , ArgumentDescription (..)
                  , ArgumentValueSpec (..)
                  , Argtester
                  , argdesc
                  , desc_short
                  , desc_long
                  , desc_direct
                  , desc_value_required
                  , desc_value_optional
                  , desc_times
                  , desc_once
                  , desc_at_least_once
                  , desc_at_most_once
                  , desc_any_times
                  , desc_at_least
                  , desc_at_most
                  , desc_argname
                  , desc_description
                  , desc_tester
                  , desc_integer
                  , desc_nonneg_integer
                  , readtester
                    -- ** Evaluating the Command Line
                  , Arguments
                  , getargs
                  , getargs_ordered
                  , getargs'
                  , getargs_ordered'
                  , unsafe_getargs
                  , unsafe_getargs_ordered
                    -- ** Extracting the Argument Values
                  , arg_switch
                  , arg_times
                  , args_opt
                  , args_req
                  , reqarg_opt
                  , reqarg_req
                  , optarg_opt
                  , optarg_req
                  , arg_occurs
                    -- ** Placing additional Constraints on the Arguments
                  , args_none
                  , args_all
                  , args_one
                  , args_at_most_one
                  , args_at_least_one
                  , arg_conflicts
                    -- ** Argument Error Reporting
                  , ArgError (..)
                  , usage_info
                  , argname
                  , argname_a
                  ) where

-- We use a fixed copy of GHC's GetOpt implementation. This is to work around a bug.
-- import System.Console.GetOpt
import HsShellScript.GetOpt

import Control.Monad
import Control.Exception
import Prelude hiding (catch)
import Data.Maybe
import System.Environment
import Data.List
import GHC.IO
import System.IO
import HsShellScript.Shell
import Data.Char
import Debug.Trace
import Data.Typeable




-- | Does the command line argument take an value?
data ArgumentValueSpec  = ArgumentValue_none 		-- ^ No value
                        | ArgumentValue_required 	-- ^ Value required
                        | ArgumentValue_optional	-- ^ Value optional
   deriving (Eq, Show, Ord)


-- | Argument value tester function. This tests the format of an argument's value for errors. The tester function is specified by
-- 'desc_tester' or such, as part of the argument description. 
-- 
-- The tester is passed the argument value. If the format is correct, then it returns @Nothing@. If there is an error, then it returns @Just msgf@,
-- with @msgf@ being an error message generation function. This function gets passed the argument description, and produces the error
-- message. The argument description typically is used to extract a descriptive name of the argument (using 'argname' or 'argname_a') to be included
-- in the error message.
type Argtester = String                           -- Argument value to be tested
                 -> Maybe (ArgumentDescription    -- Argument description for message generation
                           -> String              -- Error message
                          )


-- | Description of one command line argument. These are generated by
-- @argdesc@ from a list of argument properties, and subsequently used by one of the
-- @getargs@... functions. This type is abstract.
data ArgumentDescription = ArgumentDescription {
        argdesc_short_args :: [Char],                           -- ^ Short option names
        argdesc_long_args :: [String],                          -- ^ Long option names
        argdesc_argarg :: ArgumentValueSpec,                    -- ^ What about a possible value of the argument?
        argdesc_times :: Maybe (Int,Int),                       -- ^ Minimum and maximum of number of occurences allowed
        argdesc_argargname :: Maybe String,                     -- ^ Name for argument's value, for message generation
        argdesc_argarg_description :: Maybe String,             -- ^ Descrition of the argument, for message generation
        argdesc_argarg_tester :: Maybe Argtester                -- ^ Argument value tester
      }

-- excluding tester
ad_tup ad = 
   (argdesc_short_args ad, argdesc_long_args ad, argdesc_argarg ad, argdesc_times ad, argdesc_argargname ad, argdesc_argarg_description ad)

instance Eq ArgumentDescription where
   d == e = ad_tup d == ad_tup e

instance Ord ArgumentDescription where
   compare d e = compare (ad_tup d) (ad_tup e)

-- value for maximum number of times
unlimited = -1

-- Whether two argument descriptions describe the same argument.
-- Every short or long argument name occurs in only one argument
-- descriptor (this is checked). Every argument has a short or a long
-- name (short = [], long = [""] for direct arguments).
same_arg :: ArgumentDescription -> ArgumentDescription -> Bool
same_arg arg1 arg2 =
   case (argdesc_short_args arg1, argdesc_short_args arg2) of
      (a:_, b:_) -> a == b
      ([], [])   -> case (argdesc_long_args arg1, argdesc_long_args arg2) of
                       ([],_)  -> unnamed
                       (_,[])  -> unnamed
                       (l1,l2) -> head l1 == head l2
      _          -> False
   where unnamed = error "Bug in argument description: nameless, non-direct argument. desc_short or desc_long must be specified."

-- | A property of a command line argument. These are generated by the
-- @desc_@... functions, and condensed to argument
-- descriptions of type @ArgumentDescription@ by @argdesc@. This type is abstract.
newtype ArgumentProperty =
   ArgumentProperty { argumentproperty :: ArgumentDescription -> ArgumentDescription }
-- An argument property is a function which fills in part of an argument descriptor.


-- starting value for argument descriptor
nulldesc :: ArgumentDescription
nulldesc =
   ArgumentDescription {
      argdesc_short_args = [],
      argdesc_long_args = [],
      argdesc_argarg = ArgumentValue_none,
      argdesc_times = Nothing,          -- default = (0,1)
      argdesc_argargname = Nothing,
      argdesc_argarg_description = Nothing,
      argdesc_argarg_tester = Nothing
   }

-- default number of times an argument may occur
times_default = (0,1)


-- | This represents the parsed contents of the command line. It is returned
-- by the @getargs@... functions, and passed on to the
-- value extraction functions by the user.
--
-- See 'getargs', 'getargs_ordered', 'getargs\'', 'getargs_ordered\''.
newtype Arguments =
    Arguments ( [ ( ArgumentDescription             -- argument descriptor
                  , [Maybe String]                  -- arguments matching this descriptor
                  )
                ]
              , String                              -- usage information
              )

argvalues :: Arguments -> ArgumentDescription -> [Maybe String]
argvalues (Arguments (l,_)) desc =
   argvalues' l
   where
      argvalues' ((d,v):r) = if same_arg desc d then v else argvalues' r
      argvalues' []        = abort "Bug using HsShellScript: Value of unknown argument queried (add it to getarg's list)" desc

-- used internally to represent one occurence of a specific argument
type ArgOcc = (ArgumentDescription, Maybe String)


-- | Error thrown when there is an error in the
-- command line arguments.
data ArgError = ArgError {
      -- | Error message generated by HsShellScript.Args.
      argerror_message :: String,
      -- | Usage information derived from the argument descriptions.
      argerror_usageinfo :: String
   }
   deriving (Typeable)


-- |
-- Make @ArgError@ an instance of @Exception@, so we can throw and catch it, using GHC-6.10\'s new exception library.
instance Exception ArgError


---
-- Printing an @ArgError@ will produce the error message. The usage
-- information must be printed separately, using @usage_info@.
instance Show ArgError where
   show argerror = argerror_message argerror


-- Whether it is the description for direct arguments. Direct arguments are
-- the ones without introducing "-" or "--".
is_direct :: ArgumentDescription -> Bool
is_direct desc =
   argdesc_short_args desc == [] && argdesc_long_args desc == [""]


-- |
-- Short name of the argument. This specifies a character for a
-- one letter style argument, like @-x@. There can be specified
-- several for the same argument. Each argument needs at least
-- either a short or a long name.
desc_short :: Char                      -- ^ The character to name the argument.
           -> ArgumentProperty    -- ^ The corresponding argument property.
desc_short c = ArgumentProperty
   (\desc ->
      if (c `elem` (argdesc_short_args desc))
         then abort ("Bug in HsShellScript argument description: Duplicate short argument " ++ show c ++ " specified") desc
         else if ("" `elem` argdesc_long_args desc)
                 then abort_conflict "" desc
                 else desc { argdesc_short_args = c : argdesc_short_args desc }
   )

-- |

-- Long name of the argument. This specifies a GNU style long name for the argument, which is
-- introduced by two dashes, like @--arg@ or @--arg=...@. There can be specified several names for
-- the same argument. Each argument needs at least either a short or a long name. Except for direct 
-- arguments, which don't have a name.
--
-- See 'desc_direct'

desc_long :: String                     -- ^ The long name of the argument.
          -> ArgumentProperty     -- ^ The corresponding argument property.
desc_long str = ArgumentProperty
   (\desc ->
      if (str `elem` (argdesc_long_args desc))
         then abort ("Bug in HsShellScript argument description: Duplicate long argument " ++ show str ++ " specified") desc
         else if ("" `elem` argdesc_long_args desc)
                 then abort_conflict "" desc
                 else desc { argdesc_long_args = str : argdesc_long_args desc }
   )

-- |
-- Signal that this is the description of direct arguments. Direct arguments are the ones not
-- introduced by any short or long argument names (like @-x@ or @--arg@). After the special argument
-- @--@, also everything is a direct argument, even when starting with @-@ or @--@. The presence of
-- @desc_direct@ in the argument properties list signals @argdesc@ that this is the description of
-- the direct arguments. There may be at most one such description.
desc_direct :: ArgumentProperty
desc_direct = ArgumentProperty
   (\desc ->
      if argdesc_long_args desc == [] && argdesc_short_args desc == [] && argdesc_argarg desc == ArgumentValue_none
         then desc { argdesc_long_args = [""], argdesc_argarg = ArgumentValue_required, argdesc_argargname = Just "" }
         else abort_conflict "desc_direct conflicts desc_long, desc_short, desc_value_required and desc_value_optional." desc
   )

-- |
-- Signal that the argument requires a value.
desc_value_required :: ArgumentProperty
desc_value_required = ArgumentProperty
   (\desc ->
      if argdesc_argarg desc == ArgumentValue_none
         then desc { argdesc_argarg = ArgumentValue_required }
         else abort_conflict "desc_value_required repeated or conflicting desc_value_optional" desc
   )

-- |
-- Signal that the argument optionally has a value. The user may or may
-- not specify a value to this argument.
desc_value_optional :: ArgumentProperty
desc_value_optional = ArgumentProperty
   (\desc ->
      if argdesc_argarg desc == ArgumentValue_none
         then desc { argdesc_argarg = ArgumentValue_optional }
         else abort_conflict "desc_value_optional repeated or conflicting desc_value_required" desc
   )

-- |
-- Specify lower and upper bound on the number of times an argument may
-- occur.
desc_times :: Int                       -- ^ Lower bound of the allowed number of argdesc_times.
           -> Int                       -- ^ Upper bound of the allowed number of argdesc_times.
           -> ArgumentProperty          -- ^ The corresponding argument property.
desc_times n m = ArgumentProperty
   (\desc ->
       if argdesc_times desc == Nothing
          then desc { argdesc_times = Just (n,m) }
          else abort_conflict "desc_times conflicting previous number of occurences specification" desc
   )

-- |
-- Signal that the argument must be present exactly once. This is
-- meaningful only for arguments which can take a value.
desc_once :: ArgumentProperty     -- ^ The corresponding argument property.
desc_once = desc_times 1 1

-- |
-- Signal that the argument must occur at least one time.
desc_at_least_once :: ArgumentProperty -- ^ The corresponding argument property.
desc_at_least_once = desc_times 1 unlimited

-- |
-- Signal that the argument must occur at most one time.
desc_at_most_once :: ArgumentProperty -- ^ The corresponding argument property.
desc_at_most_once  = desc_times 0 1

-- |
-- Signal that the argument must have at least the specified number of
-- occurences, and has no upper limit of occurences.
desc_at_least :: Int                        -- ^ Number of times.
              -> ArgumentProperty           -- ^ The corresponding argument property.
desc_at_least n = desc_times n unlimited

-- |
-- Signal that the argument may occur any number of times.
desc_any_times :: ArgumentProperty -- ^ The corresponding argument property.
desc_any_times  = desc_times 0 unlimited

-- |
-- Signal that the argument does not need to be present, and may occur at most
-- the specified number of times.
desc_at_most :: Int                     -- ^ Number of times.
             -> ArgumentProperty  -- ^ The corresponding argument property.
desc_at_most n = desc_times 0 n

-- |
-- Specify the descriptive name for command line argument's value. Used for the
-- generation of the usage message. The name should be very short.
desc_argname :: String                          -- ^ Name of the argument's value.
             -> ArgumentProperty          -- ^ The corresponding argument property.
desc_argname name = ArgumentProperty
   (\desc ->
      if argdesc_argargname desc == Nothing
         then desc { argdesc_argargname = Just name }
         else abort "Bug in HsShellScript argument description: Multiple names specified" desc
   )

-- |
-- Specify a short description of what the argument does. Used for the
-- generation of the usage message. This is to fit on one line, after the
-- short and long argument names. It should be 40 characters long or so.
desc_description :: String                      -- ^ Short description of the argument.
                 -> ArgumentProperty      -- ^ The corresponding argument property.
desc_description expl = ArgumentProperty
   (\desc ->
      if argdesc_argarg_description desc == Nothing
         then desc { argdesc_argarg_description = Just expl }
         else abort "Bug in HsShellScript argument description: Multiple explanations specified" desc
   )

-- | Specify a tester for this argument. The tester is a function which tests the argument value for format errors. Typically, it tests whether the
-- value can be parsed to some target type. If the test fails, the tester produces an error message. When parsing the command line arguments (which
-- @getargs@ or related), all the testers are applied to the respective argument values, and an 'ArgError' is thrown in case of failure. By using a
-- tester, it can be ensured that the argument values abide a specific format when extracting them, such that they can be parsed without errors, e.g.
-- @myarg = read (reqarg_req args d_myarg)@.
--
-- An argument tester is a function of type 'Argtester'. 
--
-- See 'readtester', 'desc_integer', 'desc_nonneg_integer', 'Argtester'.
desc_tester :: Argtester                        -- ^ Argument tester to apply to this argument
            -> ArgumentProperty                 -- ^ The corresponding argument property.
desc_tester t = ArgumentProperty
   (\desc ->
      case argdesc_argarg_tester desc of
         Nothing -> desc { argdesc_argarg_tester = Just t }
         Just _  -> abort "Bug in HsShellScript argument description: Multiple argument value testers specified" desc
   )


-- |
-- Build an argument tester from a @reads@ like function. Typically, a specialisation of the standard prelude function @read@ is used. 
-- Example: @readtester \"Integer expected.\" (reads :: ReadS Int)@
readtester :: ReadS a                           -- Reader function, like the standard prelude function @reads@
           -> String                            -- Additional message
           -> Argtester                         -- Argument tester to be passed to 'desc_tester'
readtester reader msg val = 
   case filter ((== "") . snd) $ reader val of
      [(_,"")] -> Nothing
      []       -> Just (\arg -> "Format error in the value of the " ++ argname_a arg ++ ". " ++ msg ++ "\nValue: " ++ quote val)
      _        -> Just (\arg -> "Ambigious value of the " ++ argname_a arg ++ ". " ++ msg ++ "\nValue: " ++ quote val)


{- | Specify that the value of this argument, if present, is a positive integer. This will cause an error when the command line is parsed, and the
   argument's value doesn't specify an integer.

>desc_integer = desc_tester (readtester (reads :: ReadS Int) "Integer expected.")

   See 'desc_tester'.
-}
desc_integer :: ArgumentProperty
desc_integer = desc_tester (readtester (reads :: ReadS Int) "Integer expected.")


{- | Specify that the value of this argument, if present, is a non-negative integer. This will cause an error when the command line is parsed, and the
   value doesn't specify a non-negative integer.

>desc_nonneg_integer = desc_tester (readtester ((filter (\(a,_) -> a >= 0) . reads) :: ReadS Int) "Non-negative integer expected." )

   See 'desc_tester'.
-}
desc_nonneg_integer :: ArgumentProperty
desc_nonneg_integer = desc_tester (readtester ((filter (\(a,_) -> a >= 0) . reads) :: ReadS Int) "Non-negative integer expected." )


abort_conflict msg = abort ("Conflicting properties in argument description. " ++ msg)
abort msg desc = error (msg ++ "\nargument (so far): " ++ argname desc)

-- | Generate a descriptive argument name from an argument description, suitable for use in error messages. This uses the long and short argument names
-- (as specified by 'desc_short' and 'desc_long') and generates descriptive names of the argument like \"-f\", \"--myflag\", \"-f\/--myflag\", etc. All the
-- argument names are included. In case of direct arguments (see 'desc_direct'), the descriptive name is \"@(direct argument)@\".
argname :: ArgumentDescription -> String
argname desc =
   if (argdesc_short_args desc, argdesc_long_args desc) == ([],[""]) then "(direct argument)"
      else if (argdesc_short_args desc, argdesc_long_args desc) == ([],[]) then "yet unnamed argument"
         else concat (intersperse "/" ( map (\s -> "-"++[s]) (argdesc_short_args desc) ++ map ("--" ++) (argdesc_long_args desc) ))

-- | Generate a descriptive argument name from an argument description, beginning with \"argument\". This uses the long and short argument names (as
-- specified by 'desc_short' and 'desc_long') and generates descriptive names of the argument like \"argument -f\", \"argument --myflag\", \"argument
-- -f\/--myflag\", etc. All the argument names are included. In case of direct arguments (see 'desc_direct'), the descriptive name is \"direct argument\".
argname_a :: ArgumentDescription -> String
argname_a desc =
   if (argdesc_short_args desc, argdesc_long_args desc) == ([],[""]) then "direct argument"
      else if (argdesc_short_args desc, argdesc_long_args desc) == ([],[]) then "yet unnamed argument"
         else "argument " ++ concat (intersperse "/" ( map (\s -> "-"++[s]) (argdesc_short_args desc) ++ map ("--" ++) (argdesc_long_args desc) ))

up1 "" = ""
up1 (x:xs) = toUpper x : xs

-- complete generation of argument description
prop_final :: ArgumentProperty
prop_final = ArgumentProperty
   (\desc ->
      seq (if argdesc_argarg desc /= ArgumentValue_none && argdesc_argargname desc == Nothing
              then error $ "Bug in description of " ++ argname_a desc ++ ": Argument's value must be given a name using desc_argname."
              else if argdesc_argarg desc == ArgumentValue_none && argdesc_argargname desc /= Nothing
                      then error $ "Bug in description of " ++ argname_a desc
                           ++ ": Argument doesn't take a sub argument, but a name for it is specified."
                      else ()
          ) $
          desc { argdesc_times = Just (fromMaybe times_default (argdesc_times desc))
               , argdesc_argarg_description = Just (fromMaybe "" (argdesc_argarg_description desc))
               }
   )

-- |
-- Make an argument description from a list of argument properties. This
-- condenses the list to an argument description,
-- which can be used by the @getargs@... functions and the
-- argument value extraction functions.
argdesc :: [ArgumentProperty]     -- ^ List of properties, which describe the command line argument.
        -> ArgumentDescription    -- ^ The corresponding argument description.
argdesc propl =
   foldr (.) id (map argumentproperty (prop_final:propl)) nulldesc


-- Parse command line arguments.
getargs0 :: String -> ArgOrder ArgOcc -> [String] -> [ArgumentDescription] -> Either ArgError Arguments
getargs0 header ordering cmdlargs descs =
   let (  descs_direct     -- direct arguments (without argument name)
        , descs_regular    -- regular arguments (with long or short argument name)
        ) = partition is_direct descs

       nonunique :: Eq a => [a] -> Maybe a
       nonunique (a:b:r) = if (a == b) then (Just a) else nonunique (b:r)
       nonunique _       = Nothing

       test_unique :: (Show a, Ord a) => (ArgumentDescription -> [a]) -> String -> b -> b
       test_unique extr what x =
           case nonunique (sort (concat (map extr descs))) of
              Just y -> error ("Bug: Several occurences of " ++ what ++ " " ++ show y ++ " in command line argument specifications")
              Nothing -> x

       optdescr = map make_optdescr descs_regular

       make_optdescr :: ArgumentDescription -> OptDescr ArgOcc
       make_optdescr desc =
          Option (argdesc_short_args desc)
                 (argdesc_long_args desc)
                 (case argdesc_argarg desc of
                     ArgumentValue_none      -> NoArg  (desc, Nothing)
                     ArgumentValue_required     -> ReqArg (\arg -> (desc, Just arg))
                                              (fromJust (argdesc_argargname desc))
                     ArgumentValue_optional     -> OptArg (\arg -> (desc, arg))
                                              (fromJust (argdesc_argargname desc))
                 )
                 (fromJust (argdesc_argarg_description desc))

       -- Postprocessing after successful call to getOpt
       getopt_post :: [ArgOcc] -> [String] -> Either ArgError Arguments
       getopt_post pars{-getOpt recognized arguments-} rest{-direct arguments-} =
          case (rest, descs_direct) of
             ([],[])  ->
                -- no direct arguments allowed and none provided
                getopt_post' pars
             (r, [d]) ->
                -- direct arguments allowed and expected
                getopt_post' (pars ++ zip (repeat d) (map Just r))
             ((x:xs), []) ->
                -- direct arguments provided, but not allowed
                Left (ArgError "Surplus arguments." usageinfo)
             _ ->
                -- several descriptions for direct arguments
                error "Bug in argument descriptions: Several descriptions for direct arguments (desc_direct) specified."

       add :: (ArgumentDescription, Maybe String) -> [(ArgumentDescription, [Maybe String])] -> [(ArgumentDescription, [Maybe String])]
       add (a,str) []        = [(a,[str])]
       add (b,str) ((a,l):r) =
          if same_arg a b then (a,str:l) : r
                          else (a,l) : add (b,str) r

       getopt_post' :: [ArgOcc] -> Either ArgError Arguments
       getopt_post' pars{-all arguments-} =
          let pars' = foldr add (map (\d -> (d,[])) descs) pars

              -- Check the number of argument occurences
              check_num :: [(ArgumentDescription, [Maybe String])] -> Maybe ArgError
              check_num [] = Nothing
              check_num ((desc,args):rest) =
                 let (min,max) = fromJust (argdesc_times desc)
                     number    = length args
                     wrong_number_msg =
                        (if is_direct desc then fst else snd) $
                        if number == 0 && min == 1 then
                           ( "Missing argument."
                           , "Missing " ++ argname_a desc ++ "."
                           )
                        else if number < min then
                           ( "Too few arguments. " ++ show min ++ " required."
                           , "Too few instances of " ++ argname_a desc ++ ". "++ show min ++ " required."
                           )
                        else if number > max && max == 1 then
                           ( "Only one argument may be specified."
                           , "Repeated " ++ argname_a desc ++ "."
                           )
                        else if number > max && max /= unlimited then
                           ( "Too many arguments."
                           , "Too many instances of " ++ argname_a desc ++ "."
                           )
                        else error "bug in HsShellScript.Args.hs"
                 in  if number >= min && (number <= max || max == unlimited)
                        then check_num rest
                        else Just (ArgError wrong_number_msg usageinfo)

              -- Apply any argument testers
              check_testers :: [(ArgumentDescription, [Maybe String])] -> Maybe ArgError
              check_testers [] = Nothing
              check_testers ((desc,args):rest) =
                 case argdesc_argarg_tester desc of
                    Just argdesc_argarg_tester -> 
                       if argdesc_argarg desc == ArgumentValue_none 
                          then abort "Bug in HsShellScript argument descriptions: Argument value tester specified,\n\
                                     \but no argument value has been allowed. Add desc_value_optional or\n\
                                     \desc_value_required." 
                                     desc
                          else case filter isJust (map (argdesc_argarg_tester . fromJust) (filter isJust args)) of
                                  []              -> check_testers rest
                                  (Just msgf : _) -> Just (ArgError (msgf desc) usageinfo)
                    Nothing -> check_testers rest

          in  case check_testers pars' of 
                 Nothing  -> case check_num pars' of
                                Nothing  -> Right (Arguments (pars',usageinfo))
                                Just err -> Left err
                 Just err -> Left err

       -- usage information generated by GetOpt
       usageinfo = usageInfo header optdescr

   in test_unique argdesc_short_args "short argument" $
         test_unique argdesc_long_args "long argument" $
            case getOpt ordering optdescr cmdlargs of
               (pars, rest, []) ->
                  getopt_post pars rest
               (_,_,f) ->
                  throw (ArgError (unlines (map chomp f)) (usageInfo header optdescr))
   where
      -- duplicated here in order to break cyclic module dependency
      chomp "" = ""
      chomp "\n" = ""
      chomp [x] = [x]
      chomp (x:xs) = let xs' = chomp xs
                     in  if xs' == "" && x == '\n' then "" else x:xs'


-- |
-- Parse command line arguments. The arguments are taken from a call to
-- @getArgs@ and parsed. Any error is thrown as a 
-- @ArgError@ exception. The result is a value from which the
-- information in the command line can be extracted by the @arg@...,
-- @reqarg@... and @optarg@... functions.
--
-- Named arguments (like @-x@ or @--arg@) and direct
-- arguments may occur in any order.
getargs :: String                               -- ^ Header to be used in the usage info.
        -> [ArgumentDescription]          -- ^ The argument descriptions.
        -> IO Arguments                   -- ^ The contents of the command line.
getargs header descs = do
   args <- getArgs
   let res = getargs0 header Permute args descs
   either throw
          return
          res

-- |
-- Parse command line arguments. The arguments are taken from a call to
-- @getArgs@ and parsed. Any error is thrown as a 
-- @ArgError@ exception. The result is a value from which the
-- information in the command line can be extracted by the @arg@...,
-- @reqarg@... and @optarg@... functions.
--
-- All arguments after the first direct argument are regarded as direct
-- arguments. This means that argument names introduced by @-@
-- or @--@ no longer take effect.
getargs_ordered :: String                       -- ^ Header to be used in the usage info.
                -> [ArgumentDescription]  -- ^ Descriptions of the arguments.
                -> IO Arguments           -- ^ The contents of the command line.
getargs_ordered header descs = do
   args <- getArgs
   either throw
          return
          (getargs0 header RequireOrder args descs)

-- |
-- Parse the specified command line. Any error is returned as @Left
-- argerror@. In case of success, the result is returned as
-- @Right res@. From the result, the information in the command
-- line can be extracted by the @arg@..., @reqarg@...
-- and @optarg@... functions.
--
-- Named arguments (like @-x@ or @--arg@) and direct
-- arguments may occur in any order.
getargs' :: String                              -- ^ Header to be used in the usage info.
         -> [String]                            -- ^ Command line to be parsed.
         -> [ArgumentDescription]         -- ^ The argument descriptions.
         -> Either ArgError Arguments     -- ^ The contents of the command line.
getargs' header args descs = getargs0 header Permute args descs

-- |
-- Parse the specified command line. Any error is returned as @Left
-- argerror@. In case of success, the result is returned as
-- @Right res@. From the result, the information in the command
-- line can be extracted by the @arg@..., @reqarg@...
-- and @optarg@... functions.
--
-- All arguments after the first direct argument are regarded as direct
-- arguments. This means that argument names introduced by @-@
-- or @--@ no longer take effect.
getargs_ordered' :: String                              -- ^ Header to be used in the usage info.
                 -> [String]                            -- ^ Command line to be parsed.
                 -> [ArgumentDescription]         -- ^ The argument descriptions.
                 -> Either ArgError Arguments     -- ^ The contents of the command line.
getargs_ordered' header args descs = getargs0 header RequireOrder args descs


test_desc :: ArgumentDescription -> Bool -> String -> b -> b
test_desc desc ok msg x =
   if ok then x
         else abort msg desc

maybe_head :: [a] -> Maybe a
maybe_head [] = Nothing
maybe_head [a] = Just a

-- |
-- Query whether a certain switch is specified on the command line. A switch is an
-- argument which is allowed zero or one time, and has no value.
arg_switch :: Arguments                   -- ^ Command line parse result.
           -> ArgumentDescription         -- ^ Argument description of the switch.
           -> Bool                              -- ^ Whether the switch is present in the command line.
arg_switch args desc =
   test_desc desc (argdesc_argarg desc == ArgumentValue_none && argdesc_times desc == Just (0,1))
             "bug: querying argument with is not a switch with arg_switch" $
   case argvalues args desc of
      []         -> False
      [Nothing]  -> True

-- |
-- Query the number of occurences of an argument.
arg_times :: Arguments                    -- ^ Command line parse result.
          -> ArgumentDescription          -- ^ Description of the argument.
          -> Int                          -- ^ Number of times the argument occurs.
arg_times args desc =
   length (argvalues args desc)

-- |
-- Query the values of an argument with optional value. This is for
-- arguments which take an optional value, and may occur several times. The
-- occurences with value are represented as @Just value@, the occurences
-- without are represented as @Nothing@.
args_opt :: Arguments                     -- ^ Command line parse result.
         -> ArgumentDescription           -- ^ Description of the argument.
         -> [Maybe String]                      -- ^ The occurences of the argument.
args_opt args desc =
   test_desc desc (argdesc_argarg desc == ArgumentValue_optional && snd (fromJust (argdesc_times desc)) /= 1)
             "Bug: Querying argument which doesn't take an optional value, or may not occur several times, with args_opt."
   $ argvalues args desc

-- |
-- Query the values of an argument with required value. This is for
-- arguments which require a value, and may occur several times.
args_req :: Arguments                     -- ^ Command line parse result.
         -> ArgumentDescription           -- ^ Description of the argument.
         -> [String]                            -- ^ The values of the argument.
args_req args desc =
   test_desc desc (argdesc_argarg desc == ArgumentValue_required && snd (fromJust (argdesc_times desc)) /= 1)
             "Bug: Querying argument which doesn't require a value, or may not occur several times, with args_req." $
   map fromJust (argvalues args desc)

-- |
-- Query the optional value of a required argument. This is for arguments
-- which must occur once, and may have a value. If the argument is
-- specified, its value is returned as @Just value@. If it isn't, the result
-- is @Nothing@.
reqarg_opt :: Arguments                   -- ^ Command line parse result.
           -> ArgumentDescription         -- ^ Description of the argument.
           -> Maybe String                      -- ^ The value of the argument, if it occurs.
reqarg_opt args desc =
   test_desc desc (argdesc_argarg desc == ArgumentValue_optional && argdesc_times desc == Just (1,1))
             "Bug: Querying argument which doesn't take an optional value, or which must not occur exactly once, with reqarg_opt." $
   head (argvalues args desc)

-- |
-- Query the value of a required argument. This is for arguments which must
-- occur exactly once, and require a value.
reqarg_req :: Arguments                   -- ^ Command line parse result.
           -> ArgumentDescription         -- ^ Description of the argument.
           -> String                            -- ^ The value of the argument.
reqarg_req args desc =
   test_desc desc (argdesc_argarg desc == ArgumentValue_required && argdesc_times desc == Just (1,1))
             "Bug: Querying argument with non-required value, or which doesn't occur exactly once, with reqarg_req." $
   fromJust (head (argvalues args desc))

-- |
-- Query the optional value of an optional argument. This is for arguments
-- which may occur zero or one time, and which may or may not have a value.
-- If the argument doesn't occur, the result is @Nothing@. If it does occur,
-- but has no value, then the result is @Just Nothing@. If it does occur with
-- value, the result is @Just (Just value)@.
optarg_opt :: Arguments                   -- ^ Command line parse result.
           -> ArgumentDescription         -- ^ Description of the argument.
           -> Maybe (Maybe String)              -- ^ The occurence of the argument and its value (see above).
optarg_opt args desc =
   test_desc desc (argdesc_argarg desc == ArgumentValue_optional)  "Bug: Querying argument with non-optional value with optarg_opt." $
   test_desc desc (fst (fromJust (argdesc_times desc)) == 0)       "Bug: Querying argument which isn't optional with optarg_opt." $
   test_desc desc (snd (fromJust (argdesc_times desc)) == 1)       "Bug: Querying argument which may occur several times optarg_opt." $
   maybe_head (argvalues args desc)

-- |
-- Query the value of an optional argument. This is for optional arguments
-- which require a value, and may occur at most once. The result is
-- @Just value@ if the argument occurs, and @Nothing@
-- if it doesn't occur.
optarg_req :: Arguments                   -- ^ Command line parse result.
           -> ArgumentDescription         -- ^ Description of the argument.
           -> Maybe String                      -- ^ The value of the argument, if it occurs.
optarg_req args desc =
   test_desc desc (argdesc_argarg desc == ArgumentValue_required)        "Bug: Querying argument with non-required value with optarg_req."
   $ test_desc desc (fst (fromJust (argdesc_times desc)) == 0)          "Bug: Querying argument which isn't optional with optarg_req."
   $ test_desc desc (snd (fromJust (argdesc_times desc)) == 1)          "Bug: Querying argument which may occur several times optarg_req."
   $ fmap fromJust (maybe_head (argvalues args desc))


-- |
-- None of the specifed arguments may be present.
--
-- Throws an ArgError if any of the arguments are present.
args_none :: [ArgumentDescription]        -- ^ List of the arguments which must not be present.
          -> Arguments                    -- ^ Command line parse result.
          -> IO ()
args_none descs args@(Arguments (argl,usageinfo)) =
   mapM_ (\desc ->
             when (arg_times args desc /= 0) $
                throw (ArgError (up1 (argname_a desc) ++ " is not allowed.\n") usageinfo)
         )
         descs

-- |
-- All of the specified arguments must be present.
--
-- Throws an ArgError if any is missing.
args_all :: [ArgumentDescription]         -- ^ List of the arguments which must be present.
         -> Arguments                     -- ^ Command line parse result.
         -> IO ()
args_all descs args@(Arguments (argl,usageinfo)) =
   mapM_ (\desc ->
             when (arg_times args desc == 0) $
                throw (ArgError ("Missing " ++ argname_a desc ++ "\n") usageinfo)
         )
         descs

-- |
-- Exactly one of the specified arguments must be present.
--
-- Otherwise throw an ArgError.
args_one :: [ArgumentDescription]         -- ^ List of the arguments, of which exactly one must be present.
         -> Arguments                     -- ^ Command line parse result.
         -> IO ()
args_one descs args@(Arguments (argl,usageinfo)) =
   when (occuring descs args /= 1) $
      throw (ArgError ("Exactly one of the following arguments must be present.\n"
                       ++ concat (intersperse ", " (map argname descs)) ++ "\n")
                       usageinfo)


-- |
-- At most one of the specified arguments may be present.
--
-- Otherwise throw an ArgError.
args_at_most_one :: [ArgumentDescription] -- ^ List of the arguments, of which at most one may be present.
                 -> Arguments             -- ^ Command line parse result.
                 -> IO ()
args_at_most_one descs args@(Arguments (argl,usageinfo)) =
   when (occuring descs args > 1) $
      throw (ArgError ("Only one of the following arguments may be present.\n"
                       ++ concat (intersperse ", " (map argname descs)) ++ "\n")
                      usageinfo)


-- |
-- At least one of the specified arguments must be present.
--
-- Otherwise throw an ArgError.
args_at_least_one :: [ArgumentDescription]        -- ^ List of the arguments, of which at least one must be present.
                  -> Arguments                    -- ^ Command line parse result.
                  -> IO ()
args_at_least_one descs args@(Arguments (argl,usageinfo)) =
   when (occuring descs args == 0) $
      throw (ArgError ("One of the following arguments must be present.\n"
                       ++ concat (intersperse ", " (map argname descs)) ++ "\n")
                      usageinfo)


-- |
-- When the specified argument is present, then none of the other arguments may be present.
--
-- Otherwise throw an ArgError.
arg_conflicts :: ArgumentDescription   -- ^ Argument which doesn't tolerate the other arguments
              -> [ArgumentDescription] -- ^ Arguments which aren't tolerated by the specified argument
              -> Arguments             -- ^ Command line parse result.
              -> IO ()
arg_conflicts desc descs args@(Arguments (argl,usageinfo)) =
   when (arg_occurs args desc && occuring descs args > 1) $
      throw (ArgError ("When " ++ argname desc ++ " is present, none of the following arguments may be present.\n"
                       ++ concat (intersperse ", " (map argname descs)) ++ "\n")
                       usageinfo)


-- How many of the specified arguments do occur? Multiple occurences of the same argument count as one.
occuring :: [ArgumentDescription] -> Arguments -> Int
occuring descs args =
   sum (map (\desc -> if arg_times args desc == 0 then 0 else 1) descs)


{- | Whether the specified argument occurs in the command line. 
-}
arg_occurs :: Arguments                   -- ^ Command line parse result.
           -> ArgumentDescription         -- ^ Description of the respective argument.
           -> Bool                              -- ^ Whether the specified argument occurs in the command line.
arg_occurs args desc =
   occuring [desc] args == 1


-- |
-- Get the usage information from the parsed arguments. The usage info
-- contains the header specified to the corresponding @getargs...@
-- function, and descriptions of the command line arguments.
usage_info :: Arguments -> String
usage_info (Arguments (_,ui)) = ui


{-
instance Show (OptDescr a) where
   show (Option short long argdescr expl) =
       "Option short:" ++ showList short " long:" ++ show long ++ " argdescr:" ++ show argdescr ++ " expl:" ++ showList expl ""

instance Show (ArgDescr a) where
   show (NoArg _) = "NoArg"
   show (ReqArg _ _) = "ReqArg ..."
   show (OptArg _ _) = "OptArg ..."
-}


{- | @getargs@ as a pure function, instead of an IO action. This allows to make evaluated command line arguments global values. This calls @getargs@
   to parse the command line arguments. @GHC.IO.unsafePerformIO@ is used to take the result out of the IO monad.

   >unsafe_getargs header descs = GHC.IO.unsafePerformIO $ getargs header descs

   The @getargs@ action is performed on demand, when the parse result is evaluated. It may result in an 'ArgError' being thrown. In order to avoid
   this happening at unexpected times, the @main@ function should, start with the line @seq args (return ())@, where @args@ is the result of
   @unsafe_getargs@,. This will trigger any command line argument errors at the beginning of the program. (See section 6.2 of the Hakell Report for the
   definition of @seq@).

   A typical use of @unsafe_getargs@ looks like this:

>header = "..."
>descs = [ d_myflag, ... ]
>
>d_myflag = argdesc [ ... ]
>
>args = unsafe_getargs header descs
>myflag = arg_switch args d_myflag
>
>main = mainwrapper $ do
>   seq args (return ())
>   ...

  See 'getargs', 'unsafe_getargs_ordered'.
-}
unsafe_getargs :: String                        -- ^ The header used in the usage information
               -> [ArgumentDescription]   -- ^ The argument descriptions
               -> Arguments               -- ^ The parsed command line arguments
unsafe_getargs header descs = 
   GHC.IO.unsafePerformIO $ getargs header descs


{- | @getargs_ordered@ as a pure function, instead of an IO action. This is exactly like @unsafe_getargs@, but using @getargs_ordered@ instead of
   @getargs@.

   >unsafe_getargs_ordered = GHC.IO.unsafePerformIO $ getargs_ordered header descs

   See 'unsafe_getargs'.
-}
unsafe_getargs_ordered :: String                        -- ^ The header used in the usage information
                       -> [ArgumentDescription]   -- ^ The argument descriptions
                       -> Arguments               -- ^ The parsed command line arguments
unsafe_getargs_ordered header descs = 
   GHC.IO.unsafePerformIO $ getargs_ordered header descs
