-- |
-- Module    : System.Console.GetOpt.Simple
-- Copyright : Alexander Bondarenko 2012
-- License   : BSD3
--
-- Maintainer : aenor.realm@gmail.com
-- Stability : experimental
-- Portability : unknown
--
-- There's no need to invoke full 'getOpt' power in everyday use.
-- So, here it is a most common use case implemented to be as painless as possible while retaining some functionality.
-- It's divided into three layers, each built upon another. You can start at highest and peel of layers to gradually
-- unlock more 'getOpt' features.

module System.Console.GetOpt.Simple where

import System.Environment (getProgName, getArgs)
import System.Console.GetOpt (getOpt, usageInfo, ArgOrder(Permute), OptDescr(Option), ArgDescr(ReqArg, NoArg))
import System.Exit (exitSuccess, exitFailure)
import Control.Monad

import Data.Char (toUpper)
import qualified Data.Map as M

-- * Low level: using ['OptDescr'] with some helpers.

-- | A result of all those musings is a plain string-to-string dictionary.
type Options = M.Map String String

-- | An option is a string-tagged string value to be processed with "Data.Map" functions.
type Flag = (String, String)

-- ** 'ArgDescr' helpers

-- | We are using a no-processing, grab and run away 'ArgDesc'. All options' arguments are required.
type FlagMaker = String -> ArgDescr Flag

-- | Make an option with a value. Option argument value will be captured and “tagged” with an option name.
--
-- > arg "user"
arg :: FlagMaker
arg tag = ReqArg (\val -> (tag, val)) (map toUpper tag)

-- | Make a valueless option. The value captured will be an empty string.
--
-- > noArg "debug"
noArg :: FlagMaker
noArg tag = NoArg (tag, "")

-- ** A generic «usage» message which prefixes getOpt's option dump.

-- | Generate and show usage example using 'getProgName' and lists of required options and arguments.
showUsage :: [String] -> [String] -> IO ()
showUsage reqOpts reqArgs = do
    self <- getProgName
    putStrLn . unwords $  ["Usage:", self]
                       ++ ["--" ++ opt ++ " " ++ (map toUpper opt) | opt <- reqOpts]
                       ++ ["[OPTION...]"]
                       ++ reqArgs

-- ** Extract and check values.

-- | An option list which will result in a assoc list of options.
type FlagDescr = OptDescr Flag

-- | Run getOpt against option list. Show errors and usage notice if something goes wrong.
processOpts :: [FlagDescr] -> [String] -> [String] -> [String] -> IO (Options, [String])
processOpts opts reqOpts reqArgs argv = do
    case getOpt Permute opts argv of
        (o, n, [])   -> return (M.fromList o, n)
        (_, _, errs) -> do
            mapM_ putStr errs
            putStrLn ""
            showUsage reqOpts reqArgs
            putStrLn $ usageInfo "" opts
            exitFailure

-- | Extract values and validate against lists of mandatory arguments and options.
-- This adds a default '-h/--help' option.
--
-- Low level uses getOpt's facilities to prepare option list and offers maximum flexibility:
--
-- > options = [ Option ['v'] ["verbose", "debug"] (noArg "debug")   "Dump all the stuff flying."
-- >           , Option ['d'] ["date"]             (arg   "date")    "Report date."
-- >           , Option ['c'] ["conf"]             (arg   "conf")    "Configuration file."
-- >           , Option ['s'] ["section"]          (arg   "section") "Configuration section."
-- >           ]
-- >
-- > (opts, args) <- getOptsArgs options ["conf", "section"] ["command"]
getOptsArgs :: [FlagDescr] -> [String] -> [String] -> IO (Options, [String])
getOptsArgs opts reqOpts reqArgs = do
    let optDescr = Option ['h'] ["help"] (noArg "help") "Show this help." : opts

    (opts, args) <- getArgs >>= processOpts optDescr reqOpts reqArgs

    let usage msg = do
        when (not $ null msg) $ putStrLn (msg ++ "\n")
        showUsage reqOpts reqArgs
        putStrLn $ usageInfo "" optDescr

    when ("help" `M.member` opts) $ usage "" >> exitSuccess

    forM_ reqOpts $ \opt -> do
        when (opt `M.notMember` opts) $ do
            usage $ "required option missing: " ++ opt
            exitFailure

    when (length args < length reqArgs) $ do
            usage $ "required arguments missing: " ++ unwords (drop (length args) reqArgs)
            exitFailure

    return (opts, args)

-- * Intermediate: drop getOpts chains.

-- | A validation flag. Ignored when building a option list but stored for future reference.
data Mode = Required
          | Optional
          | Default String
          deriving (Eq, Show)

-- | 'Conf'iguration type used to construct Option list and, later, check for mandatory options and arguments.
type Conf = [(FlagMaker, String, Mode, String)]

-- | Process a 'Conf'iguration into a list of 'getOpt' options.
-- Required options and arguments are enforced, but defaults aren't being into a result.
--
-- > let options = makeOptions [ (noArg, "verbose", Optional,   "Dump all the stuff flying.")
-- >                           , (arg,   "date",    Required,   "Report date.")]
-- >                           , (arg,   "conf",    Required,   "Configuration file.")
-- >                           , (arg,   "section", Default "", "Configuration section.")
-- >                           ]
-- >
-- > (opts, args) <- getOptsArgs (makeOptions options) ["conf", "section"] ["command"]
makeOptions :: Conf -> [FlagDescr]
makeOptions = map (\(a, v, _, h) -> option a v h)

-- | Construct an 'Option' from a less verbose list of values.
option :: FlagMaker -> String -> String -> FlagDescr
option argCons varname help = Option [head varname] [varname] (argCons varname) help

-- * Easy-mode using 'Conf'iguration.

-- | Magic.
--
-- >>> (opts, args) <- getUsingConf options ["command"]
-- >>> print opts
-- fromList [("date", "2012-08-23"), ("conf", "/usr/local/etc/service.conf"), ("section", "")]
--
getUsingConf :: Conf -> [String] -> IO (Options, [String])
getUsingConf conf reqArgs = do
    let (options, reqOpts, defaults) = fromConf conf

    (opts, args) <- getOptsArgs options reqOpts reqArgs

    return (opts `M.union` M.fromList defaults, args)

-- | Process configuration into function arguments.
fromConf :: Conf -> ([FlagDescr], [String], [(String, String)])
fromConf conf = (makeOptions conf, getReqOpts conf, getDefaultOpts conf)
    where getReqOpts conf = [varName | (_, varName, mode, _) <- conf, mode == Required]
          getDefaultOpts conf = [(varName, defValue mode) | (_, varName, mode, _) <- conf, haveDefault mode]
          haveDefault (Default _) = True
          haveDefault _           = False
          defValue (Default val) = val