module GetOpt.Declarative.Interpret (
  ParseResult(..)
, parseCommandLineOptions
, parse
, interpretOptions
) where

import           Prelude ()
import           Test.Hspec.Core.Compat

import           System.Console.GetOpt (OptDescr, ArgOrder(..), getOpt)
import qualified System.Console.GetOpt as GetOpt

import           GetOpt.Declarative.Types
import           GetOpt.Declarative.Util (mkUsageInfo)

data InvalidArgument = InvalidArgument String String

data ParseResult config = Help String | Failure String | Success config

parseCommandLineOptions :: [(String, [Option config])] -> String -> [String] -> config -> ParseResult config
parseCommandLineOptions :: forall config.
[(String, [Option config])]
-> String -> [String] -> config -> ParseResult config
parseCommandLineOptions [(String, [Option config])]
opts String
prog [String]
args config
config = case forall config.
[OptDescr (Maybe (config -> Either InvalidArgument config))]
-> config -> [String] -> Maybe (Either String config)
parseWithHelp (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> b
snd [(String,
  [OptDescr (Maybe (config -> Either InvalidArgument config))])]
options) config
config [String]
args of
  Maybe (Either String config)
Nothing -> forall config. String -> ParseResult config
Help String
usage
  Just (Right config
c) -> forall config. config -> ParseResult config
Success config
c
  Just (Left String
err) -> forall config. String -> ParseResult config
Failure forall a b. (a -> b) -> a -> b
$ String
prog forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
err forall a. [a] -> [a] -> [a]
++ String
"\nTry `" forall a. [a] -> [a] -> [a]
++ String
prog forall a. [a] -> [a] -> [a]
++ String
" --help' for more information.\n"
  where
    options :: [(String,
  [OptDescr (Maybe (config -> Either InvalidArgument config))])]
options = forall a a1. [(a, [OptDescr a1])] -> [(a, [OptDescr (Maybe a1)])]
addHelpFlag forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall config.
[Option config]
-> [OptDescr (config -> Either InvalidArgument config)]
interpretOptions) [(String, [Option config])]
opts

    documentedOptions :: [(String,
  [OptDescr (Maybe (config -> Either InvalidArgument config))])]
documentedOptions = forall a a1. [(a, [OptDescr a1])] -> [(a, [OptDescr (Maybe a1)])]
addHelpFlag forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ forall config.
[Option config]
-> [OptDescr (config -> Either InvalidArgument config)]
interpretOptions forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter forall config. Option config -> Bool
optionDocumented) [(String, [Option config])]
opts

    usage :: String
    usage :: String
usage = String
"Usage: " forall a. [a] -> [a] -> [a]
++ String
prog forall a. [a] -> [a] -> [a]
++ String
" [OPTION]...\n\n"
      forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" (forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. String -> [OptDescr a] -> String
mkUsageInfo) [(String,
  [OptDescr (Maybe (config -> Either InvalidArgument config))])]
documentedOptions)

addHelpFlag :: [(a, [OptDescr a1])] -> [(a, [OptDescr (Maybe a1)])]
addHelpFlag :: forall a a1. [(a, [OptDescr a1])] -> [(a, [OptDescr (Maybe a1)])]
addHelpFlag [(a, [OptDescr a1])]
opts = case [(a, [OptDescr a1])]
opts of
  (a
section, [OptDescr a1]
xs) : [(a, [OptDescr a1])]
ys -> (a
section, forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
GetOpt.Option [] [String
"help"] (forall a. a -> ArgDescr a
GetOpt.NoArg forall {a}. Maybe a
help) String
"display this help and exit" forall a. a -> [a] -> [a]
: forall a. [OptDescr a] -> [OptDescr (Maybe a)]
noHelp [OptDescr a1]
xs) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [OptDescr a] -> [OptDescr (Maybe a)]
noHelp) [(a, [OptDescr a1])]
ys
  [] -> []
  where
    help :: Maybe a
help = forall {a}. Maybe a
Nothing

    noHelp :: [OptDescr a] -> [OptDescr (Maybe a)]
    noHelp :: forall a. [OptDescr a] -> [OptDescr (Maybe a)]
noHelp = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just)

parseWithHelp :: [OptDescr (Maybe (config -> Either InvalidArgument config))] -> config -> [String] -> Maybe (Either String config)
parseWithHelp :: forall config.
[OptDescr (Maybe (config -> Either InvalidArgument config))]
-> config -> [String] -> Maybe (Either String config)
parseWithHelp [OptDescr (Maybe (config -> Either InvalidArgument config))]
options config
config [String]
args = case forall a.
ArgOrder a -> [OptDescr a] -> [String] -> ([a], [String], [String])
getOpt forall a. ArgOrder a
Permute [OptDescr (Maybe (config -> Either InvalidArgument config))]
options [String]
args of
  ([Maybe (config -> Either InvalidArgument config)]
opts, [], []) | ()
_ : [()]
_ <- [() | Maybe (config -> Either InvalidArgument config)
Nothing <- [Maybe (config -> Either InvalidArgument config)]
opts] -> forall {a}. Maybe a
Nothing
  ([Maybe (config -> Either InvalidArgument config)]
opts, [String]
xs, [String]
ys) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall config.
config
-> ([config -> Either InvalidArgument config], [String], [String])
-> Either String config
interpretResult config
config (forall a. [Maybe a] -> [a]
catMaybes [Maybe (config -> Either InvalidArgument config)]
opts, [String]
xs, [String]
ys)

parse :: [OptDescr (config -> Either InvalidArgument config)] -> config -> [String] -> Either String config
parse :: forall config.
[OptDescr (config -> Either InvalidArgument config)]
-> config -> [String] -> Either String config
parse [OptDescr (config -> Either InvalidArgument config)]
options config
config = forall config.
config
-> ([config -> Either InvalidArgument config], [String], [String])
-> Either String config
interpretResult config
config forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
ArgOrder a -> [OptDescr a] -> [String] -> ([a], [String], [String])
getOpt forall a. ArgOrder a
Permute [OptDescr (config -> Either InvalidArgument config)]
options

interpretResult :: config -> ([config -> Either InvalidArgument config], [String], [String]) -> Either String config
interpretResult :: forall config.
config
-> ([config -> Either InvalidArgument config], [String], [String])
-> Either String config
interpretResult config
config = forall a. ([a], [String], [String]) -> Either String [a]
interpretGetOptResult forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall config.
config
-> [config -> Either InvalidArgument config]
-> Either String config
foldResult config
config

foldResult :: config -> [config -> Either InvalidArgument config] -> Either String config
foldResult :: forall config.
config
-> [config -> Either InvalidArgument config]
-> Either String config
foldResult config
config [config -> Either InvalidArgument config]
opts = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. InvalidArgument -> String
renderInvalidArgument) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. a -> a
id) config
config [config -> Either InvalidArgument config]
opts

renderInvalidArgument :: InvalidArgument -> String
renderInvalidArgument :: InvalidArgument -> String
renderInvalidArgument (InvalidArgument String
name String
value) = String
"invalid argument `" forall a. [a] -> [a] -> [a]
++ String
value forall a. [a] -> [a] -> [a]
++ String
"' for `--" forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
"'"

interpretGetOptResult :: ([a], [String], [String]) -> Either String [a]
interpretGetOptResult :: forall a. ([a], [String], [String]) -> Either String [a]
interpretGetOptResult ([a], [String], [String])
result = case ([a], [String], [String])
result of
  ([a]
opts, [], []) -> forall a b. b -> Either a b
Right [a]
opts
  ([a]
_, [String]
_, String
err:[String]
_) -> forall a b. a -> Either a b
Left (forall a. [a] -> [a]
init String
err)
  ([a]
_, String
arg:[String]
_, [String]
_) -> forall a b. a -> Either a b
Left (String
"unexpected argument `" forall a. [a] -> [a] -> [a]
++ String
arg forall a. [a] -> [a] -> [a]
++ String
"'")

interpretOptions :: [Option config] -> [OptDescr (config -> Either InvalidArgument config)]
interpretOptions :: forall config.
[Option config]
-> [OptDescr (config -> Either InvalidArgument config)]
interpretOptions = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall config.
Option config
-> [OptDescr (config -> Either InvalidArgument config)]
interpretOption

interpretOption :: Option config -> [OptDescr (config -> Either InvalidArgument config)]
interpretOption :: forall config.
Option config
-> [OptDescr (config -> Either InvalidArgument config)]
interpretOption (Option String
name Maybe Char
shortcut OptionSetter config
argDesc String
help Bool
_) = case OptionSetter config
argDesc of
  NoArg config -> config
setter -> [forall {a}. ArgDescr a -> OptDescr a
option forall a b. (a -> b) -> a -> b
$ forall a. a -> ArgDescr a
GetOpt.NoArg (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. config -> config
setter)]

  Flag Bool -> config -> config
setter -> [
      forall {a}. ArgDescr a -> OptDescr a
option (forall {a}. Bool -> ArgDescr (config -> Either a config)
arg Bool
True)
    , forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
GetOpt.Option [] [String
"no-" forall a. [a] -> [a] -> [a]
++ String
name] (forall {a}. Bool -> ArgDescr (config -> Either a config)
arg Bool
False) (String
"do not " forall a. [a] -> [a] -> [a]
++ String
help)
    ]
    where
      arg :: Bool -> ArgDescr (config -> Either a config)
arg Bool
v = forall a. a -> ArgDescr a
GetOpt.NoArg (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> config -> config
setter Bool
v)

  OptArg String
argName Maybe String -> config -> Maybe config
setter -> [forall {a}. ArgDescr a -> OptDescr a
option forall a b. (a -> b) -> a -> b
$ forall a. (Maybe String -> a) -> String -> ArgDescr a
GetOpt.OptArg Maybe String -> config -> Either InvalidArgument config
arg String
argName]
    where
      arg :: Maybe String -> config -> Either InvalidArgument config
arg Maybe String
mInput config
c = case Maybe String -> config -> Maybe config
setter Maybe String
mInput config
c of
        Just config
c_ -> forall a b. b -> Either a b
Right config
c_
        Maybe config
Nothing -> case Maybe String
mInput of
          Just String
input -> forall {b}. String -> Either InvalidArgument b
invalid String
input
          Maybe String
Nothing -> forall a b. b -> Either a b
Right config
c

  Arg String
argName String -> config -> Maybe config
setter -> [forall {a}. ArgDescr a -> OptDescr a
option (forall a. (String -> a) -> String -> ArgDescr a
GetOpt.ReqArg String -> config -> Either InvalidArgument config
arg String
argName)]
    where
      arg :: String -> config -> Either InvalidArgument config
arg String
input = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall {b}. String -> Either InvalidArgument b
invalid String
input) forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> config -> Maybe config
setter String
input

  where
    invalid :: String -> Either InvalidArgument b
invalid = forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> InvalidArgument
InvalidArgument String
name
    option :: ArgDescr a -> OptDescr a
option ArgDescr a
arg = forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
GetOpt.Option (forall a. Maybe a -> [a]
maybeToList Maybe Char
shortcut) [String
name] ArgDescr a
arg String
help