module System.Console.GetOpt.Generics.Modifier (
Modifier(..),
Modifiers,
mkModifiers,
isPositionalArgumentsField,
getPositionalArgumentType,
getVersion,
applyModifiers,
applyModifiersLong,
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 System.Console.GetOpt.Generics.Modifier.Types
import WithCli.Parser
import WithCli.Normalize
import WithCli.Result
data Modifier
= AddShortOption String Char
| RenameOption String String
| RenameOptions (String -> Maybe String)
| UseForPositionalArguments String String
| AddOptionHelp String String
| AddVersionFlag String
mkModifiers :: [Modifier] -> Result Modifiers
mkModifiers = foldM inner empty
where
empty :: Modifiers
empty = Modifiers [] id Nothing [] Nothing
inner :: Modifiers -> Modifier -> Result Modifiers
inner (Modifiers shorts renaming args help version) modifier = case modifier of
(AddShortOption option short) ->
return $ Modifiers (insertWith (++) option [short] shorts) renaming args help version
(RenameOption from to) ->
let newRenaming :: String -> String
newRenaming option = if from `matches` option
then to
else option
in return $ Modifiers shorts (renaming . newRenaming) args help version
(RenameOptions newRenaming) ->
return $ Modifiers shorts (renaming `combineRenamings` newRenaming) args help version
(UseForPositionalArguments option typ) -> case args of
Nothing -> return $ Modifiers shorts renaming (Just (option, map toUpper typ)) help version
Just _ -> Errors ["UseForPositionalArguments can only be used once"]
(AddOptionHelp option helpText) ->
return $ Modifiers shorts renaming args (insert option helpText help) version
(AddVersionFlag v) ->
return $ Modifiers shorts renaming args help (Just v)
combineRenamings :: (a -> a) -> (a -> Maybe a) -> (a -> a)
combineRenamings old new x = old (fromMaybe x (new x))
insertWith :: Eq a => (b -> b -> b) -> a -> b -> [(a, b)] -> [(a, b)]
insertWith _ key value [] = [(key, value)]
insertWith combine key value ((a, b) : r) =
if a == key
then (key, b `combine` value) : r
else (a, b) : insertWith combine key value r
insert :: Eq a => a -> b -> [(a, b)] -> [(a, b)]
insert key value [] = [(key, value)]
insert key value ((a, b) : r) =
if a == key
then (key, value) : r
else (a, b) : insert key value r
applyModifiers :: Modifiers -> Parser Unnormalized a -> Parser Unnormalized a
applyModifiers modifiers =
addShortOptions >>>
renameOptions
where
addShortOptions = modParserOptions $ map $
\ option ->
case filter (\ (needle, _) -> needle `elem` longs option) (shortOptions modifiers) of
[] -> option
(concat . map snd -> newShorts) ->
foldl' (flip addShort) option newShorts
renameOptions =
modParserOptions $ map $ modLongs $ renaming modifiers
applyModifiersLong :: Modifiers -> String -> String
applyModifiersLong modifiers long = (renaming modifiers) long
longs :: OptDescr a -> [String]
longs (Option _ ls _ _) = ls
addShort :: Char -> OptDescr a -> OptDescr a
addShort short (Option shorts longs argDescrs help) =
Option (shorts ++ [short]) longs argDescrs help
modLongs :: (String -> String) -> OptDescr a -> OptDescr a
modLongs f (Option shorts longs descrs help) =
Option shorts (map f longs) descrs help