{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ViewPatterns #-}

module WithCli.Flag where

import           Prelude ()
import           Prelude.Compat

import           Data.List
import           Data.Maybe
import           System.Console.GetOpt

data Flag a
  = Help
  | Version String
  | NoHelp a
  deriving ((forall a b. (a -> b) -> Flag a -> Flag b)
-> (forall a b. a -> Flag b -> Flag a) -> Functor Flag
forall a b. a -> Flag b -> Flag a
forall a b. (a -> b) -> Flag a -> Flag b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Flag b -> Flag a
$c<$ :: forall a b. a -> Flag b -> Flag a
fmap :: forall a b. (a -> b) -> Flag a -> Flag b
$cfmap :: forall a b. (a -> b) -> Flag a -> Flag b
Functor)

flagConcat :: Monoid a => [Flag a] -> Flag a
flagConcat :: forall a. Monoid a => [Flag a] -> Flag a
flagConcat = (Flag a -> Flag a -> Flag a) -> Flag a -> [Flag a] -> Flag a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Flag a -> Flag a -> Flag a
forall a. Monoid a => Flag a -> Flag a -> Flag a
flagAppend (a -> Flag a
forall a. a -> Flag a
NoHelp a
forall a. Monoid a => a
mempty)
  where
    flagAppend :: Monoid a => Flag a -> Flag a -> Flag a
    flagAppend :: forall a. Monoid a => Flag a -> Flag a -> Flag a
flagAppend Flag a
a Flag a
b = case (Flag a
a, Flag a
b) of
      (Flag a
Help, Flag a
_) -> Flag a
forall a. Flag a
Help
      (Flag a
_, Flag a
Help) -> Flag a
forall a. Flag a
Help
      (Version String
s, Flag a
_) -> String -> Flag a
forall a. String -> Flag a
Version String
s
      (Flag a
_, Version String
s) -> String -> Flag a
forall a. String -> Flag a
Version String
s
      (NoHelp a
a, NoHelp a
b) -> a -> Flag a
forall a. a -> Flag a
NoHelp (a -> a -> a
forall a. Monoid a => a -> a -> a
mappend a
a a
b)

foldFlags :: [Flag a] -> Flag [a]
foldFlags :: forall a. [Flag a] -> Flag [a]
foldFlags [Flag a]
flags = [Flag [a]] -> Flag [a]
forall a. Monoid a => [Flag a] -> Flag a
flagConcat ([Flag [a]] -> Flag [a]) -> [Flag [a]] -> Flag [a]
forall a b. (a -> b) -> a -> b
$ (Flag a -> Flag [a]) -> [Flag a] -> [Flag [a]]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> [a]) -> Flag a -> Flag [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure) [Flag a]
flags

helpOption :: OptDescr (Flag a)
helpOption :: forall a. OptDescr (Flag a)
helpOption =
  String
-> [String] -> ArgDescr (Flag a) -> String -> OptDescr (Flag a)
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'h'] [String
"help"] (Flag a -> ArgDescr (Flag a)
forall a. a -> ArgDescr a
NoArg Flag a
forall a. Flag a
Help) String
"show help and exit"

versionOption :: String -> OptDescr (Flag a)
versionOption :: forall a. String -> OptDescr (Flag a)
versionOption String
version =
  String
-> [String] -> ArgDescr (Flag a) -> String -> OptDescr (Flag a)
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'v'] [String
"version"] (Flag a -> ArgDescr (Flag a)
forall a. a -> ArgDescr a
NoArg (String -> Flag a
forall a. String -> Flag a
Version String
version)) String
"show version and exit"

usage :: String -> [(Bool, String)] -> [OptDescr ()] -> String
usage :: String -> [(Bool, String)] -> [OptDescr ()] -> String
usage String
progName [(Bool, String)]
fields [OptDescr ()]
options = String -> [OptDescr ()] -> String
forall a. String -> [OptDescr a] -> String
usageInfo String
header [OptDescr ()]
options
  where
    header :: String
    header :: String
header = [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
      String
progName String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
      String
"[OPTIONS]" String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
      [String] -> Maybe [String] -> [String]
forall a. a -> Maybe a -> a
fromMaybe [] ([(Bool, String)] -> Maybe [String]
formatFields [(Bool, String)]
fields) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
      []

    formatFields :: [(Bool, String)] -> Maybe [String]
    formatFields :: [(Bool, String)] -> Maybe [String]
formatFields [] = Maybe [String]
forall a. Maybe a
Nothing
    formatFields [(Bool, String)]
fields = [String] -> Maybe [String]
forall a. a -> Maybe a
Just ([String] -> Maybe [String]) -> [String] -> Maybe [String]
forall a b. (a -> b) -> a -> b
$
      let (((Bool, String) -> String) -> [(Bool, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Bool, String) -> String
forall a b. (a, b) -> b
snd -> [String]
nonOptional, ((Bool, String) -> String) -> [(Bool, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Bool, String) -> String
forall a b. (a, b) -> b
snd -> [String]
optional) =
            ((Bool, String) -> Bool)
-> [(Bool, String)] -> ([(Bool, String)], [(Bool, String)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Bool -> Bool
not (Bool -> Bool)
-> ((Bool, String) -> Bool) -> (Bool, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, String) -> Bool
forall a b. (a, b) -> a
fst) [(Bool, String)]
fields
      in [String]
nonOptional [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [[String] -> String
formatOptional [String]
optional]

    formatOptional :: [String] -> String
    formatOptional :: [String] -> String
formatOptional [] = String
""
    formatOptional [String
a] = String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
    formatOptional (String
a : [String]
r) = String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
formatOptional [String]
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"