diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,21 @@ # Changelog +## [0.9.0.0] - 2025-03-12 + +### Added + +* Completions + +## [0.8.0.1] - 2024-12-22 + +### Changed + +* Fixed that `secretTextFileOrBareSetting` would not pass the linter without + `name`. + ## [0.8.0.0] - 2024-11-05 + +### Changed * Change `withShownDefault` and `valueWithShown` to accept a function to use in place of `show` rather than a pre-rendered `String`. diff --git a/opt-env-conf.cabal b/opt-env-conf.cabal --- a/opt-env-conf.cabal +++ b/opt-env-conf.cabal @@ -1,17 +1,17 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0. +-- This file has been generated from package.yaml by hpack version 0.36.1. -- -- see: https://github.com/sol/hpack name: opt-env-conf -version: 0.8.0.0 +version: 0.9.0.0 synopsis: Settings parsing for Haskell: command-line arguments, environment variables, and configuration values. homepage: https://github.com/NorfairKing/opt-env-conf#readme bug-reports: https://github.com/NorfairKing/opt-env-conf/issues author: Tom Sydney Kerckhove maintainer: syd@cs-syd.eu -copyright: Copyright: (c) 2024 Tom Sydney Kerckhove +copyright: Copyright: (c) 2024-2025 Tom Sydney Kerckhove license: LGPL-3 license-file: LICENSE build-type: Simple @@ -27,6 +27,7 @@ OptEnvConf OptEnvConf.Args OptEnvConf.Casing + OptEnvConf.Completer OptEnvConf.Completion OptEnvConf.Doc OptEnvConf.EnvMap diff --git a/src/OptEnvConf.hs b/src/OptEnvConf.hs --- a/src/OptEnvConf.hs +++ b/src/OptEnvConf.hs @@ -32,6 +32,7 @@ value, hidden, metavar, + completer, -- ** Commands commands, @@ -47,6 +48,10 @@ some, select, + -- ** Completers + filePath, + directoryPath, + -- ** Prefixing parsers subArgs, subArgs_, @@ -129,6 +134,7 @@ module OptEnvConf.Doc, module OptEnvConf.Nix, module OptEnvConf.Parser, + module OptEnvConf.Completer, module OptEnvConf.Reader, module OptEnvConf.Run, module OptEnvConf.Setting, @@ -138,6 +144,7 @@ import Control.Applicative import OptEnvConf.Casing +import OptEnvConf.Completer import OptEnvConf.Doc import OptEnvConf.Nix import OptEnvConf.Parser diff --git a/src/OptEnvConf/Args.hs b/src/OptEnvConf/Args.hs --- a/src/OptEnvConf/Args.hs +++ b/src/OptEnvConf/Args.hs @@ -12,6 +12,7 @@ consumeOption, consumeSwitch, recogniseLeftovers, + argsAtEnd, -- ** Internals Tomb (..), @@ -112,6 +113,9 @@ rebuildArgs :: Args -> [Tomb Arg] rebuildArgs Args {..} = argsBefore ++ argsAfter + +argsAtEnd :: Args -> Bool +argsAtEnd = all (== Dead) . argsAfter -- | Create 'Args' with all-live arguments and cursor at the start. parseArgs :: [String] -> Args diff --git a/src/OptEnvConf/Completer.hs b/src/OptEnvConf/Completer.hs new file mode 100644 --- /dev/null +++ b/src/OptEnvConf/Completer.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE LambdaCase #-} + +module OptEnvConf.Completer + ( Completer (..), + mkCompleter, + listCompleter, + listIOCompleter, + filePath, + directoryPath, + ) +where + +import Data.List +import Data.Maybe +import Path +import Path.IO +import Path.Internal.Posix (Path (..)) + +newtype Completer = Completer {unCompleter :: String -> IO [String]} + +-- Forward-compatible synonym for the 'Completer' constructor +mkCompleter :: (String -> IO [String]) -> Completer +mkCompleter = Completer + +listCompleter :: [String] -> Completer +listCompleter ss = listIOCompleter $ pure ss + +listIOCompleter :: IO [String] -> Completer +listIOCompleter act = Completer $ \s -> filterPrefix s <$> act + +filePath :: Completer +filePath = Completer $ \fp' -> do + here <- getCurrentDir + + -- An empty string is not a valid relative file or dir, but it is the most + -- common option so we special case it here + let (prefix, fp) = stripCurDir fp' + fmap (filterPrefix fp' . map (prefix <>)) $ do + let listDirForgiving d = fromMaybe ([], []) <$> forgivingAbsence (listDirRel d) + (dirsFromParentListing, filesFromParentListing) <- case parseSomeDir fp of + Nothing -> case fp of + [] -> do + -- This is not a valid rel dir but still a prefix of a valid rel dir: + -- the current dir + (ds, fs) <- listDirRel here + pure + ( map fromRelDir $ filter (not . hiddenRel) ds, + map fromRelFile $ filter (not . hiddenRel) fs + ) + _ -> pure ([], []) + Just (Abs ad) -> do + (ds, fs) <- listDirForgiving ad + pure + ( map (fromAbsDir . (ad )) $ filter (not . hiddenRel) ds, + map (fromAbsFile . (ad )) $ filter (not . hiddenRel) fs + ) + Just (Rel rd) -> do + (ds, fs) <- listDirForgiving rd + pure + ( map (fromRelDir . (rd )) $ filter (not . hiddenRel) ds, + map (fromRelFile . (rd )) $ filter (not . hiddenRel) fs + ) + + (dirsFromPartialListing, filesFromPartialListing) <- case parseSomeFile fp of + Nothing -> + -- This is not a valid rel file but still a prefix of a valid + -- (hidden) rel file. + if fp == "." + then do + (ds, fs) <- listDirRel here + pure + ( map fromRelDir ds, + map fromRelFile fs + ) + else pure ([], []) + Just (Abs af) -> do + let dir = parent af + let filterHidden = if hiddenRel (filename af) then id else filter (not . hiddenRel) + (ds, fs) <- listDirForgiving dir + pure + ( map (fromAbsDir . (dir )) $ filterHidden ds, + map (fromAbsFile . (dir )) $ filterHidden fs + ) + Just (Rel rf) -> do + let dir = parent rf + let filterHidden = if hiddenRel rf then id else filter (not . hiddenRel) + (ds, fs) <- listDirForgiving dir + pure + ( map (fromRelDir . (dir )) $ filterHidden ds, + map (fromRelFile . (dir )) $ filterHidden fs + ) + + pure $ + concat + [ filesFromPartialListing, + filesFromParentListing, + dirsFromPartialListing, + dirsFromParentListing + ] + +directoryPath :: Completer +directoryPath = Completer $ \fp' -> do + here <- getCurrentDir + + -- An empty string is not a valid relative file or dir, but it is the most + -- common option so we special case it here + let (prefix, fp) = stripCurDir fp' + fmap (filterPrefix fp' . map (prefix <>)) $ do + let listDirForgiving d = fromMaybe ([], []) <$> forgivingAbsence (listDirRel d) + dirsFromParentListing <- case parseSomeDir fp of + Nothing -> case fp of + [] -> do + -- This is not a valid rel dir but still a prefix of a valid rel dir: + -- the current dir + (ds, _) <- listDirRel here + pure (map fromRelDir $ filter (not . hiddenRel) ds) + _ -> pure [] + Just (Abs ad) -> do + (ds, _) <- listDirForgiving ad + pure (map (fromAbsDir . (ad )) $ filter (not . hiddenRel) ds) + Just (Rel rd) -> do + (ds, _) <- listDirForgiving rd + pure (map (fromRelDir . (rd )) $ filter (not . hiddenRel) ds) + + dirsFromPartialListing <- case parseSomeDir fp of + Nothing -> pure [] + Just (Abs af) -> do + let dir = parent af + let filterHidden = if hiddenRel (dirname af) then id else filter (not . hiddenRel) + (ds, _) <- listDirForgiving dir + pure (map (fromAbsDir . (dir )) $ filterHidden ds) + Just (Rel rf) -> + -- This is not a valid rel dir but still a prefix of a valid + -- (hidden) rel dir. + if fp == "." + then do + (ds, _) <- listDirRel here + pure (map fromRelDir ds) + else do + let dir = parent rf + let filterHidden = if hiddenRel rf then id else filter (not . hiddenRel) + (ds, _) <- listDirForgiving dir + pure (map (fromRelDir . (dir )) $ filterHidden ds) + + pure $ + concat + [ dirsFromPartialListing, + dirsFromParentListing + ] + +hiddenRel :: Path Rel f -> Bool +hiddenRel (Path s) = case s of + ('.' : _) -> True + _ -> False + +stripCurDir :: FilePath -> (FilePath, FilePath) +stripCurDir = \case + '.' : '/' : rest' -> + let (pf, rest) = stripCurDir rest' + in ("./" <> pf, rest) + p -> ("", p) + +filterPrefix :: String -> [String] -> [String] +filterPrefix s = filter (s `isPrefixOf`) diff --git a/src/OptEnvConf/Completion.hs b/src/OptEnvConf/Completion.hs --- a/src/OptEnvConf/Completion.hs +++ b/src/OptEnvConf/Completion.hs @@ -12,15 +12,22 @@ runCompletionQuery, pureCompletionQuery, Completion (..), + evalCompletions, + evalCompletion, + Suggestion (..), + evalSuggestion, ) where +import Control.Monad import Control.Monad.State import Data.List import qualified Data.List.NonEmpty as NE import Data.Maybe +import Data.String import OptEnvConf.Args as Args import OptEnvConf.Casing +import OptEnvConf.Completer import OptEnvConf.Parser import OptEnvConf.Setting import Path @@ -45,7 +52,6 @@ " done", "", " COMPREPLY=( $(" ++ fromAbsFile progPath ++ " \"${CMDLINE[@]}\") )", - " echo \"${COMPREPLY[@]}\" > hm.log", "}", "", "complete -o filenames -F " ++ functionName ++ " " ++ progname @@ -129,13 +135,31 @@ Parser a -> -- | Enriched Bool -> - -- Where completion is invoked (inbetween arguments) + -- | Where completion is invoked (inbetween arguments) Int -> -- Provider arguments [String] -> IO () -runCompletionQuery parser enriched index ws = do +runCompletionQuery parser enriched index' ws' = do + -- Which index and args are passed here is a bit tricky. + -- Some examples: + -- + -- progname -> (1, ["progname"]) + -- progname - -> (1, ["progname", "-"]) + -- progname - -> (1, ["progname", "-"]) + -- progname -- -> (1, ["progname", "--"]) + -- progname - -> (2, ["progname", "-"]) + -- + -- We use 'drop 1' here because we don't care about the progname anymore. + let index = pred index' + let ws = drop 1 ws' + let arg = fromMaybe "" $ listToMaybe $ drop index ws let completions = pureCompletionQuery parser index ws + evaluatedCompletions <- evalCompletions arg completions + -- You can use this for debugging inputs: + -- import System.IO + -- hPutStrLn stderr $ show (enriched, index, ws) + -- hPutStrLn stderr $ show evaluatedCompletions if enriched then putStr $ @@ -145,52 +169,109 @@ Nothing -> completionSuggestion Just d -> completionSuggestion <> "\t" <> d ) - completions - else putStr $ unlines $ map completionSuggestion completions + evaluatedCompletions + else putStr $ unlines $ map completionSuggestion evaluatedCompletions pure () +-- Because the first arg has already been skipped we get input like this here: +-- +-- progname -> (0, []) +-- progname - -> (0, ["-"]) +-- progname - -> (0, ["-"]) +-- progname -- -> (0, ["--"]) +-- progname - -> (1, ["-"]) selectArgs :: Int -> [String] -> (Args, Maybe String) -selectArgs _ix args = - let selectedArgs = args -- take ix args - in (parseArgs selectedArgs, NE.last <$> NE.nonEmpty selectedArgs) +selectArgs ix args = + ( parseArgs $ take ix args, + NE.head <$> NE.nonEmpty (drop ix args) + ) -data Completion = Completion +data Completion a = Completion { -- | Completion - completionSuggestion :: String, + completionSuggestion :: !a, -- | Description completionDescription :: !(Maybe String) } - deriving (Show, Eq) + deriving (Show, Eq, Ord) -pureCompletionQuery :: Parser a -> Int -> [String] -> [Completion] +instance (IsString str) => IsString (Completion str) where + fromString s = + Completion + { completionSuggestion = fromString s, + completionDescription = Nothing + } + +evalCompletions :: String -> [Completion Suggestion] -> IO [Completion String] +evalCompletions arg = fmap concat . mapM (evalCompletion arg) + +evalCompletion :: String -> Completion Suggestion -> IO [Completion String] +evalCompletion arg c = do + ss <- evalSuggestion arg (completionSuggestion c) + pure $ map (\s -> c {completionSuggestion = s}) ss + +data Suggestion + = SuggestionBare !String + | SuggestionCompleter !Completer + +-- For tidier tests +instance IsString Suggestion where + fromString = SuggestionBare + +evalSuggestion :: String -> Suggestion -> IO [String] +evalSuggestion arg = \case + SuggestionBare s -> pure $ filter (arg `isPrefixOf`) [s] + SuggestionCompleter (Completer act) -> act arg + +pureCompletionQuery :: Parser a -> Int -> [String] -> [Completion Suggestion] pureCompletionQuery parser ix args = - -- TODO use the index properly (?) fromMaybe [] $ evalState (go parser) selectedArgs where (selectedArgs, mCursorArg) = selectArgs ix args - goCommand :: Command a -> State Args (Maybe [Completion]) + goCommand :: Command a -> State Args (Maybe [Completion Suggestion]) goCommand = go . commandParser -- TODO complete with the command + combineOptions = Just . concat . catMaybes + + tryOrRestore :: State Args (Maybe a) -> State Args (Maybe a) + tryOrRestore func = do + before <- get + mA <- func + case mA of + Nothing -> do + put before + pure Nothing + Just a -> pure (Just a) + + orCompletions :: Parser x -> Parser y -> State Args (Maybe [Completion Suggestion]) + orCompletions p1 p2 = do + p1s <- tryOrRestore $ go p1 + p2s <- tryOrRestore $ go p2 + pure $ case (p1s, p2s) of + (Nothing, Nothing) -> Nothing + (Just cs, Nothing) -> Just cs + (Nothing, Just cs) -> Just cs + (Just cs1, Just cs2) -> Just $ cs1 ++ cs2 + + andCompletions :: Parser x -> Parser y -> State Args (Maybe [Completion Suggestion]) + andCompletions p1 p2 = do + p1s <- tryOrRestore $ go p1 + case p1s of + Nothing -> pure Nothing + Just cs1 -> do + p2s <- tryOrRestore $ go p2 + pure $ case p2s of + Nothing -> Nothing + Just cs2 -> pure $ cs1 ++ cs2 + -- Nothing means "this branch was not valid" - -- Just means "no completions" - go :: Parser a -> State Args (Maybe [Completion]) + -- Just [] means "no completions" + go :: Parser a -> State Args (Maybe [Completion Suggestion]) go = \case ParserPure _ -> pure $ Just [] - ParserAp p1 p2 -> do - c1 <- go p1 - case c1 of - Just [] -> go p2 - Just ss -> pure $ Just ss - Nothing -> pure $ Just [] - ParserAlt p1 p2 -> do - s1s <- go p1 - s2s <- go p2 - pure $ (++) <$> s1s <*> s2s - ParserSelect p1 p2 -> do - c1 <- go p1 - case c1 of - Just [] -> go p2 - Just ss -> pure $ Just ss - Nothing -> pure $ Just [] + -- Parse both and combine the result + ParserAp p1 p2 -> andCompletions p1 p2 + -- Parse either: either completions are valid + ParserAlt p1 p2 -> orCompletions p1 p2 + ParserSelect p1 p2 -> andCompletions p1 p2 ParserEmpty _ -> pure Nothing ParserMany p -> do mR <- go p @@ -204,31 +285,119 @@ Just os -> fmap (os ++) <$> go p ParserAllOrNothing _ p -> go p ParserCheck _ _ _ p -> go p + ParserWithConfig _ p1 p2 -> + -- The config-file auto-completion is probably less important, we put it second. + andCompletions p2 p1 ParserCommands _ _ cs -> do - -- Don't re-use the state accross commands - Just . concat . catMaybes <$> mapM goCommand cs - ParserWithConfig _ p1 p2 -> do - c1 <- go p1 - case c1 of - Just [] -> go p2 - Just ss -> pure $ Just ss - Nothing -> pure $ Just [] - ParserSetting _ Setting {..} -> + as <- get + let possibilities = Args.consumeArgument as + fmap combineOptions $ forM possibilities $ \(mArg, rest) -> do + case mArg of + Nothing -> do + if argsAtEnd rest + then do + let arg = fromMaybe "" mCursorArg + let matchingCommands = filter ((arg `isPrefixOf`) . commandArg) cs + pure $ + Just $ + map + ( \Command {..} -> + Completion + { completionSuggestion = SuggestionBare commandArg, + completionDescription = Just commandHelp + } + ) + matchingCommands + else pure Nothing -- TODO: What does this mean? + Just arg -> + case find ((== arg) . commandArg) cs of + Just c -> do + put rest + goCommand c + Nothing -> pure Nothing -- Invalid command + ParserSetting _ Setting {..} -> do + let arg = fromMaybe "" mCursorArg + let completionDescription = settingHelp + let completeWithCompleter = pure $ Just $ maybeToList $ do + c <- settingCompleter + let completionSuggestion = SuggestionCompleter c + pure Completion {..} + let completeWithCompleterAtEnd = do + as <- get + if argsAtEnd as then completeWithCompleter else pure $ Just [] + let completeWithDasheds = do + let isLong = \case + DashedLong _ -> True + DashedShort _ -> False + let favorableDasheds = if any isLong settingDasheds then filter isLong settingDasheds else settingDasheds + let suggestions = filter (arg `isPrefixOf`) (map Args.renderDashed favorableDasheds) + let completions = + map + ( ( \completionSuggestion -> + Completion {..} + ) + . SuggestionBare + ) + suggestions + pure $ Just completions if settingHidden then pure $ Just [] else do - case mCursorArg of - Nothing -> pure $ Just [] - Just arg -> do - let suggestions = filter (arg `isPrefixOf`) (map Args.renderDashed settingDasheds) - let completions = - map - ( \completionSuggestion -> - let completionDescription = settingHelp - in Completion {..} - ) - suggestions - pure $ Just completions - --- ParserAp p1 p2 -> do --- s1s <- go p1 |> go p2 + as <- get + if settingTryArgument + then do + case Args.consumeArgument as of + [] -> completeWithCompleterAtEnd + -- TODO in theory we really need to try all possible consumptions of an argument. + -- This would complicate this function quite a bit, so we + -- just try the first option and leave it there for now. + (mConsumed, as') : _ -> do + put as' + case mConsumed of + Nothing -> completeWithCompleterAtEnd + Just _ -> pure $ Just [] + else + if isJust settingSwitchValue + then do + -- Try to parse the switch first, so we don't suggest it if + -- it's already been parsed. + case Args.consumeSwitch settingDasheds as of + Nothing -> + -- A switch can be anywhere, doesn't need to be at the end. + completeWithDasheds + Just as' -> do + put as' + pure $ Just [] + else do + if settingTryOption + then do + -- First we try to consume the option so we don't suggest it if it's already been parsed + case Args.consumeOption settingDasheds as of + Just (_, as') -> do + put as' + pure $ Just [] + Nothing -> do + if argsAtEnd as + then completeWithDasheds + else do + -- If we're not at the end, we may be between an option's + -- dashed an the option value being tab-completed In that case + -- we need to parse the dashed as normal and check if that + -- brings us to the end. + -- + -- We use 'consumeSwitch' to consume the dashed part of + -- the option because consumeOption would try to + -- consume the option argument too. + case Args.consumeSwitch settingDasheds as of + Nothing -> pure $ Just [] + Just as' -> do + put as' + completeWithCompleterAtEnd + else do + -- We can't auto-complete settings parsed from env vars + -- or config values, but this path is still valid. + -- + -- TODO consider checking if env vars or config vals + -- are parsed, then this path may still be invalid + -- afteral. + pure $ Just [] diff --git a/src/OptEnvConf/Parser.hs b/src/OptEnvConf/Parser.hs --- a/src/OptEnvConf/Parser.hs +++ b/src/OptEnvConf/Parser.hs @@ -100,6 +100,7 @@ import GHC.Stack (HasCallStack, SrcLoc, callStack, getCallStack, withFrozenCallStack) import OptEnvConf.Args (Dashed (..), prefixDashed) import OptEnvConf.Casing +import OptEnvConf.Completer import OptEnvConf.Reader import OptEnvConf.Setting import Path @@ -461,7 +462,8 @@ withFrozenCallStack $ setting $ [ reader str, - metavar "FILE_PATH" -- TODO file completer + metavar "FILE_PATH", + completer filePath ] ++ builders @@ -477,7 +479,8 @@ withFrozenCallStack $ setting $ [ reader str, - metavar "DIRECTORY_PATH" -- TODO directory completer + metavar "DIRECTORY_PATH", + completer directoryPath ] ++ builders @@ -861,7 +864,8 @@ settingExamples = [], settingHidden = True, settingMetavar = Nothing, - settingHelp = Nothing + settingHelp = Nothing, + settingCompleter = Nothing } parseDisableSwitch :: Parser Bool parseDisableSwitch = @@ -878,7 +882,8 @@ settingExamples = [], settingHidden = True, settingMetavar = Nothing, - settingHelp = Nothing + settingHelp = Nothing, + settingCompleter = Nothing } parseEnv :: Maybe (Parser Bool) @@ -898,7 +903,8 @@ settingExamples = [], settingHidden = False, settingMetavar = Just "BOOL", - settingHelp = settingHelp s + settingHelp = settingHelp s, + settingCompleter = Nothing } parseConfigVal :: Maybe (Parser Bool) parseConfigVal = do @@ -917,7 +923,8 @@ settingExamples = [], settingHidden = False, settingMetavar = Nothing, - settingHelp = settingHelp s + settingHelp = settingHelp s, + settingCompleter = Nothing } parseDummy :: Parser Bool parseDummy = @@ -934,7 +941,8 @@ settingExamples = [], settingHidden = False, settingMetavar = Nothing, - settingHelp = settingHelp s + settingHelp = settingHelp s, + settingCompleter = Nothing } prefixDashedLong :: String -> Dashed -> Maybe Dashed prefixDashedLong prefix = \case @@ -955,63 +963,79 @@ secretTextFileOrBareSetting :: (HasCallStack) => [Builder FilePath] -> Parser Text secretTextFileOrBareSetting bs = withFrozenCallStack $ - let b = mconcat $ bs ++ [reader str] - bareSetting f = T.pack <$> setting [mapMaybeBuilder f b, metavar "SECRET"] - fileSetting f = secretTextFileSetting [mapMaybeBuilder f b] - in choice - [ bareSetting $ \case - BuildTryArgument -> Nothing - BuildAddShort s -> Just $ BuildAddShort s - BuildAddLong l -> Just $ BuildAddLong l - BuildAddEnv _ -> Nothing - BuildAddConf _ -> Nothing - BuildSetDefault _ _ -> Nothing - i -> Just i, - fileSetting $ \case - BuildTryArgument -> Nothing - BuildAddShort _ -> Nothing - BuildAddLong l -> Just $ BuildAddLong (l <> NE.fromList "-file") - BuildAddEnv _ -> Nothing - BuildAddConf _ -> Nothing - BuildSetDefault _ _ -> Nothing - i -> Just i, - bareSetting $ \case - BuildTryArgument -> Nothing - BuildTryOption -> Nothing - BuildAddShort _ -> Nothing - BuildAddLong _ -> Nothing - BuildAddEnv v -> Just $ BuildAddEnv v - BuildAddConf _ -> Nothing - BuildSetDefault _ _ -> Nothing - i -> Just i, - fileSetting $ \case - BuildTryArgument -> Nothing - BuildTryOption -> Nothing - BuildAddShort _ -> Nothing - BuildAddLong _ -> Nothing - BuildAddEnv e -> Just $ BuildAddEnv $ e ++ "_FILE" - BuildAddConf _ -> Nothing - BuildSetDefault _ _ -> Nothing - i -> Just i, - bareSetting $ \case - BuildTryArgument -> Nothing - BuildTryOption -> Nothing - BuildAddShort _ -> Nothing - BuildAddLong _ -> Nothing - BuildAddEnv _ -> Nothing - BuildAddConf k -> Just $ BuildAddConf k - BuildSetDefault _ _ -> Nothing - i -> Just i, - fileSetting $ \case - BuildTryArgument -> Nothing - BuildTryOption -> Nothing - BuildAddShort _ -> Nothing - BuildAddLong _ -> Nothing - BuildAddEnv _ -> Nothing - BuildAddConf k -> Just $ BuildAddConf $ suffixConfigValSettingKey "-file" k - BuildSetDefault _ _ -> Nothing - i -> Just i - ] + choice $ + catMaybes + [ bareOption, + fileOption, + bareEnv, + fileEnv, + bareConf, + fileConf + ] + where + mLoc = snd <$> listToMaybe (getCallStack callStack) + b = mconcat $ bs ++ [reader str] + bareSetting p f = do + let s = completeBuilder $ mconcat [mapMaybeBuilder f b, reader str, metavar "SECRET"] + guard $ p s + pure $ T.pack <$> ParserSetting mLoc s + fileSetting p f = do + let s = completeBuilder $ mconcat [mapMaybeBuilder f b, reader str, metavar "FILE_PATH"] + guard $ p s + pure $ mapIO (resolveFile' >=> readSecretTextFile) $ ParserSetting mLoc s + + bareOption = bareSetting settingTryOption $ \case + BuildTryArgument -> Nothing + BuildAddShort s -> Just $ BuildAddShort s + BuildAddLong l -> Just $ BuildAddLong l + BuildAddEnv _ -> Nothing + BuildAddConf _ -> Nothing + BuildSetDefault _ _ -> Nothing + i -> Just i + fileOption = fileSetting settingTryOption $ \case + BuildTryArgument -> Nothing + BuildAddShort _ -> Nothing + BuildAddLong l -> Just $ BuildAddLong (l <> NE.fromList "-file") + BuildAddEnv _ -> Nothing + BuildAddConf _ -> Nothing + BuildSetDefault _ _ -> Nothing + i -> Just i + bareEnv = bareSetting (isJust . settingEnvVars) $ \case + BuildTryArgument -> Nothing + BuildTryOption -> Nothing + BuildAddShort _ -> Nothing + BuildAddLong _ -> Nothing + BuildAddEnv v -> Just $ BuildAddEnv v + BuildAddConf _ -> Nothing + BuildSetDefault _ _ -> Nothing + i -> Just i + fileEnv = fileSetting (isJust . settingEnvVars) $ \case + BuildTryArgument -> Nothing + BuildTryOption -> Nothing + BuildAddShort _ -> Nothing + BuildAddLong _ -> Nothing + BuildAddEnv e -> Just $ BuildAddEnv $ e ++ "_FILE" + BuildAddConf _ -> Nothing + BuildSetDefault _ _ -> Nothing + i -> Just i + bareConf = bareSetting (isJust . settingConfigVals) $ \case + BuildTryArgument -> Nothing + BuildTryOption -> Nothing + BuildAddShort _ -> Nothing + BuildAddLong _ -> Nothing + BuildAddEnv _ -> Nothing + BuildAddConf k -> Just $ BuildAddConf k + BuildSetDefault _ _ -> Nothing + i -> Just i + fileConf = fileSetting (isJust . settingConfigVals) $ \case + BuildTryArgument -> Nothing + BuildTryOption -> Nothing + BuildAddShort _ -> Nothing + BuildAddLong _ -> Nothing + BuildAddEnv _ -> Nothing + BuildAddConf k -> Just $ BuildAddConf $ suffixConfigValSettingKey "-file" k + BuildSetDefault _ _ -> Nothing + i -> Just i -- | Prefix all 'long's and 'short's with a given 'String'. {-# ANN subArgs ("NOCOVER" :: String) #-} diff --git a/src/OptEnvConf/Run.hs b/src/OptEnvConf/Run.hs --- a/src/OptEnvConf/Run.hs +++ b/src/OptEnvConf/Run.hs @@ -246,38 +246,29 @@ help "Render Nix options" ], BashCompletionScript - <$> mapIO - parseAbsFile - ( setting - [ option, - reader str, - long "bash-completion-script", - hidden, - help "Render the bash completion script" - ] - ), + <$> setting + [ option, + reader $ maybeReader parseAbsFile, + long "bash-completion-script", + hidden, + help "Render the bash completion script" + ], ZshCompletionScript - <$> mapIO - parseAbsFile - ( setting - [ option, - reader str, - long "zsh-completion-script", - hidden, - help "Render the zsh completion script" - ] - ), + <$> setting + [ option, + reader $ maybeReader parseAbsFile, + long "zsh-completion-script", + hidden, + help "Render the zsh completion script" + ], ZshCompletionScript - <$> mapIO - parseAbsFile - ( setting - [ option, - reader str, - long "fish-completion-script", - hidden, - help "Render the fish completion script" - ] - ), + <$> setting + [ option, + reader $ maybeReader parseAbsFile, + long "fish-completion-script", + hidden, + help "Render the fish completion script" + ], setting [ help "Query completion", switch CompletionQuery, diff --git a/src/OptEnvConf/Setting.hs b/src/OptEnvConf/Setting.hs --- a/src/OptEnvConf/Setting.hs +++ b/src/OptEnvConf/Setting.hs @@ -29,6 +29,7 @@ example, shownExample, hidden, + completer, Builder (..), BuildInstruction (..), @@ -53,6 +54,7 @@ import Data.Maybe import OptEnvConf.Args (Dashed (..), renderDashed) import OptEnvConf.Casing +import OptEnvConf.Completer import OptEnvConf.Reader import Text.Show @@ -89,7 +91,8 @@ settingHidden :: !Bool, -- | Which metavar should be show in documentation settingMetavar :: !(Maybe Metavar), - settingHelp :: !(Maybe String) + settingHelp :: !(Maybe String), + settingCompleter :: !(Maybe Completer) } -- An 'Ord'-able Setting without giving 'Setting' an 'Eq' instance @@ -144,7 +147,8 @@ settingHelp = Nothing, settingExamples = [], settingHidden = False, - settingDefaultValue = Nothing + settingDefaultValue = Nothing, + settingCompleter = Nothing } -- | Show a 'Setting' as much as possible, for debugging @@ -207,6 +211,7 @@ | BuildSetDefault !a !String | BuildAddExample !String | BuildSetHidden + | BuildSetCompleter !Completer applyBuildInstructions :: [BuildInstruction a] -> Setting a -> Setting a applyBuildInstructions is s = foldr applyBuildInstruction s is @@ -226,6 +231,7 @@ BuildSetDefault a shown -> s {settingDefaultValue = Just (a, shown)} BuildAddExample e -> s {settingExamples = e : settingExamples s} BuildSetHidden -> s {settingHidden = True} + BuildSetCompleter c -> s {settingCompleter = Just c} instance Semigroup (Builder f) where (<>) (Builder f1) (Builder f2) = Builder (f1 <> f2) @@ -374,3 +380,9 @@ -- Multiple 'hidden's are redundant. hidden :: Builder a hidden = Builder [BuildSetHidden] + +-- | Set the setting to tab-complete with the given completer +-- +-- Multiple 'completer's are redundant. +completer :: Completer -> Builder a +completer c = Builder [BuildSetCompleter c]