module General.GetOpt(
    OptDescr(..), ArgDescr(..),
    getOpt,
    fmapFmapOptDescr,
    showOptDescr,
    mergeOptDescr,
    removeOverlap,
    optionsEnum,
    optionsEnumDesc
    ) where

import qualified System.Console.GetOpt as O
import System.Console.GetOpt hiding (getOpt)
import qualified Data.HashSet as Set
import Data.Maybe
import Data.Either
import Data.List.Extra


getOpt :: [OptDescr (Either String a)] -> [String] -> ([a], [String], [String])
getOpt :: [OptDescr (Either String a)]
-> [String] -> ([a], [String], [String])
getOpt [OptDescr (Either String a)]
opts [String]
args = ([a]
flagGood, [String]
files, [String]
flagBad [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
errs)
    where ([Either String a]
flags, [String]
files, [String]
errs) = ArgOrder (Either String a)
-> [OptDescr (Either String a)]
-> [String]
-> ([Either String a], [String], [String])
forall a.
ArgOrder a -> [OptDescr a] -> [String] -> ([a], [String], [String])
O.getOpt ArgOrder (Either String a)
forall a. ArgOrder a
O.Permute [OptDescr (Either String a)]
opts [String]
args
          ([String]
flagBad, [a]
flagGood) = [Either String a] -> ([String], [a])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either String a]
flags


fmapFmapOptDescr :: (a -> b) -> OptDescr (Either String a) -> OptDescr (Either String b)
fmapFmapOptDescr :: (a -> b)
-> OptDescr (Either String a) -> OptDescr (Either String b)
fmapFmapOptDescr a -> b
f = (Either String a -> Either String b)
-> OptDescr (Either String a) -> OptDescr (Either String b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f)


showOptDescr :: [OptDescr a] -> [String]
showOptDescr :: [OptDescr a] -> [String]
showOptDescr [OptDescr a]
xs = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ if Int
nargs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
26 then [String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
args String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
28 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
nargs) Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
desc]
                     else [String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
args, Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
30 Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
desc]
    | Option String
s [String]
l ArgDescr a
arg String
desc <- [OptDescr a]
xs
    , let args :: String
args = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Char -> String) -> String -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ArgDescr a -> Char -> String
forall a. ArgDescr a -> Char -> String
short ArgDescr a
arg) String
s [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ArgDescr a -> String -> String
forall a. ArgDescr a -> String -> String
long ArgDescr a
arg) [String]
l
    , let nargs :: Int
nargs = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
args]
    where short :: ArgDescr a -> Char -> String
short NoArg{} Char
x = String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
x]
          short (ReqArg String -> a
_ String
b) Char
x = String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
x] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
b
          short (OptArg Maybe String -> a
_ String
b) Char
x = String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
x] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
b String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
          long :: ArgDescr a -> String -> String
long NoArg{} String
x = String
"--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x
          long (ReqArg String -> a
_ String
b) String
x = String
"--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
b
          long (OptArg Maybe String -> a
_ String
b) String
x = String
"--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"[=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
b String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"


-- | Remove flags from the first field that are present in the second
removeOverlap :: [OptDescr b] -> [OptDescr a] -> [OptDescr a]
removeOverlap :: [OptDescr b] -> [OptDescr a] -> [OptDescr a]
removeOverlap [OptDescr b]
bad = (OptDescr a -> Maybe (OptDescr a)) -> [OptDescr a] -> [OptDescr a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe OptDescr a -> Maybe (OptDescr a)
forall a. OptDescr a -> Maybe (OptDescr a)
f
    where
        short :: HashSet Char
short = String -> HashSet Char
forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList (String -> HashSet Char) -> String -> HashSet Char
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
x | Option String
x [String]
_ ArgDescr b
_ String
_ <- [OptDescr b]
bad]
        long :: HashSet String
long  = [String] -> HashSet String
forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList ([String] -> HashSet String) -> [String] -> HashSet String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String]
x | Option String
_ [String]
x ArgDescr b
_ String
_ <- [OptDescr b]
bad]
        f :: OptDescr a -> Maybe (OptDescr a)
f (Option String
a [String]
b ArgDescr a
c String
d) | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
a2 Bool -> Bool -> Bool
&& [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
b2 = Maybe (OptDescr a)
forall a. Maybe a
Nothing
                           | Bool
otherwise = OptDescr a -> Maybe (OptDescr a)
forall a. a -> Maybe a
Just (OptDescr a -> Maybe (OptDescr a))
-> OptDescr a -> Maybe (OptDescr a)
forall a b. (a -> b) -> a -> b
$ String -> [String] -> ArgDescr a -> String -> OptDescr a
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
a2 [String]
b2 ArgDescr a
c String
d
            where a2 :: String
a2 = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> HashSet Char -> Bool) -> HashSet Char -> Char -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Char -> HashSet Char -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
Set.member HashSet Char
short) String
a
                  b2 :: [String]
b2 = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> HashSet String -> Bool)
-> HashSet String -> String -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> HashSet String -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
Set.member HashSet String
long) [String]
b

mergeOptDescr :: [OptDescr (Either String a)] -> [OptDescr (Either String b)] -> [OptDescr (Either String (Either a b))]
mergeOptDescr :: [OptDescr (Either String a)]
-> [OptDescr (Either String b)]
-> [OptDescr (Either String (Either a b))]
mergeOptDescr [OptDescr (Either String a)]
xs [OptDescr (Either String b)]
ys = (OptDescr (Either String a)
 -> OptDescr (Either String (Either a b)))
-> [OptDescr (Either String a)]
-> [OptDescr (Either String (Either a b))]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> Either a b)
-> OptDescr (Either String a)
-> OptDescr (Either String (Either a b))
forall a b.
(a -> b)
-> OptDescr (Either String a) -> OptDescr (Either String b)
fmapFmapOptDescr a -> Either a b
forall a b. a -> Either a b
Left) [OptDescr (Either String a)]
xs [OptDescr (Either String (Either a b))]
-> [OptDescr (Either String (Either a b))]
-> [OptDescr (Either String (Either a b))]
forall a. [a] -> [a] -> [a]
++ (OptDescr (Either String b)
 -> OptDescr (Either String (Either a b)))
-> [OptDescr (Either String b)]
-> [OptDescr (Either String (Either a b))]
forall a b. (a -> b) -> [a] -> [b]
map ((b -> Either a b)
-> OptDescr (Either String b)
-> OptDescr (Either String (Either a b))
forall a b.
(a -> b)
-> OptDescr (Either String a) -> OptDescr (Either String b)
fmapFmapOptDescr b -> Either a b
forall a b. b -> Either a b
Right) [OptDescr (Either String b)]
ys

optionsEnum :: (Enum a, Bounded a, Show a) => [OptDescr (Either String a)]
optionsEnum :: [OptDescr (Either String a)]
optionsEnum = [(a, String)] -> [OptDescr (Either String a)]
forall a. Show a => [(a, String)] -> [OptDescr (Either String a)]
optionsEnumDesc [(a
x, String
"Flag " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
lower (a -> String
forall a. Show a => a -> String
show a
x) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".") | a
x <- [a]
forall a. (Enum a, Bounded a) => [a]
enumerate]

optionsEnumDesc :: Show a => [(a, String)] -> [OptDescr (Either String a)]
optionsEnumDesc :: [(a, String)] -> [OptDescr (Either String a)]
optionsEnumDesc [(a, String)]
xs = [String
-> [String]
-> ArgDescr (Either String a)
-> String
-> OptDescr (Either String a)
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
"" [String -> String
lower (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
x] (Either String a -> ArgDescr (Either String a)
forall a. a -> ArgDescr a
NoArg (Either String a -> ArgDescr (Either String a))
-> Either String a -> ArgDescr (Either String a)
forall a b. (a -> b) -> a -> b
$ a -> Either String a
forall a b. b -> Either a b
Right a
x) String
d | (a
x,String
d) <- [(a, String)]
xs]