From 00e953f03c72794980ef1e5bb90e3bd393d85168 Mon Sep 17 00:00:00 2001 From: Uladzimir Stsepchanka Date: Sun, 27 Jun 2021 11:20:21 +0300 Subject: [PATCH] Allow options via environment variables #118 --- src/Options/Applicative.hs | 2 + src/Options/Applicative/Builder.hs | 14 +- src/Options/Applicative/Builder/Internal.hs | 21 ++- src/Options/Applicative/Common.hs | 141 +++++++++++++++----- src/Options/Applicative/Extra.hs | 21 ++- src/Options/Applicative/Types.hs | 4 + tests/test.hs | 43 ++++++ 7 files changed, 198 insertions(+), 48 deletions(-) diff --git a/src/Options/Applicative.hs b/src/Options/Applicative.hs index 662134bb..3aad0b85 100644 --- a/src/Options/Applicative.hs +++ b/src/Options/Applicative.hs @@ -89,6 +89,7 @@ module Options.Applicative ( long, help, helpDoc, + environ, value, showDefaultWith, showDefault, @@ -171,6 +172,7 @@ module Options.Applicative ( execParser, customExecParser, execParserPure, + execParserPureEnv, -- ** Handling parser results manually getParseResult, diff --git a/src/Options/Applicative/Builder.hs b/src/Options/Applicative/Builder.hs index 917659a2..b2de0d6e 100644 --- a/src/Options/Applicative/Builder.hs +++ b/src/Options/Applicative/Builder.hs @@ -33,6 +33,7 @@ module Options.Applicative.Builder ( long, help, helpDoc, + environ, value, showDefaultWith, showDefault, @@ -165,6 +166,13 @@ short = fieldMod . name . OptShort long :: HasName f => String -> Mod f a long = fieldMod . name . OptLong +-- | Try to read value from environment variable. +-- If applied many times are tried in order with latter one taking precedence. +-- +-- /Note/: Same restrictions as for 'value' apply. +environ :: String -> Mod OptionFields a +environ var = fieldMod $ \p -> p {optEnvVars = var:optEnvVars p} + -- | Specify a default value for an option. -- -- /Note/: Because this modifier means the parser will never fail, @@ -367,11 +375,13 @@ strOption = option str -- > nameParser = option str ( long "name" <> short 'n' ) -- option :: ReadM a -> Mod OptionFields a -> Parser a -option r m = mkParser d g rdr +option r m = mkParserEnv envP d g rdr where Mod f d g = metavar "ARG" `mappend` m - fields = f (OptionFields [] mempty ExpectsArgError) + fields = f (OptionFields [] [] mempty ExpectsArgError) crdr = CReader (optCompleter fields) r + envVars = optEnvVars fields + envP = if null envVars then Nothing else Just $ EnvP envVars r rdr = OptReader (optNames fields) crdr (optNoArgError fields) -- | Modifier for 'ParserInfo'. diff --git a/src/Options/Applicative/Builder/Internal.hs b/src/Options/Applicative/Builder/Internal.hs index e5bc4b63..c201423c 100644 --- a/src/Options/Applicative/Builder/Internal.hs +++ b/src/Options/Applicative/Builder/Internal.hs @@ -17,6 +17,7 @@ module Options.Applicative.Builder.Internal ( baseProps, mkCommand, mkParser, + mkParserEnv, mkOption, mkProps, @@ -26,6 +27,7 @@ module Options.Applicative.Builder.Internal ( import Control.Applicative import Control.Monad (mplus) +import Data.Maybe (catMaybes) import Data.Semigroup hiding (Option) import Prelude @@ -34,6 +36,7 @@ import Options.Applicative.Types data OptionFields a = OptionFields { optNames :: [OptName] + , optEnvVars :: [String] , optCompleter :: Completer , optNoArgError :: String -> ParseError } @@ -162,11 +165,19 @@ mkParser :: DefaultProp a -> (OptProperties -> OptProperties) -> OptReader a -> Parser a -mkParser d@(DefaultProp def _) g rdr = - let - o = liftOpt $ mkOption d g rdr - in - maybe o (\a -> o <|> pure a) def +mkParser = mkParserEnv empty + +mkParserEnv :: Maybe (Parser a) + -> DefaultProp a + -> (OptProperties -> OptProperties) + -> OptReader a + -> Parser a +mkParserEnv envP d@(DefaultProp def _) g rdr = foldr1 (<|>) $ catMaybes psrs + where + psrs = + [ Just $ liftOpt $ mkOption d g rdr + , envP + , pure <$> def ] mkOption :: DefaultProp a -> (OptProperties -> OptProperties) diff --git a/src/Options/Applicative/Common.hs b/src/Options/Applicative/Common.hs index 46d2b730..f32dabb9 100644 --- a/src/Options/Applicative/Common.hs +++ b/src/Options/Applicative/Common.hs @@ -39,10 +39,16 @@ module Options.Applicative.Common ( ParserPrefs(..), -- * Running parsers + InvokedWith, + mkInvokedWith, runParserInfo, + runParserInfoEnv, runParserFully, + runParserFullyEnv, runParserStep, + runParserStepEnv, runParser, + runParserEnv, evalParser, -- * Low-level utilities @@ -52,11 +58,11 @@ module Options.Applicative.Common ( ) where import Control.Applicative -import Control.Monad (guard, mzero, msum, when) +import Control.Monad (guard, join, mzero, msum, when) import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.State (StateT(..), get, put, runStateT) -import Data.List (isPrefixOf) -import Data.Maybe (maybeToList, isJust, isNothing) +import Control.Monad.Trans.State (StateT(..), get, gets, modify, runStateT) +import Data.List (find, isPrefixOf) +import Data.Maybe (catMaybes, listToMaybe, maybeToList, isJust, isNothing) import Prelude import Options.Applicative.Internal @@ -80,16 +86,27 @@ isOptionPrefix _ _ = False liftOpt :: Option a -> Parser a liftOpt = OptP -optMatches :: MonadP m => Bool -> OptReader a -> OptWord -> Maybe (StateT Args m a) +data InvokedWith = InvokedWith + { _invArgs :: Args + , _invEnv :: Env + } + +mkInvokedWith :: Args -> Env -> InvokedWith +mkInvokedWith = InvokedWith + +setInvArgs :: Args -> InvokedWith -> InvokedWith +setInvArgs args inv = inv{_invArgs = args} + +optMatches :: MonadP m => Bool -> OptReader a -> OptWord -> Maybe (StateT InvokedWith m a) optMatches disambiguate opt (OptWord arg1 val) = case opt of OptReader names rdr no_arg_err -> do guard $ has_name arg1 names Just $ do - args <- get + args <- gets _invArgs let mb_args = uncons $ maybeToList val ++ args let missing_arg = missingArgP (no_arg_err $ showOption arg1) (crCompleter rdr) (arg', args') <- maybe (lift missing_arg) return mb_args - put args' + modify $ setInvArgs args' lift $ runReadM (withReadM (errorFor arg1) (crReader rdr)) arg' FlagReader names x -> do @@ -100,9 +117,9 @@ optMatches disambiguate opt (OptWord arg1 val) = case opt of -- `--foo=val` was being parsed as `--foo -val`, which is gibberish. guard $ isShortName arg1 || isNothing val Just $ do - args <- get + args <- gets _invArgs let val' = ('-' :) <$> val - put $ maybeToList val' ++ args + modify $ setInvArgs $ maybeToList val' ++ args return x _ -> Nothing where @@ -136,6 +153,7 @@ searchParser :: Monad m -> Parser a -> NondetT m (Parser a) searchParser _ (NilP _) = mzero searchParser f (OptP opt) = f opt +searchParser _ (EnvP _ _) = mzero searchParser f (MultP p1 p2) = foldr1 () [ do p1' <- searchParser f p1 return (p1' <*> p2) @@ -152,7 +170,7 @@ searchParser f (BindP p k) = msum Just aa -> searchParser f (k aa) ] searchOpt :: MonadP m => ParserPrefs -> OptWord -> Parser a - -> NondetT (StateT Args m) (Parser a) + -> NondetT (StateT InvokedWith m) (Parser a) searchOpt pprefs w = searchParser $ \opt -> do let disambiguate = prefDisambiguate pprefs && optVisibility opt > Internal @@ -161,7 +179,7 @@ searchOpt pprefs w = searchParser $ \opt -> do Nothing -> mzero searchArg :: MonadP m => ParserPrefs -> String -> Parser a - -> NondetT (StateT Args m) (Parser a) + -> NondetT (StateT InvokedWith m) (Parser a) searchArg prefs arg = searchParser $ \opt -> do when (isArg (optMain opt)) cut @@ -169,11 +187,12 @@ searchArg prefs arg = CmdReader _ _ f -> case (f arg, prefBacktrack prefs) of (Just subp, NoBacktrack) -> lift $ do - args <- get <* put [] - fmap pure . lift $ enterContext arg subp *> runParserInfo subp args <* exitContext - - (Just subp, Backtrack) -> fmap pure . lift . StateT $ \args -> - enterContext arg subp *> runParser (infoPolicy subp) CmdStart (infoParser subp) args <* exitContext + inv <- get <* modify (setInvArgs []) + fmap pure . lift $ enterContext arg subp *> runParserInfoEnv subp inv <* exitContext + (Just subp, Backtrack) -> fmap pure . lift . StateT $ \inv -> + enterContext arg subp + *> runParserEnv (infoPolicy subp) CmdStart (infoParser subp) inv + <* exitContext (Just subp, SubparserInline) -> lift $ do lift $ enterContext arg subp @@ -184,8 +203,19 @@ searchArg prefs arg = fmap pure . lift . lift $ runReadM (crReader rdr) arg _ -> mzero +-- | Lookup environment for option value +searchEnv :: MonadP m => [String] -> ReadM a -> Env -> m a +searchEnv vars rdr env = do + maybe mzero do_read $ listToMaybe $ catMaybes $ map (`lookupVar` env) vars + where + do_read (var,val) = runReadM (withReadM (error_for var) rdr) val + lookupVar var = find $ (== var) . fst + error_for var msg = "environment variable " ++ show var ++ ": " ++ msg + stepParser :: MonadP m => ParserPrefs -> ArgPolicy -> String - -> Parser a -> NondetT (StateT Args m) (Parser a) + -> Parser a -> NondetT (StateT InvokedWith m) (Parser a) +stepParser _ _ _ (EnvP vars rdr) = + lift $ pure <$> (gets _invEnv >>= lift . searchEnv vars rdr) stepParser pprefs AllPositionals arg p = searchArg pprefs arg p stepParser pprefs ForwardOptions arg p = case parseWord arg of @@ -196,33 +226,53 @@ stepParser pprefs _ arg p = case parseWord arg of Nothing -> searchArg pprefs arg p +runParser :: MonadP m => ArgPolicy -> IsCmdStart -> Parser a -> Args -> m (a,Args) +runParser policy isCmdStart p args = + fmap _invArgs <$> runParserEnv policy isCmdStart p (InvokedWith args []) + -- | Apply a 'Parser' to a command line, and return a result and leftover -- arguments. This function returns an error if any parsing error occurs, or -- if any options are missing and don't have a default value. -runParser :: MonadP m => ArgPolicy -> IsCmdStart -> Parser a -> Args -> m (a, Args) -runParser policy _ p ("--" : argt) | policy /= AllPositionals - = runParser AllPositionals CmdCont p argt -runParser policy isCmdStart p args = case args of - [] -> exitP isCmdStart policy p result +runParserEnv :: MonadP m + => ArgPolicy + -> IsCmdStart + -> Parser a + -> InvokedWith + -> m (a, InvokedWith) +runParserEnv policy _ p (InvokedWith ("--" : argt) env) + | policy /= AllPositionals + = runParserEnv AllPositionals CmdCont p (InvokedWith argt env) +runParserEnv policy isCmdStart p inv@(InvokedWith args env) = case args of + [] -> result >>= exitP isCmdStart policy p (arg : argt) -> do (mp', args') <- do_step arg argt case mp' of - Nothing -> hoistMaybe result <|> parseError arg p - Just p' -> runParser (newPolicy arg) CmdCont p' args' + Nothing -> (result >>= hoistMaybe) <|> parseError arg p + Just p' -> runParserEnv (newPolicy arg) CmdCont p' (InvokedWith args' env) where - result = - (,) <$> evalParser p <*> pure args - do_step = - runParserStep policy p - + result = do + def <- defaultValueEnv env p + pure $ flip (,) inv <$> def + do_step arg = + runParserStepEnv policy p arg env newPolicy a = case policy of NoIntersperse -> if isJust (parseWord a) then NoIntersperse else AllPositionals x -> x runParserStep :: MonadP m => ArgPolicy -> Parser a -> String -> Args -> m (Maybe (Parser a), Args) -runParserStep policy p arg args = do +runParserStep policy p arg = runParserStepEnv policy p arg [] + +runParserStepEnv :: MonadP m + => ArgPolicy + -> Parser a + -> String + -> Env + -> Args + -> m (Maybe (Parser a), Args) +runParserStepEnv policy p arg env args = do prefs <- getPrefs - flip runStateT args + fmap (fmap _invArgs) + $ flip runStateT (InvokedWith args env) $ disamb (not (prefDisambiguate prefs)) $ stepParser prefs policy arg p @@ -230,12 +280,18 @@ parseError :: MonadP m => String -> Parser x -> m a parseError arg = errorP . UnexpectedError arg . SomeParser runParserInfo :: MonadP m => ParserInfo a -> Args -> m a -runParserInfo i = runParserFully (infoPolicy i) (infoParser i) +runParserInfo i args = runParserInfoEnv i $ InvokedWith args [] + +runParserInfoEnv :: MonadP m => ParserInfo a -> InvokedWith -> m a +runParserInfoEnv i = runParserFullyEnv (infoPolicy i) (infoParser i) runParserFully :: MonadP m => ArgPolicy -> Parser a -> Args -> m a -runParserFully policy p args = do - (r, args') <- runParser policy CmdStart p args - case args' of +runParserFully policy p args = runParserFullyEnv policy p (InvokedWith args []) + +runParserFullyEnv :: MonadP m => ArgPolicy -> Parser a -> InvokedWith -> m a +runParserFullyEnv policy p inv = do + (r, inv') <- runParserEnv policy CmdStart p inv + case _invArgs inv' of [] -> return r a:_ -> parseError a (pure ()) @@ -244,10 +300,23 @@ runParserFully policy p args = do evalParser :: Parser a -> Maybe a evalParser (NilP r) = r evalParser (OptP _) = Nothing +evalParser (EnvP _ _) = Nothing evalParser (MultP p1 p2) = evalParser p1 <*> evalParser p2 evalParser (AltP p1 p2) = evalParser p1 <|> evalParser p2 evalParser (BindP p k) = evalParser p >>= evalParser . k +-- | Either value from environment or default value of a 'Parser'. +defaultValueEnv :: (MonadP m) => Env -> Parser a -> m (Maybe a) +defaultValueEnv _ (NilP r) = pure r +defaultValueEnv _ (OptP _) = pure Nothing +defaultValueEnv env (EnvP vars rdr) = Just <$> searchEnv vars rdr env +defaultValueEnv env (MultP p1 p2) = + liftA2 (<*>) (defaultValueEnv env p1) (defaultValueEnv env p2) +defaultValueEnv env (AltP p1 p2) = + liftA2 (<|>) (defaultValueEnv env p1) (defaultValueEnv env p2) +defaultValueEnv env (BindP p k) = + fmap join $ defaultValueEnv env p >>= mapM (defaultValueEnv env . k) + -- | Map a polymorphic function over all the options of a parser, and collect -- the results in a list. mapParser :: (forall x. ArgumentReachability -> Option x -> b) @@ -278,6 +347,7 @@ treeMapParser g = simplify . go False g = Leaf (f (ArgumentReachability r) opt) | otherwise = MultNode [] + go _ _ (EnvP _ _) = MultNode [] go r f (MultP p1 p2) = MultNode [go r f p1, go r' f p2] where r' = r || hasArg p1 @@ -301,6 +371,7 @@ treeMapParser g = simplify . go False g hasArg :: Parser a -> Bool hasArg (NilP _) = False hasArg (OptP p) = (isArg . optMain) p + hasArg (EnvP _ _) = False hasArg (MultP p1 p2) = hasArg p1 || hasArg p2 hasArg (AltP p1 p2) = hasArg p1 || hasArg p2 hasArg (BindP p _) = hasArg p diff --git a/src/Options/Applicative/Extra.hs b/src/Options/Applicative/Extra.hs index e8e9a752..494aa7f6 100644 --- a/src/Options/Applicative/Extra.hs +++ b/src/Options/Applicative/Extra.hs @@ -9,6 +9,7 @@ module Options.Applicative.Extra ( execParser, customExecParser, execParserPure, + execParserPureEnv, getParseResult, handleParseResult, parserFailure, @@ -133,12 +134,20 @@ getParseResult :: ParserResult a -> Maybe a getParseResult (Success a) = Just a getParseResult _ = Nothing +-- | Run 'execParserPureEnv' with empty environment +execParserPure :: ParserPrefs + -> ParserInfo a + -> [String] + -> ParserResult a +execParserPure pprefs pinfo = execParserPureEnv pprefs pinfo [] + -- | The most general way to run a program description in pure code. -execParserPure :: ParserPrefs -- ^ Global preferences for this parser - -> ParserInfo a -- ^ Description of the program to run - -> [String] -- ^ Program arguments - -> ParserResult a -execParserPure pprefs pinfo args = +execParserPureEnv :: ParserPrefs -- ^ Global preferences for this parser + -> ParserInfo a -- ^ Description of the program to run + -> [(String,String)] -- ^ Environment variables + -> [String] -- ^ Program arguments + -> ParserResult a +execParserPureEnv pprefs pinfo env args = case runP p pprefs of (Right (Right r), _) -> Success r (Right (Left c), _) -> CompletionInvoked c @@ -147,7 +156,7 @@ execParserPure pprefs pinfo args = pinfo' = pinfo { infoParser = (Left <$> bashCompletionParser pinfo pprefs) <|> (Right <$> infoParser pinfo) } - p = runParserInfo pinfo' args + p = runParserInfoEnv pinfo' $ mkInvokedWith args env -- | Generate a `ParserFailure` from a `ParseError` in a given `Context`. -- diff --git a/src/Options/Applicative/Types.hs b/src/Options/Applicative/Types.hs index ee0636b6..0ad483ef 100644 --- a/src/Options/Applicative/Types.hs +++ b/src/Options/Applicative/Types.hs @@ -30,6 +30,7 @@ module Options.Applicative.Types ( ArgPolicy(..), ArgumentReachability(..), AltNodeType(..), + Env, OptTree(..), ParserHelp(..), SomeParser(..), @@ -255,6 +256,7 @@ instance Functor OptReader where data Parser a = NilP (Maybe a) | OptP (Option a) + | EnvP [String] (ReadM a) | forall x . MultP (Parser (x -> a)) (Parser x) | AltP (Parser a) (Parser a) | forall x . BindP (Parser x) (x -> Parser a) @@ -262,6 +264,7 @@ data Parser a instance Functor Parser where fmap f (NilP x) = NilP (fmap f x) fmap f (OptP opt) = OptP (fmap f opt) + fmap f (EnvP vars rdr) = EnvP vars (fmap f rdr) fmap f (MultP p1 p2) = MultP (fmap (f.) p1) p2 fmap f (AltP p1 p2) = AltP (fmap f p1) (fmap f p2) fmap f (BindP p k) = BindP p (fmap f . k) @@ -372,6 +375,7 @@ instance Monad ParserResult where CompletionInvoked c >>= _ = CompletionInvoked c type Args = [String] +type Env = [(String,String)] -- | Policy for how to handle options within the parse data ArgPolicy diff --git a/tests/test.hs b/tests/test.hs index 3c8bf6a4..596678d7 100644 --- a/tests/test.hs +++ b/tests/test.hs @@ -37,6 +37,9 @@ import Prelude run :: ParserInfo a -> [String] -> ParserResult a run = execParserPure defaultPrefs +runWithEnv :: ParserInfo a -> [(String,String)] -> [String] -> ParserResult a +runWithEnv = execParserPureEnv defaultPrefs + assertError :: Show a => ParserResult a -> (ParserFailure ParserHelp -> Property) -> Property assertError x f = case x of @@ -956,6 +959,46 @@ prop_edit_transposition :: [Char] -> [Char] -> Char -> Char -> Property prop_edit_transposition as bs a b = a /= b ==> editDistance (as ++ [a,b] ++ bs) (as ++ [b,a] ++ bs) === 1 +prop_environ :: Property +prop_environ = once $ + let p :: Parser Int + p = option auto $ long "foo" <> environ "FOO" + i = info p idm + in assertResult (runWithEnv i [("FOO","1"), ("BAR","2")] []) (=== 1) + +prop_environ_prefer_last :: Property +prop_environ_prefer_last = once $ + let p :: Parser Int + p = option auto $ long "foo" <> environ "FOO" <> environ "BAR" + i = info p idm + in assertResult (runWithEnv i [("FOO","1"), ("BAR","2")] []) (=== 2) + +prop_environ_read_error :: Property +prop_environ_read_error = once $ + let p :: Parser Int + p = option auto $ long "foo" <> environ "FOO" + i = info p idm + result = runWithEnv i [("FOO","bar")] [] + in assertError result $ \failure -> + let (msg, _) = renderFailure failure "test" + fstLine = head $ lines msg + expected = "environment variable \"FOO\": cannot parse value `bar'" + in expected === fstLine + +prop_environ_prefer_cmd :: Property +prop_environ_prefer_cmd = once $ + let p :: Parser Int + p = option auto $ long "foo" <> environ "FOO" + i = info p idm + in assertResult (runWithEnv i [("FOO","bar")] ["--foo", "1"]) (=== 1) + +prop_environ_override_default :: Property +prop_environ_override_default = once $ + let p :: Parser Int + p = option auto $ long "foo" <> environ "FOO" <> value 2 + i = info p idm + in assertResult (runWithEnv i [("FOO","1")] []) (=== 1) + --- return []