git-mediate-1.1.0: src/OptUtils.hs

{-# LANGUAGE OverloadedRecordDot, LambdaCase, FlexibleContexts #-}

module OptUtils
    ( Parser, parseEnvOptions, envSwitch, envOptional, envOption
    ) where

import           Control.Applicative ((<|>))
import           Control.Monad ((>=>), guard, unless)
import           Control.Monad.Reader
import           Control.Monad.State
import           Data.Foldable (traverse_)
import           Data.Functor.Compose (Compose(..))
import qualified Data.Map as M
import           Data.Maybe (catMaybes)
import qualified Data.Set as S
import qualified Options.Applicative as O
import           System.Environment (lookupEnv)
import           Text.Read.Compat (readMaybe)

type Parser = Compose (ReaderT EnvVarName (State EnvContent)) O.Parser

type EnvVarName = String

data EnvContent = EnvContent
    { flags :: S.Set String
    , options :: M.Map String String
    , errors :: [String]
    }

instance Semigroup EnvContent where
    EnvContent f0 o0 e0 <> EnvContent f1 o1 e1 =
        EnvContent (f0 <> f1) (o0 <> o1)
        ( e0 <> e1
            <> (("Duplicate flag: " <>) <$> S.toList (S.intersection f0 f1))
            <> (("Duplicate option: " <>) <$> M.keys (M.intersection o0 o1))
        )

instance Monoid EnvContent where
    mempty = EnvContent mempty mempty mempty

parseEnvOptions :: String -> Parser a -> IO (O.Parser a)
parseEnvOptions name (Compose parser) =
    do
        envOpts <- foldMap (parseEnv . words) <$> lookupEnv name
        let (result, remainder) = runState (runReaderT parser name) envOpts
        let errFmt = formatRemainder remainder
        result <$
            unless (null errFmt)
            (putStrLn (unlines
                (("Warning: unhandled options in " <> name <> ":") : (("  * " <>) <$> errFmt))))

formatRemainder :: EnvContent -> [String]
formatRemainder (EnvContent f o e) =
    (("Unrecognized flag --" <>) <$> S.toList f)
    <> M.foldMapWithKey (\k v -> ["Unrecognized option: --" <> k <> " " <> v]) o
    <> e

parseEnv :: [String] -> EnvContent
parseEnv [] = mempty
parseEnv (('-':'-':flag@(_:_)):rest) = parseEnvFlag flag rest
parseEnv (['-',flag]:rest) = parseEnvFlag [flag] rest
parseEnv (other:rest) = mempty{errors = ["Unknown argument: " <> other]} <> parseEnv rest

parseEnvFlag :: String -> [String] -> EnvContent
parseEnvFlag flag rest =
    case rest of
    [] -> flagRes
    ('-':_):_ -> flagRes <> parseEnv rest
    val:rest' -> mempty{options = M.singleton flag val} <> parseEnv rest'
    where
        flagRes = mempty{flags = S.singleton flag}

-- | A boolean flag which may be initialized by an environment variable.
--
-- If the flag is present in the environment,
-- the corresponding --no-<name> or --<name> flag will be available to override it.
envSwitch :: String -> Bool -> String -> Parser Bool
envSwitch name def desc =
    Compose $
    do
        otherInEnv <- gets (S.member otherMode . flags)
        modify (\x -> x{flags = S.delete otherMode x.flags})
        let flag
                | otherInEnv = defaultMode
                | otherwise = otherMode
        let curDef = def /= otherInEnv
        let actionHelp
                | curDef = "Disable"
                | otherwise = "Enable"
        extraHelp <- (guard otherInEnv >>) <$> overrideHelp otherMode
        let help = actionHelp <> " " <> desc <> extraHelp
        pure ((/= curDef) <$> O.switch (O.long flag <> O.help help))
    where
        noFlag = "no-" <> name
        (defaultMode, otherMode)
            | def = (name, noFlag)
            | otherwise = (noFlag, name)

overrideHelp :: MonadReader EnvVarName m => String -> m String
overrideHelp val = asks (\name -> " (override \"--" <> val <> "\" from " <> name <> ")")

-- | An optional value which may be initialized by an environment variable.
--
-- If the flag is present in the environment,
-- a corresponding --no-<name> flag will be available to disable it.
envOptional :: (Read a, Show a) => String -> String -> String -> (a -> String) -> Parser (Maybe a)
envOptional name valDesc help disableHelp =
    Compose $
    readOption name >>=
    \case
    Just val ->
        do
            oh <- overrideHelp (name <> " " <> show val)
            ov <- envOptionFromEnv val
            opt <- getCompose (envOption name Nothing (commonMods <> ov))
            pure $
                O.optional opt
                <|> f <$> O.switch (O.long ("no-" <> name) <> O.help (disableHelp val <> oh))
        where
            f True = Nothing
            f False = Just val
    Nothing -> pure (O.optional (O.option O.auto (O.long name <> commonMods)))
    where
        commonMods = O.metavar valDesc <> O.help help

readOption :: (Read a, MonadState EnvContent m) => String -> m (Maybe a)
readOption name =
    do
        result <- gets (M.lookup name . options >=> readMaybe)
        result <$ traverse_ (const (modify (\x -> x{options = M.delete name x.options}))) result

-- | An option with a default value which may be initialized by an environment variable.
--
-- (the default value should be specified in the provided @O.Mod@ argument)
envOption :: (Read a, Show a) => String -> Maybe Char -> O.Mod O.OptionFields a -> Parser a
envOption name shortName mods =
    Compose $
    traverse readOption ([name] <> maybe [] (pure . pure) shortName)
    >>=
    \case
    [] -> pure (O.option O.auto baseMods)
    [val] -> O.option O.auto . (baseMods <>) <$> envOptionFromEnv val
    _ ->
        O.option O.auto baseMods <$
        modify (\x -> x{errors = x.errors <> ["Both --" <> name <> " and -" <> maybe [] pure shortName <> " specified"]})
    . catMaybes
    where
        baseMods = O.long name <> foldMap O.short shortName <> mods

envOptionFromEnv :: (MonadReader EnvVarName m, Show a) => a -> m (O.Mod O.OptionFields a)
envOptionFromEnv val =
    asks (\envVar -> O.value val <> O.showDefaultWith (\x -> show x <> ", from " <> envVar))