module System.Console.GetOpt.Generics.Modifier (
Modifier(..),
Modifiers,
mkModifiers,
mkShortOptions,
mkLongOption,
hasPositionalArgumentsField,
isPositionalArgumentsField,
getHelpText,
deriveShortOptions,
mkShortModifiers,
insertWith,
) where
import Control.Applicative
import Control.Monad
import Data.Char
import Data.Maybe
import Generics.SOP
import System.Console.GetOpt.Generics.Internal
import System.Console.GetOpt.Generics.Result
data Modifier
= AddShortOption String Char
| RenameOption String String
| UseForPositionalArguments String
| AddOptionHelp String String
deriving (Show, Eq, Ord)
data Modifiers = Modifiers {
_shortOptions :: [(String, [Char])],
_renamings :: [(String, String)],
positionalArgumentsField :: Maybe String,
helpTexts :: [(String, String)]
}
deriving (Show, Eq, Ord)
mkModifiers :: [Modifier] -> Result Modifiers
mkModifiers = foldM inner (Modifiers [] [] Nothing [])
where
inner :: Modifiers -> Modifier -> Result Modifiers
inner (Modifiers shorts renamings args help) modifier = case modifier of
(AddShortOption option short) -> do
normalized <- normalizeFieldName option
return $ Modifiers
(insertWith (++) normalized [short] shorts)
renamings args help
(RenameOption from to) -> do
fromNormalized <- normalizeFieldName from
return $ Modifiers shorts (insert fromNormalized to renamings) args help
(UseForPositionalArguments option) -> do
normalized <- normalizeFieldName option
return $ Modifiers shorts renamings (Just normalized) help
(AddOptionHelp option helpText) -> do
normalized <- normalizeFieldName option
return $ Modifiers shorts renamings args (insert normalized helpText help)
mkShortOptions :: Modifiers -> String -> [Char]
mkShortOptions (Modifiers shortMap _ _ _) option =
fromMaybe [] (lookup option shortMap)
mkLongOption :: Modifiers -> String -> String
mkLongOption (Modifiers _ renamings _ _) option =
fromMaybe option (lookup option renamings)
hasPositionalArgumentsField :: Modifiers -> Bool
hasPositionalArgumentsField = isJust . positionalArgumentsField
isPositionalArgumentsField :: Modifiers -> String -> Bool
isPositionalArgumentsField modifiers field =
Just field == positionalArgumentsField modifiers
getHelpText :: Modifiers -> String -> String
getHelpText modifiers field = fromMaybe "" (lookup field (helpTexts modifiers))
deriveShortOptions :: (HasDatatypeInfo a, SingI (Code a)) =>
Proxy a -> [Modifier]
deriveShortOptions proxy =
mkShortModifiers (flags proxy)
flags :: (SingI (Code a), HasDatatypeInfo a) =>
Proxy a -> [String]
flags proxy = case datatypeInfo proxy of
ADT _ _ ci -> fromNPConstructorInfo ci
Newtype _ _ ci -> fromConstructorInfo ci
where
fromNPConstructorInfo :: NP ConstructorInfo xs -> [String]
fromNPConstructorInfo Nil = []
fromNPConstructorInfo (a :* r) =
fromConstructorInfo a ++ fromNPConstructorInfo r
fromConstructorInfo :: ConstructorInfo x -> [String]
fromConstructorInfo (Constructor _) = []
fromConstructorInfo (Infix _ _ _) = []
fromConstructorInfo (Record _ fields) =
fromFields fields
fromFields :: NP FieldInfo xs -> [String]
fromFields (FieldInfo name :* r) = name : fromFields r
fromFields Nil = []
mkShortModifiers :: [String] -> [Modifier]
mkShortModifiers fields =
let withShorts = mapMaybe (\ field -> (field, ) <$> toShort field) fields
allShorts = map snd withShorts
isUnique c = case filter (== c) allShorts of
[_] -> True
_ -> False
in (flip mapMaybe) withShorts $ \ (field, short) ->
if isUnique short
then Just (AddShortOption field short)
else Nothing
where
toShort :: String -> Maybe Char
toShort s = case dropWhile (\ c -> not (isAscii c && isAlpha c)) s of
[] -> Nothing
(a : _) -> Just (toLower a)
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