diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,51 @@ # Changelog +## [0.15.0.0] - 2026-03-17 + +### Added + +* `filePathWithExtension` and `filePathWithExtensions` completers for + completing only files with specific extensions. +* `CompletionResult` and `CompletionFinality` types for per-result + trailing-space suppression in zsh. + +### Changed + +* **Breaking:** `Completer` now wraps `String -> IO [CompletionResult]` + instead of `String -> IO [String]`. Each result carries a + `CompletionFinality` indicating whether it is final (e.g. a file — shell + appends trailing space) or non-final (e.g. a directory — no trailing + space). The zsh completion script uses this signal instead of the `*/` + suffix heuristic. +* `withLocalYamlConfig` (via `configuredConfigFile`) now completes only + `.yaml` and `.yml` files instead of all files. +* Fixed `filePathSetting` and `directoryPathSetting` so that user-provided + builders (e.g. `completer`, `metavar`) take precedence over the built-in + defaults instead of being silently overridden. +* Fixed completion for options next to default commands with arguments. + When a default command's argument parser speculatively consumed a dashed + option (e.g. `--archive-dir`) as a positional value, sibling parsers in + the same applicative could no longer see it, suppressing their completers. + +## [0.14.1.0] - 2026-02-25 + +### Added + +* `renderSettingsNixOptionsWithGeneratedComment` +* `renderParserNixOptionsWithGeneratedComment` +* `withGeneratedComment` + +### Changed + +* The `--render-nix-options` CLI output now includes a generated file comment + +## [0.14.0.0] - 2025-12-03 + +### Changed + +* Source location package names are now cleaned up to not contain a hash. + This makes it possible to use them in golden tests. + ## [0.13.0.0] - 2025-11-18 ### Added diff --git a/opt-env-conf.cabal b/opt-env-conf.cabal --- a/opt-env-conf.cabal +++ b/opt-env-conf.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.1. +-- This file has been generated from package.yaml by hpack version 0.38.3. -- -- see: https://github.com/sol/hpack name: opt-env-conf -version: 0.13.0.0 +version: 0.15.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 diff --git a/src/OptEnvConf.hs b/src/OptEnvConf.hs --- a/src/OptEnvConf.hs +++ b/src/OptEnvConf.hs @@ -55,6 +55,8 @@ -- ** Completers filePath, + filePathWithExtension, + filePathWithExtensions, directoryPath, -- ** Prefixing parsers diff --git a/src/OptEnvConf/Completer.hs b/src/OptEnvConf/Completer.hs --- a/src/OptEnvConf/Completer.hs +++ b/src/OptEnvConf/Completer.hs @@ -3,9 +3,14 @@ module OptEnvConf.Completer ( Completer (..), mkCompleter, + CompletionFinality (..), + CompletionResult (..), + finalResult, listCompleter, listIOCompleter, filePath, + filePathWithExtension, + filePathWithExtensions, directoryPath, ) where @@ -15,17 +20,45 @@ import Path import Path.IO -newtype Completer = Completer {unCompleter :: String -> IO [String]} +-- | Whether a shell should consider a completion result to be complete. +-- +-- A final result like @file.txt@ means the user is done typing this +-- argument, so the shell should append a trailing space. +-- +-- A non-final result like @dir/@ means the user likely wants to keep +-- typing (e.g. to complete a file inside the directory), so the shell +-- should not append a trailing space. +data CompletionFinality + = -- | The completion is complete; the shell should append a trailing space. + CompletionFinal + | -- | The completion may be extended further; no trailing space. + CompletionNotFinal + deriving (Show, Eq, Ord) +data CompletionResult = CompletionResult + { completionResultValue :: !String, + completionResultFinality :: !CompletionFinality + } + deriving (Show, Eq, Ord) + +finalResult :: String -> CompletionResult +finalResult s = + CompletionResult + { completionResultValue = s, + completionResultFinality = CompletionFinal + } + +newtype Completer = Completer {unCompleter :: String -> IO [CompletionResult]} + -- Forward-compatible synonym for the 'Completer' constructor -mkCompleter :: (String -> IO [String]) -> Completer +mkCompleter :: (String -> IO [CompletionResult]) -> Completer mkCompleter = Completer listCompleter :: [String] -> Completer listCompleter ss = listIOCompleter $ pure ss listIOCompleter :: IO [String] -> Completer -listIOCompleter act = Completer $ \s -> filterPrefix s <$> act +listIOCompleter act = Completer $ \s -> filterPrefix s . map finalResult <$> act filePath :: Completer filePath = Completer $ \fp' -> do @@ -34,7 +67,7 @@ -- 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 + fmap (filterPrefix fp' . map (addPrefix prefix)) $ do let listDirForgiving d = fromMaybe ([], []) <$> forgivingAbsence (listDirRel d) (dirsFromParentListing, filesFromParentListing) <- case parseSomeDir fp of Nothing -> case fp of @@ -91,12 +124,27 @@ pure $ concat - [ filesFromPartialListing, - filesFromParentListing, - dirsFromPartialListing, - dirsFromParentListing + [ map fileResult filesFromPartialListing, + map fileResult filesFromParentListing, + map dirResult dirsFromPartialListing, + map dirResult dirsFromParentListing ] + where + addPrefix :: String -> CompletionResult -> CompletionResult + addPrefix pfx cr = cr {completionResultValue = pfx <> completionResultValue cr} +filePathWithExtension :: String -> Completer +filePathWithExtension ext = filePathWithExtensions [ext] + +filePathWithExtensions :: [String] -> Completer +filePathWithExtensions exts = Completer $ \s -> do + results <- unCompleter filePath s + pure $ filter matchesExtension results + where + matchesExtension cr + | "/" `isSuffixOf` completionResultValue cr = True + | otherwise = any (`isSuffixOf` completionResultValue cr) exts + directoryPath :: Completer directoryPath = Completer $ \fp' -> do here <- getCurrentDir @@ -104,7 +152,7 @@ -- 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 + fmap (filterPrefix fp' . map (addPrefix prefix . dirResult)) $ do let listDirForgiving d = fromMaybe ([], []) <$> forgivingAbsence (listDirRel d) dirsFromParentListing <- case parseSomeDir fp of Nothing -> case fp of @@ -146,7 +194,24 @@ [ dirsFromPartialListing, dirsFromParentListing ] + where + addPrefix :: String -> CompletionResult -> CompletionResult + addPrefix pfx cr = cr {completionResultValue = pfx <> completionResultValue cr} +fileResult :: String -> CompletionResult +fileResult s = + CompletionResult + { completionResultValue = s, + completionResultFinality = CompletionFinal + } + +dirResult :: String -> CompletionResult +dirResult s = + CompletionResult + { completionResultValue = s, + completionResultFinality = CompletionNotFinal + } + hiddenRel :: Path Rel f -> Bool hiddenRel p = case toFilePath p of ('.' : _) -> True @@ -159,5 +224,5 @@ in ("./" <> pf, rest) p -> ("", p) -filterPrefix :: String -> [String] -> [String] -filterPrefix s = filter (s `isPrefixOf`) +filterPrefix :: String -> [CompletionResult] -> [CompletionResult] +filterPrefix s = filter ((s `isPrefixOf`) . completionResultValue) diff --git a/src/OptEnvConf/Completion.hs b/src/OptEnvConf/Completion.hs --- a/src/OptEnvConf/Completion.hs +++ b/src/OptEnvConf/Completion.hs @@ -88,12 +88,19 @@ " if [[ $word[1] == \"-\" ]]; then", " local desc=(\"$parts[1] ($parts[2])\")", " compadd -d desc -- $parts[1]", + " elif [[ $parts[3] == 'N' ]]; then", + " local desc=($(print -f \"%-019s -- %s\" $parts[1] $parts[2]))", + " compadd -f -l -S '' -d desc -- $parts[1]", " else", " local desc=($(print -f \"%-019s -- %s\" $parts[1] $parts[2]))", - " compadd -l -d desc -- $parts[1]", + " compadd -f -l -d desc -- $parts[1]", " fi", " else", - " compadd -f -- $word", + " if [[ $parts[3] == 'N' ]]; then", + " compadd -f -S '' -- $parts[1]", + " else", + " compadd -f -- $parts[1]", + " fi", " fi", "done" ] @@ -116,10 +123,11 @@ " set tmpline $tmpline --completion-word $arg", " end", " for opt in (" ++ fromAbsFile progPath ++ " $tmpline)", - " if test -d $opt", - " echo -E \"$opt/\"", + " set -l val (string split \\t -- $opt)[1]", + " if test -d $val", + " echo -E \"$val/\"", " else", - " echo -E \"$opt\"", + " echo -E \"$val\"", " end", " end", "end", @@ -165,12 +173,17 @@ putStr $ unlines $ map - ( \Completion {..} -> case completionDescription of - Nothing -> completionSuggestion - Just d -> completionSuggestion <> "\t" <> d + ( \Completion {..} -> + let val = completionResultValue completionSuggestion + notFinal = completionResultFinality completionSuggestion == CompletionNotFinal + in case (notFinal, completionDescription) of + (False, Nothing) -> val + (False, Just d) -> val <> "\t" <> d + (True, Nothing) -> val <> "\t\tN" + (True, Just d) -> val <> "\t" <> d <> "\tN" ) evaluatedCompletions - else putStr $ unlines $ map completionSuggestion evaluatedCompletions + else putStr $ unlines $ map (completionResultValue . completionSuggestion) evaluatedCompletions pure () -- Because the first arg has already been skipped we get input like this here: @@ -201,13 +214,13 @@ completionDescription = Nothing } -evalCompletions :: String -> [Completion Suggestion] -> IO [Completion String] +evalCompletions :: String -> [Completion Suggestion] -> IO [Completion CompletionResult] evalCompletions arg = fmap concat . mapM (evalCompletion arg) -evalCompletion :: String -> Completion Suggestion -> IO [Completion String] +evalCompletion :: String -> Completion Suggestion -> IO [Completion CompletionResult] evalCompletion arg c = do - ss <- evalSuggestion arg (completionSuggestion c) - pure $ map (\s -> c {completionSuggestion = s}) ss + rs <- evalSuggestion arg (completionSuggestion c) + pure $ map (\r -> c {completionSuggestion = r}) rs data Suggestion = SuggestionBare !String @@ -217,9 +230,9 @@ instance IsString Suggestion where fromString = SuggestionBare -evalSuggestion :: String -> Suggestion -> IO [String] +evalSuggestion :: String -> Suggestion -> IO [CompletionResult] evalSuggestion arg = \case - SuggestionBare s -> pure $ filter (arg `isPrefixOf`) [s] + SuggestionBare s -> pure $ filter ((arg `isPrefixOf`) . completionResultValue) [finalResult s] SuggestionCompleter (Completer act) -> act arg pureCompletionQuery :: Parser a -> Int -> [String] -> [Completion Suggestion] @@ -227,8 +240,10 @@ fromMaybe [] $ evalState (go parser) selectedArgs where (selectedArgs, mCursorArg) = selectArgs ix args + -- Complete within a command's parser. The command name itself is + -- already handled in the ParserCommands branch (argsAtEnd case). goCommand :: Command a -> State Args (Maybe [Completion Suggestion]) - goCommand = go . commandParser -- TODO complete with the command + goCommand = go . commandParser combineOptions = Just . concat . catMaybes tryOrRestore :: State Args (Maybe a) -> State Args (Maybe a) @@ -241,6 +256,37 @@ pure Nothing Just a -> pure (Just a) + -- Completions for many/some: try the parser repeatedly. + -- Each iteration either advances the args state (consuming input) + -- or produces end-of-input suggestions. We keep completions from + -- the iteration that is at the cursor position (the last one that + -- advanced state, or the first if none advance). + manyCompletions :: Parser x -> State Args (Maybe [Completion Suggestion]) + manyCompletions p = do + before <- get + mR <- go p + case mR of + Nothing -> pure Nothing + Just os -> do + after <- get + if after == before + then -- State did not advance; return these completions. + pure $ Just os + else -- State advanced: something was consumed. Try the + -- next iteration. Its completions supersede ours + -- only if it also has a valid result. + do + mMore <- manyCompletions p + case mMore of + Nothing -> pure $ Just os + Just more + -- If the next iteration only produced stale + -- dashed suggestions (state didn't advance + -- further), prefer our completions which came + -- from the advancing iteration. + | null os -> pure $ Just more + | otherwise -> pure $ Just os + orCompletions :: Parser x -> Parser y -> State Args (Maybe [Completion Suggestion]) orCompletions p1 p2 = do p1s <- tryOrRestore $ go p1 @@ -273,48 +319,73 @@ ParserAlt p1 p2 -> orCompletions p1 p2 ParserSelect p1 p2 -> andCompletions p1 p2 ParserEmpty _ -> pure Nothing - ParserMany _ p -> do - mR <- go p - case mR of - Nothing -> pure Nothing - Just os -> fmap (os ++) <$> go p - ParserSome _ p -> do - mR <- go p - case mR of - Nothing -> pure Nothing - Just os -> fmap (os ++) <$> go p + ParserMany _ p -> manyCompletions p + ParserSome _ p -> manyCompletions 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 + ParserCommands _ mDefault cs -> do + let mDefaultCommand = do + d <- mDefault + find ((== d) . commandArg) cs 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 + -- First, try matching an explicit command name. + explicitCommandCompletions <- + 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 -- consumeArgument offered "don't consume" but there + -- are still live args remaining. This possibility is + -- invalid for commands: if we didn't consume a command + -- name then the remaining args have nowhere to go. + pure Nothing + Just arg -> + case find ((== arg) . commandArg) cs of + Just c -> do + put rest + goCommand c + Nothing -> pure Nothing + -- If there is a default command, also try completing within + -- the default command's parser, since that is what would run + -- if the user provides no command. + case mDefaultCommand of + Nothing -> pure explicitCommandCompletions + Just dc -> do + defaultCompletions <- tryOrRestore $ goCommand dc + case defaultCompletions of + Nothing -> pure explicitCommandCompletions + Just dcs + -- If no args were consumed (we were already at end), + -- combine the explicit command listing with the default + -- command's completions. + | argsAtEnd as -> pure $ combineOptions [explicitCommandCompletions, Just dcs] + | otherwise -> do + -- The default command consumed args, so its + -- completions are valid. But we must restore + -- the state: the consumed args may also be + -- intended for sibling parsers in an + -- applicative (<*>), e.g. an option like + -- --archive-dir that the default command + -- swallowed as a positional argument. + put as + pure $ Just dcs ParserSetting _ Setting {..} -> do let arg = fromMaybe "" mCursorArg let completionDescription = settingHelp @@ -346,16 +417,26 @@ 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 + let possibilities = Args.consumeArgument as + -- Try all possible consumptions of the argument. + -- If any possibility actually consumes a value, prefer + -- that over the "don't consume" fallback, because a + -- consumed value means the user already provided input. + case filter (isJust . fst) possibilities of + (_, as') : _ -> do put as' - case mConsumed of - Nothing -> completeWithCompleterAtEnd - Just _ -> pure $ Just [] + pure $ Just [] + [] -> + -- No possibility consumed a value. This is either + -- because there are no args at all (the [] case from + -- consumeArgument) or because only the consume-nothing + -- fallback matched. In both cases, offer the + -- completer if we are at the end. + case possibilities of + [] -> completeWithCompleterAtEnd + (_, as') : _ -> do + put as' + completeWithCompleterAtEnd else if isJust settingSwitchValue then do @@ -397,7 +478,10 @@ -- 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. + -- If we checked whether the env var is set or the + -- config val is present, we could return Nothing when + -- they are absent. That would let alternatives reject + -- this branch, improving completions when one branch + -- is env/conf-only and the other has args/options. + -- This would require IO or an environment parameter. pure $ Just [] diff --git a/src/OptEnvConf/Doc.hs b/src/OptEnvConf/Doc.hs --- a/src/OptEnvConf/Doc.hs +++ b/src/OptEnvConf/Doc.hs @@ -229,29 +229,29 @@ [ ["argument:"], [mMetavarChunk setDocMetavar] ] - | setDocTryArgument + | setDocTryArgument ], [ unwordsChunks [ ["switch:"], dashedChunksNE dasheds ] - | setDocTrySwitch, - dasheds <- maybeToList (NE.nonEmpty setDocDasheds) + | setDocTrySwitch, + dasheds <- maybeToList (NE.nonEmpty setDocDasheds) ], [ unwordsChunks [ ["option:"], dashedChunksNE dasheds ++ [" ", mMetavarChunk setDocMetavar] ] - | setDocTryOption, - dasheds <- maybeToList (NE.nonEmpty setDocDasheds) + | setDocTryOption, + dasheds <- maybeToList (NE.nonEmpty setDocDasheds) ], [ unwordsChunks [ ["env:"], envVarChunksNE vars ++ [" ", mMetavarChunk setDocMetavar] ] - | vars <- maybeToList setDocEnvVars + | vars <- maybeToList setDocEnvVars ], concat [ concatMap @@ -270,13 +270,13 @@ ) ) (NE.toList confs) - | confs <- maybeToList setDocConfKeys + | confs <- maybeToList setDocConfKeys ], [ defaultValueChunks dv - | dv <- maybeToList setDocDefault + | dv <- maybeToList setDocDefault ], [ exampleValuesChunks setDocExamples - | not (null setDocExamples) + | not (null setDocExamples) ] ] @@ -323,25 +323,25 @@ [ [ [".Sh ", "COMMANDS"], renderCommandDocs docs ] - | not (null commandDocs) + | not (null commandDocs) ], concat [ [ [".Sh ", "OPTIONS"], renderLongOptDocs optDocs ] - | not (nullDocs optDocs) + | not (nullDocs optDocs) ], concat [ [ [".Sh ", "ENVIRONMENT VARIABLES"], renderEnvDocs envDocs ] - | not (nullDocs envDocs) + | not (nullDocs envDocs) ], concat [ [ [".Sh ", "CONFIGURATION VALUES"], renderConfDocs confDocs ] - | not (nullDocs confDocs) + | not (nullDocs confDocs) ] ] @@ -364,25 +364,25 @@ [ [ headerChunks "All commands", renderCommandDocs docs ] - | not (null commandDocs) + | not (null commandDocs) ], concat [ [ headerChunks "Options", renderLongOptDocs optDocs ] - | not (nullDocs optDocs) + | not (nullDocs optDocs) ], concat [ [ headerChunks "Environment Variables", renderEnvDocs envDocs ] - | not (nullDocs envDocs) + | not (nullDocs envDocs) ], concat [ [ headerChunks "Configuration Values", renderConfDocs confDocs ] - | not (nullDocs confDocs) + | not (nullDocs confDocs) ] ] @@ -441,7 +441,7 @@ [ [ headerChunks "Available commands", renderCommandDocsShort docs ] - | not (null (docsToCommandDocs docs)) + | not (null (docsToCommandDocs docs)) ] ] @@ -576,7 +576,7 @@ indent $ concatMap renderSetDocWithoutHeader $ d : sds, [[]] ] - | not isTopLevel + | not isTopLevel ], goOr isTopLevel rest ] @@ -669,16 +669,16 @@ $ unwordsChunks $ concat [ [ [mMetavarChunk optDocMetavar] - | optDocTryArgument + | optDocTryArgument ], [ concat $ maybeToList $ dashedChunks optDocDasheds - | optDocTrySwitch + | optDocTrySwitch ], [ concat [ concat $ maybeToList $ dashedChunks optDocDasheds, [" ", mMetavarChunk optDocMetavar] ] - | optDocTryOption + | optDocTryOption ] ] @@ -724,7 +724,7 @@ [ maybeToList $ dashedChunks optDocDasheds, [ [ mMetavarChunk optDocMetavar ] - | optDocTryArgument + | optDocTryArgument ] ], [mHelpChunk optDocHelp] diff --git a/src/OptEnvConf/Lint.hs b/src/OptEnvConf/Lint.hs --- a/src/OptEnvConf/Lint.hs +++ b/src/OptEnvConf/Lint.hs @@ -21,7 +21,7 @@ import qualified Data.List.NonEmpty as NE import Data.Maybe import qualified Data.Text as T -import GHC.Stack (SrcLoc, prettySrcLoc) +import GHC.Stack (SrcLoc) import OptEnvConf.Args import OptEnvConf.Output import OptEnvConf.Parser @@ -228,7 +228,7 @@ ], ["This is not allowed because the parser would run infinitely."] ], - maybe [] (pure . ("Defined at: " :) . pure . fore cyan . chunk . T.pack . prettySrcLoc) lintErrorSrcLoc + maybe [] (pure . ("Defined at: " :) . pure . srcLocChunk) lintErrorSrcLoc ] lintParser :: Parser a -> Maybe (NonEmpty LintError) diff --git a/src/OptEnvConf/Main.hs b/src/OptEnvConf/Main.hs --- a/src/OptEnvConf/Main.hs +++ b/src/OptEnvConf/Main.hs @@ -142,7 +142,8 @@ hPutChunksLocaleWith tc stdout $ renderReferenceDocumentation progname docs exitSuccess RenderNixosOptions -> do - putStrLn $ T.unpack $ renderParserNixOptions p' + progname <- getProgName + putStrLn $ T.unpack $ renderParserNixOptionsWithGeneratedComment progname p' exitSuccess BashCompletionScript progPath -> do progname <- getProgName diff --git a/src/OptEnvConf/Nix.hs b/src/OptEnvConf/Nix.hs --- a/src/OptEnvConf/Nix.hs +++ b/src/OptEnvConf/Nix.hs @@ -1,8 +1,10 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module OptEnvConf.Nix where @@ -16,6 +18,26 @@ import qualified Data.Text as T import OptEnvConf.Parser import OptEnvConf.Setting + +renderSettingsNixOptionsWithGeneratedComment :: forall a. (HasParser a) => String -> Text +renderSettingsNixOptionsWithGeneratedComment progname = + withGeneratedComment progname (renderSettingsNixOptions @a) + +renderParserNixOptionsWithGeneratedComment :: String -> Parser a -> Text +renderParserNixOptionsWithGeneratedComment progname p = + withGeneratedComment progname (renderParserNixOptions p) + +withGeneratedComment :: String -> Text -> Text +withGeneratedComment progname content = + T.pack $ + unlines $ + map + ("# " <>) + [ "DO NOT EDIT THIS FILE DIRECTLY", + "This file was generated by running", + unwords [progname, "--render-nix-options"], + T.unpack content + ] renderSettingsNixOptions :: forall a. (HasParser a) => Text renderSettingsNixOptions = renderParserNixOptions (settingsParser :: Parser a) diff --git a/src/OptEnvConf/Output.hs b/src/OptEnvConf/Output.hs --- a/src/OptEnvConf/Output.hs +++ b/src/OptEnvConf/Output.hs @@ -2,6 +2,7 @@ module OptEnvConf.Output where +import Data.Char as Char import Data.List (intercalate, intersperse) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE @@ -11,7 +12,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Version -import GHC.Stack (SrcLoc, prettySrcLoc) +import GHC.Stack (SrcLoc (..), prettySrcLoc) import OptEnvConf.Args (Dashed (..)) import qualified OptEnvConf.Args as Args import OptEnvConf.Parser @@ -94,7 +95,22 @@ mSrcLocChunk = maybe "without srcLoc" srcLocChunk srcLocChunk :: SrcLoc -> Chunk -srcLocChunk = fore cyan . chunk . T.pack . prettySrcLoc +srcLocChunk = fore cyan . chunk . T.pack . prettySrcLoc . cleanSrcLoc + where + -- GHC puts the package hash in there, which may change accross compilation + -- and that messes with golden tests. + -- We try to remove the hash from the package here. + -- The srcLocPackage looks like this: + -- opt-env-conf-test-0.0.0.3-6OHAhVu967XFT6LS52oRkR-opt-env-conf-test + -- which looks like: + -- --- + -- So we take every '-'-separated part until one starts with a number. + cleanSrcLoc loc = loc {srcLocPackage = cleanPackage (srcLocPackage loc)} + cleanPackage pkg = + T.unpack $ + T.intercalate "-" $ + takeWhile (not . maybe False (Char.isDigit . fst) . T.uncons) $ + T.splitOn "-" (T.pack pkg) indent :: [[Chunk]] -> [[Chunk]] indent = map (" " :) diff --git a/src/OptEnvConf/Parser.hs b/src/OptEnvConf/Parser.hs --- a/src/OptEnvConf/Parser.hs +++ b/src/OptEnvConf/Parser.hs @@ -294,7 +294,7 @@ some = fmap NE.toList . ParserSome Nothing showParserABit :: Parser a -> String -showParserABit = ($ "") . showParserPrec 0 +showParserABit = flip (showParserPrec 0) "" showParserPrec :: Int -> Parser a -> ShowS showParserPrec = go @@ -479,11 +479,11 @@ mapIO resolveFile' $ withFrozenCallStack $ setting $ - [ reader str, - metavar "FILE_PATH", - completer filePath - ] - ++ builders + builders + ++ [ reader str, + metavar "FILE_PATH", + completer filePath + ] -- | A setting for @Path Abs dir@. -- @@ -496,11 +496,11 @@ mapIO resolveDir' $ withFrozenCallStack $ setting $ - [ reader str, - metavar "DIRECTORY_PATH", - completer directoryPath - ] - ++ builders + builders + ++ [ reader str, + metavar "DIRECTORY_PATH", + completer directoryPath + ] -- | A 'setting' with 'option', a 'reader' set to 'str', and the 'metavar' set to @STR@. -- @@ -752,7 +752,7 @@ withFrozenCallStack $ withConfig $ mapIO readFirstYamlConfigFile $ - (<>) <$> (maybeToList <$> optional configuredConfigFile) <*> parsers + ((<>) . maybeToList <$> optional configuredConfigFile) <*> parsers -- | Combine all Yaml config files that exist into a single combined config object. withCombinedYamlConfigs :: Parser [Path Abs File] -> Parser a -> Parser a @@ -763,7 +763,7 @@ withFrozenCallStack $ withConfig $ mapIO (foldM resolveYamlConfigFile Nothing) $ - (<>) <$> (maybeToList <$> optional configuredConfigFile) <*> parsers + ((<>) . maybeToList <$> optional configuredConfigFile) <*> parsers where resolveYamlConfigFile :: Maybe JSON.Object -> Path Abs File -> IO (Maybe JSON.Object) resolveYamlConfigFile acc = fmap (combineMaybeObjects acc . join) . readYamlConfigFile @@ -825,7 +825,8 @@ [ option, long "config-file", env "CONFIG_FILE", - help "Path to the configuration file" + help "Path to the configuration file", + completer (filePathWithExtensions [".yaml", ".yml"]) ] -- | Define a setting for a 'Bool' with a given default value. diff --git a/src/OptEnvConf/Setting.hs b/src/OptEnvConf/Setting.hs --- a/src/OptEnvConf/Setting.hs +++ b/src/OptEnvConf/Setting.hs @@ -152,7 +152,8 @@ suffixEnvVarSetting :: String -> EnvVarSetting -> EnvVarSetting suffixEnvVarSetting suffix e = e {envVarSettingVar = envVarSettingVar e <> suffix} -data ConfigValSetting a = forall void. +data ConfigValSetting a + = forall void. ConfigValSetting { configValSettingPath :: !(NonEmpty String), configValSettingAllowPrefix :: !Bool,