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

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

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

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

data InvalidArgument = InvalidArgument String String

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

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

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

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

addHelpFlag :: [(a, [OptDescr a1])] -> [(a, [OptDescr (Maybe a1)])]
addHelpFlag :: [(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, String
-> [String] -> ArgDescr (Maybe a1) -> String -> OptDescr (Maybe a1)
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
GetOpt.Option [] [String
"help"] (Maybe a1 -> ArgDescr (Maybe a1)
forall a. a -> ArgDescr a
GetOpt.NoArg Maybe a1
forall a. Maybe a
help) String
"display this help and exit" OptDescr (Maybe a1)
-> [OptDescr (Maybe a1)] -> [OptDescr (Maybe a1)]
forall a. a -> [a] -> [a]
: [OptDescr a1] -> [OptDescr (Maybe a1)]
forall a. [OptDescr a] -> [OptDescr (Maybe a)]
noHelp [OptDescr a1]
xs) (a, [OptDescr (Maybe a1)])
-> [(a, [OptDescr (Maybe a1)])] -> [(a, [OptDescr (Maybe a1)])]
forall a. a -> [a] -> [a]
: ((a, [OptDescr a1]) -> (a, [OptDescr (Maybe a1)]))
-> [(a, [OptDescr a1])] -> [(a, [OptDescr (Maybe a1)])]
forall a b. (a -> b) -> [a] -> [b]
map (([OptDescr a1] -> [OptDescr (Maybe a1)])
-> (a, [OptDescr a1]) -> (a, [OptDescr (Maybe a1)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [OptDescr a1] -> [OptDescr (Maybe a1)]
forall a. [OptDescr a] -> [OptDescr (Maybe a)]
noHelp) [(a, [OptDescr a1])]
ys
  [] -> []
  where
    help :: Maybe a
help = Maybe a
forall a. Maybe a
Nothing

    noHelp :: [OptDescr a] -> [OptDescr (Maybe a)]
    noHelp :: [OptDescr a] -> [OptDescr (Maybe a)]
noHelp = (OptDescr a -> OptDescr (Maybe a))
-> [OptDescr a] -> [OptDescr (Maybe a)]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> Maybe a) -> OptDescr a -> OptDescr (Maybe a)
forall a b. (a -> b) -> OptDescr a -> OptDescr b
mapOptDescr a -> Maybe a
forall a. a -> Maybe a
Just)

parseWithHelp :: [OptDescr (Maybe (config -> Either InvalidArgument config))] -> config -> [String] -> Maybe (Either String config)
parseWithHelp :: [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 ArgOrder (Maybe (config -> Either InvalidArgument config))
-> [OptDescr (Maybe (config -> Either InvalidArgument config))]
-> [String]
-> ([Maybe (config -> Either InvalidArgument config)], [String],
    [String])
forall a.
ArgOrder a -> [OptDescr a] -> [String] -> ([a], [String], [String])
getOpt ArgOrder (Maybe (config -> Either InvalidArgument config))
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] -> Maybe (Either String config)
forall a. Maybe a
Nothing
  ([Maybe (config -> Either InvalidArgument config)]
opts, [String]
xs, [String]
ys) -> Either String config -> Maybe (Either String config)
forall a. a -> Maybe a
Just (Either String config -> Maybe (Either String config))
-> Either String config -> Maybe (Either String config)
forall a b. (a -> b) -> a -> b
$ config
-> ([config -> Either InvalidArgument config], [String], [String])
-> Either String config
forall config.
config
-> ([config -> Either InvalidArgument config], [String], [String])
-> Either String config
interpretResult config
config ([Maybe (config -> Either InvalidArgument config)]
-> [config -> Either InvalidArgument 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 :: [OptDescr (config -> Either InvalidArgument config)]
-> config -> [String] -> Either String config
parse [OptDescr (config -> Either InvalidArgument config)]
options config
config = config
-> ([config -> Either InvalidArgument config], [String], [String])
-> Either String config
forall config.
config
-> ([config -> Either InvalidArgument config], [String], [String])
-> Either String config
interpretResult config
config (([config -> Either InvalidArgument config], [String], [String])
 -> Either String config)
-> ([String]
    -> ([config -> Either InvalidArgument config], [String], [String]))
-> [String]
-> Either String config
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArgOrder (config -> Either InvalidArgument config)
-> [OptDescr (config -> Either InvalidArgument config)]
-> [String]
-> ([config -> Either InvalidArgument config], [String], [String])
forall a.
ArgOrder a -> [OptDescr a] -> [String] -> ([a], [String], [String])
getOpt ArgOrder (config -> Either InvalidArgument config)
forall a. ArgOrder a
Permute [OptDescr (config -> Either InvalidArgument config)]
options

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

foldResult :: config -> [config -> Either InvalidArgument config] -> Either String config
foldResult :: config
-> [config -> Either InvalidArgument config]
-> Either String config
foldResult config
config [config -> Either InvalidArgument config]
opts = (InvalidArgument -> Either String config)
-> (config -> Either String config)
-> Either InvalidArgument config
-> Either String config
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Either String config
forall a b. a -> Either a b
Left (String -> Either String config)
-> (InvalidArgument -> String)
-> InvalidArgument
-> Either String config
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InvalidArgument -> String
renderInvalidArgument) config -> Either String config
forall (m :: * -> *) a. Monad m => a -> m a
return (Either InvalidArgument config -> Either String config)
-> Either InvalidArgument config -> Either String config
forall a b. (a -> b) -> a -> b
$ (config
 -> (config -> Either InvalidArgument config)
 -> Either InvalidArgument config)
-> config
-> [config -> Either InvalidArgument config]
-> Either InvalidArgument config
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM (((config -> Either InvalidArgument config)
 -> config -> Either InvalidArgument config)
-> config
-> (config -> Either InvalidArgument config)
-> Either InvalidArgument config
forall a b c. (a -> b -> c) -> b -> a -> c
flip (config -> Either InvalidArgument config)
-> config -> Either InvalidArgument config
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 `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
value String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' for `--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"

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

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

interpretOption :: Option config -> [OptDescr (config -> Either InvalidArgument config)]
interpretOption :: 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 -> [ArgDescr (config -> Either InvalidArgument config)
-> OptDescr (config -> Either InvalidArgument config)
forall a. ArgDescr a -> OptDescr a
option (ArgDescr (config -> Either InvalidArgument config)
 -> OptDescr (config -> Either InvalidArgument config))
-> ArgDescr (config -> Either InvalidArgument config)
-> OptDescr (config -> Either InvalidArgument config)
forall a b. (a -> b) -> a -> b
$ (config -> Either InvalidArgument config)
-> ArgDescr (config -> Either InvalidArgument config)
forall a. a -> ArgDescr a
GetOpt.NoArg (config -> Either InvalidArgument config
forall a b. b -> Either a b
Right (config -> Either InvalidArgument config)
-> (config -> config) -> config -> Either InvalidArgument config
forall b c a. (b -> c) -> (a -> b) -> a -> c
. config -> config
setter)]

  Flag Bool -> config -> config
setter -> [
      ArgDescr (config -> Either InvalidArgument config)
-> OptDescr (config -> Either InvalidArgument config)
forall a. ArgDescr a -> OptDescr a
option (Bool -> ArgDescr (config -> Either InvalidArgument config)
forall a. Bool -> ArgDescr (config -> Either a config)
arg Bool
True)
    , String
-> [String]
-> ArgDescr (config -> Either InvalidArgument config)
-> String
-> OptDescr (config -> Either InvalidArgument config)
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
GetOpt.Option [] [String
"no-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name] (Bool -> ArgDescr (config -> Either InvalidArgument config)
forall a. Bool -> ArgDescr (config -> Either a config)
arg Bool
False) (String
"do not " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
help)
    ]
    where
      arg :: Bool -> ArgDescr (config -> Either a config)
arg Bool
v = (config -> Either a config) -> ArgDescr (config -> Either a config)
forall a. a -> ArgDescr a
GetOpt.NoArg (config -> Either a config
forall a b. b -> Either a b
Right (config -> Either a config)
-> (config -> config) -> config -> Either a config
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 -> [ArgDescr (config -> Either InvalidArgument config)
-> OptDescr (config -> Either InvalidArgument config)
forall a. ArgDescr a -> OptDescr a
option (ArgDescr (config -> Either InvalidArgument config)
 -> OptDescr (config -> Either InvalidArgument config))
-> ArgDescr (config -> Either InvalidArgument config)
-> OptDescr (config -> Either InvalidArgument config)
forall a b. (a -> b) -> a -> b
$ (Maybe String -> config -> Either InvalidArgument config)
-> String -> ArgDescr (config -> Either InvalidArgument config)
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_ -> config -> Either InvalidArgument config
forall a b. b -> Either a b
Right config
c_
        Maybe config
Nothing -> case Maybe String
mInput of
          Just String
input -> String -> Either InvalidArgument config
forall b. String -> Either InvalidArgument b
invalid String
input
          Maybe String
Nothing -> config -> Either InvalidArgument config
forall a b. b -> Either a b
Right config
c

  Arg String
argName String -> config -> Maybe config
setter -> [ArgDescr (config -> Either InvalidArgument config)
-> OptDescr (config -> Either InvalidArgument config)
forall a. ArgDescr a -> OptDescr a
option ((String -> config -> Either InvalidArgument config)
-> String -> ArgDescr (config -> Either InvalidArgument config)
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 = Either InvalidArgument config
-> (config -> Either InvalidArgument config)
-> Maybe config
-> Either InvalidArgument config
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either InvalidArgument config
forall b. String -> Either InvalidArgument b
invalid String
input) config -> Either InvalidArgument config
forall a b. b -> Either a b
Right (Maybe config -> Either InvalidArgument config)
-> (config -> Maybe config)
-> config
-> Either InvalidArgument config
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> config -> Maybe config
setter String
input

  where
    invalid :: String -> Either InvalidArgument b
invalid = InvalidArgument -> Either InvalidArgument b
forall a b. a -> Either a b
Left (InvalidArgument -> Either InvalidArgument b)
-> (String -> InvalidArgument)
-> String
-> Either InvalidArgument b
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 = String -> [String] -> ArgDescr a -> String -> OptDescr a
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
GetOpt.Option (Maybe Char -> String
forall a. Maybe a -> [a]
maybeToList Maybe Char
shortcut) [String
name] ArgDescr a
arg String
help