{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs            #-}
{-# LANGUAGE LambdaCase       #-}
{-# LANGUAGE TupleSections    #-}
{-# LANGUAGE ViewPatterns     #-}

module WithCli.Modifier (
  Modifier(..),
  Modifiers,
  mkModifiers,
  isPositionalArgumentsField,
  getPositionalArgumentType,
  getVersion,

  applyModifiers,
  applyModifiersLong,

  -- exported for testing
  insertWith,
 ) where

import           Prelude ()
import           Prelude.Compat

import           Control.Arrow
import           Control.Monad
import           Data.Char
import           Data.List (foldl')
import           Data.Maybe
import           System.Console.GetOpt

import           WithCli.Modifier.Types
import           WithCli.Normalize
import           WithCli.Parser
import           WithCli.Result

-- | 'Modifier's can be used to customize the command line parser.
data Modifier
  = AddShortOption String Char
    -- ^ @AddShortOption fieldName c@ adds the 'Char' @c@ as a short option for
    --   the field addressed by @fieldName@.
  | RenameOption String String
    -- ^ @RenameOption fieldName customName@ renames the option generated
    --   through the @fieldName@ by @customName@.
  | RenameOptions (String -> Maybe String)
    -- ^ @RenameOptions f@ renames all options with the given functions. In case
    --   the function returns @Nothing@ the original field name is used.
    --
    --   Can be used together with 'Data.List.stripPrefix'.
  | UseForPositionalArguments String String
    -- ^ @UseForPositionalArguments fieldName argumentType@ fills the field
    --   addressed by @fieldName@ with the positional arguments (i.e. arguments
    --   that don't correspond to a flag). The field has to have type
    --   @['String']@.
    --
    --   @argumentType@ is used as the type of the positional arguments in the
    --   help output.
  | AddOptionHelp String String
    -- ^ @AddOptionHelp fieldName helpText@ adds a help text for the option
    --   @fieldName@.
  | AddVersionFlag String
    -- ^ @AddVersionFlag version@ adds a @--version@ flag.

mkModifiers :: [Modifier] -> Result Modifiers
mkModifiers :: [Modifier] -> Result Modifiers
mkModifiers = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Modifiers -> Modifier -> Result Modifiers
inner Modifiers
empty
  where
    empty :: Modifiers
    empty :: Modifiers
empty = [(String, String)]
-> (String -> String)
-> Maybe (String, String)
-> [(String, String)]
-> Maybe String
-> Modifiers
Modifiers [] forall a. a -> a
id forall a. Maybe a
Nothing [] forall a. Maybe a
Nothing

    inner :: Modifiers -> Modifier -> Result Modifiers
    inner :: Modifiers -> Modifier -> Result Modifiers
inner (Modifiers [(String, String)]
shorts String -> String
renaming Maybe (String, String)
args [(String, String)]
help Maybe String
version) Modifier
modifier = case Modifier
modifier of
      (AddShortOption String
option Char
short) ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [(String, String)]
-> (String -> String)
-> Maybe (String, String)
-> [(String, String)]
-> Maybe String
-> Modifiers
Modifiers (forall a b. Eq a => (b -> b -> b) -> a -> b -> [(a, b)] -> [(a, b)]
insertWith forall a. [a] -> [a] -> [a]
(++) String
option [Char
short] [(String, String)]
shorts) String -> String
renaming Maybe (String, String)
args [(String, String)]
help Maybe String
version
      (RenameOption String
from String
to) ->
        let newRenaming :: String -> String
            newRenaming :: String -> String
newRenaming String
option = if String
from String -> String -> Bool
`matches` String
option
              then String
to
              else String
option
        in forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [(String, String)]
-> (String -> String)
-> Maybe (String, String)
-> [(String, String)]
-> Maybe String
-> Modifiers
Modifiers [(String, String)]
shorts (String -> String
renaming forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
newRenaming) Maybe (String, String)
args [(String, String)]
help Maybe String
version
      (RenameOptions String -> Maybe String
newRenaming) ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [(String, String)]
-> (String -> String)
-> Maybe (String, String)
-> [(String, String)]
-> Maybe String
-> Modifiers
Modifiers [(String, String)]
shorts (String -> String
renaming forall a. (a -> a) -> (a -> Maybe a) -> a -> a
`combineRenamings` String -> Maybe String
newRenaming) Maybe (String, String)
args [(String, String)]
help Maybe String
version
      (UseForPositionalArguments String
option String
typ) -> case Maybe (String, String)
args of
        Maybe (String, String)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [(String, String)]
-> (String -> String)
-> Maybe (String, String)
-> [(String, String)]
-> Maybe String
-> Modifiers
Modifiers [(String, String)]
shorts String -> String
renaming (forall a. a -> Maybe a
Just (String
option, forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper String
typ)) [(String, String)]
help Maybe String
version
        Just (String, String)
_ -> forall a. String -> Result a
Errors String
"UseForPositionalArguments can only be used once"
      (AddOptionHelp String
option String
helpText) ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [(String, String)]
-> (String -> String)
-> Maybe (String, String)
-> [(String, String)]
-> Maybe String
-> Modifiers
Modifiers [(String, String)]
shorts String -> String
renaming Maybe (String, String)
args (forall a b. Eq a => a -> b -> [(a, b)] -> [(a, b)]
insert String
option String
helpText [(String, String)]
help) Maybe String
version
      (AddVersionFlag String
v) ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [(String, String)]
-> (String -> String)
-> Maybe (String, String)
-> [(String, String)]
-> Maybe String
-> Modifiers
Modifiers [(String, String)]
shorts String -> String
renaming Maybe (String, String)
args [(String, String)]
help (forall a. a -> Maybe a
Just String
v)

    combineRenamings :: (a -> a) -> (a -> Maybe a) -> (a -> a)
    combineRenamings :: forall a. (a -> a) -> (a -> Maybe a) -> a -> a
combineRenamings a -> a
old a -> Maybe a
new a
x = a -> a
old (forall a. a -> Maybe a -> a
fromMaybe a
x (a -> Maybe a
new a
x))

-- * list utils to replace Data.Map

insertWith :: Eq a => (b -> b -> b) -> a -> b -> [(a, b)] -> [(a, b)]
insertWith :: forall a b. Eq a => (b -> b -> b) -> a -> b -> [(a, b)] -> [(a, b)]
insertWith b -> b -> b
_ a
key b
value [] = [(a
key, b
value)]
insertWith b -> b -> b
combine a
key b
value ((a
a, b
b) : [(a, b)]
r) =
  if a
a forall a. Eq a => a -> a -> Bool
== a
key
    then (a
key, b
b b -> b -> b
`combine` b
value) forall a. a -> [a] -> [a]
: [(a, b)]
r
    else (a
a, b
b) forall a. a -> [a] -> [a]
: forall a b. Eq a => (b -> b -> b) -> a -> b -> [(a, b)] -> [(a, b)]
insertWith b -> b -> b
combine a
key b
value [(a, b)]
r

insert :: Eq a => a -> b -> [(a, b)] -> [(a, b)]
insert :: forall a b. Eq a => a -> b -> [(a, b)] -> [(a, b)]
insert a
key b
value [] = [(a
key, b
value)]
insert a
key b
value ((a
a, b
b) : [(a, b)]
r) =
  if a
a forall a. Eq a => a -> a -> Bool
== a
key
    then (a
key, b
value) forall a. a -> [a] -> [a]
: [(a, b)]
r
    else (a
a, b
b) forall a. a -> [a] -> [a]
: forall a b. Eq a => a -> b -> [(a, b)] -> [(a, b)]
insert a
key b
value [(a, b)]
r

-- * transforming Parsers

applyModifiersLong :: Modifiers -> String -> String
applyModifiersLong :: Modifiers -> String -> String
applyModifiersLong Modifiers
modifiers String
long = (Modifiers -> String -> String
renaming Modifiers
modifiers) String
long

applyModifiers :: Modifiers -> Parser Unnormalized a -> Parser Unnormalized a
applyModifiers :: forall a.
Modifiers -> Parser Unnormalized a -> Parser Unnormalized a
applyModifiers Modifiers
modifiers =
  forall a.
(forall x. [OptDescr (Result x)] -> [OptDescr (Result x)])
-> Parser Unnormalized a -> Parser Unnormalized a
modParserOptions forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a -> b) -> a -> b
$
    forall a. OptDescr a -> OptDescr a
addShortOptions forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
    forall x. Modifiers -> OptDescr x -> OptDescr x
addOptionHelp Modifiers
modifiers forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
    forall x. Modifiers -> OptDescr x -> OptDescr x
renameOptions Modifiers
modifiers
  where
    addShortOptions :: OptDescr a -> OptDescr a
    addShortOptions :: forall a. OptDescr a -> OptDescr a
addShortOptions = \ option :: OptDescr a
option@(Option String
_ [String]
longs ArgDescr a
_ String
_) ->
      case forall a. (a -> Bool) -> [a] -> [a]
filter (\ (String
needle, String
_) -> String
needle forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
longs) (Modifiers -> [(String, String)]
shortOptions Modifiers
modifiers) of
        [] -> OptDescr a
option
        (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd -> String
newShorts) ->
          forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Char -> OptDescr a -> OptDescr a
addShort) OptDescr a
option String
newShorts

    addShort :: Char -> OptDescr a -> OptDescr a
    addShort :: forall a. Char -> OptDescr a -> OptDescr a
addShort Char
short (Option String
shorts [String]
longs ArgDescr a
argDescrs String
help) =
      forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option (String
shorts forall a. [a] -> [a] -> [a]
++ [Char
short]) [String]
longs ArgDescr a
argDescrs String
help

    renameOptions :: Modifiers -> OptDescr a -> OptDescr a
    renameOptions :: forall x. Modifiers -> OptDescr x -> OptDescr x
renameOptions Modifiers
modifiers (Option String
shorts [String]
longs ArgDescr a
descrs String
help) =
      forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
shorts (forall a b. (a -> b) -> [a] -> [b]
map (Modifiers -> String -> String
renaming Modifiers
modifiers) [String]
longs) ArgDescr a
descrs String
help

    addOptionHelp :: Modifiers -> OptDescr x -> OptDescr x
    addOptionHelp :: forall x. Modifiers -> OptDescr x -> OptDescr x
addOptionHelp Modifiers
modifiers (Option String
shorts [String]
longs ArgDescr x
argDescr String
help) =
      forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
shorts [String]
longs ArgDescr x
argDescr String
newHelp
      where
        newHelp :: String
newHelp = case forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\ String
long -> forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
long (Modifiers -> [(String, String)]
helpTexts Modifiers
modifiers)) [String]
longs of
          [] -> String
help
          String
h : [String]
_ -> String
h