{-# 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 (a -> Flag b -> Flag a
(a -> b) -> Flag a -> Flag b
(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
<$ :: a -> Flag b -> Flag a
$c<$ :: forall a b. a -> Flag b -> Flag a
fmap :: (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 :: [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 :: Flag a -> Flag a -> Flag a
flagAppend a :: Flag a
a b :: Flag a
b = case (Flag a
a, Flag a
b) of
      (Help, _) -> Flag a
forall a. Flag a
Help
      (_, Help) -> Flag a
forall a. Flag a
Help
      (Version s :: String
s, _) -> String -> Flag a
forall a. String -> Flag a
Version String
s
      (_, Version s :: String
s) -> String -> Flag a
forall a. String -> Flag a
Version String
s
      (NoHelp a :: a
a, NoHelp b :: 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 :: [Flag a] -> Flag [a]
foldFlags flags :: [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 :: OptDescr (Flag a)
helpOption =
  String
-> [String] -> ArgDescr (Flag a) -> String -> OptDescr (Flag a)
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option ['h'] ["help"] (Flag a -> ArgDescr (Flag a)
forall a. a -> ArgDescr a
NoArg Flag a
forall a. Flag a
Help) "show help and exit"

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

usage :: String -> [(Bool, String)] -> [OptDescr ()] -> String
usage :: String -> [(Bool, String)] -> [OptDescr ()] -> String
usage progName :: String
progName fields :: [(Bool, String)]
fields options :: [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]
:
      "[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 fields :: [(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 [] = ""
    formatOptional [a :: String
a] = "[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ "]"
    formatOptional (a :: String
a : r :: [String]
r) = "[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
formatOptional [String]
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ "]"