opt-env-conf 0.4.0.1 → 0.4.0.2
raw patch · 3 files changed
+242/−221 lines, 3 files
Files
- CHANGELOG.md +9/−0
- opt-env-conf.cabal +1/−1
- src/OptEnvConf/Run.hs +232/−220
CHANGELOG.md view
@@ -1,5 +1,14 @@ # Changelog +## [0.4.0.2] - 2024-07-27++### Changed++* Fixed a bug in which unrecognised arguments would be parsed exponentially.+* The special `--version` command no longer allows any other arguments.+* Fixed a bug in which some source locations still showed up even though debug mode was not on.+* Fixed that only one codec for a configuration setting was tried.+ ## [0.4.0.1] - 2024-07-26 ### Added
opt-env-conf.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: opt-env-conf-version: 0.4.0.1+version: 0.4.0.2 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
src/OptEnvConf/Run.hs view
@@ -107,86 +107,100 @@ Nothing -> do let p' = internalParser version p let docs = parserDocs p'+ mDebugMode <- if debugMode then Just <$> getTerminalCapabilitiesFromHandle stderr else pure Nothing- errOrResult <-- runParserOn- mDebugMode- p'- argMap- envVars- Nothing- case errOrResult of- Left errs -> do- tc <- getTerminalCapabilitiesFromHandle stderr- hPutChunksLocaleWith tc stderr $ renderErrors errs- exitFailure- Right i -> case i of- ShowHelp -> do- progname <- getProgName- errOrDocs <- runHelpParser mDebugMode argMap' p- case errOrDocs of- Left errs -> do- stderrTc <- getTerminalCapabilitiesFromHandle stderr- hPutChunksLocaleWith stderrTc stderr $ renderErrors errs- exitFailure- Right mCommandDoc -> do- tc <- getTerminalCapabilitiesFromHandle stdout- hPutChunksLocaleWith tc stdout $ case mCommandDoc of- Nothing -> renderHelpPage progname progDesc docs- Just (path, cDoc) -> renderCommandHelpPage progname path cDoc- exitSuccess- ShowVersion -> do- progname <- getProgName- tc <- getTerminalCapabilitiesFromHandle stdout- hPutChunksLocaleWith tc stdout $ renderVersionPage progname version- exitSuccess- RenderMan -> do- progname <- getProgName- tc <- getTerminalCapabilitiesFromHandle stdout- hPutChunksLocaleWith tc stdout $ renderManPage progname version progDesc docs- exitSuccess- RenderDocumentation -> do- progname <- getProgName- tc <- getTerminalCapabilitiesFromHandle stdout- hPutChunksLocaleWith tc stdout $ renderReferenceDocumentation progname docs- exitSuccess- RenderNixosOptions -> do- putStrLn $ T.unpack $ renderParserNixOptions p'- exitSuccess- CheckSettings -> do- let argMap'' = case consumeSwitch [DashedLong settingsCheckSwitch] argMap of- Nothing -> error "If you see this there is a bug in opt-env-conf."- Just am -> am- stderrTc <- getTerminalCapabilitiesFromHandle stderr- errOrSets <- runParserOn (Just stderrTc) p argMap'' envVars Nothing- case errOrSets of- Left errs -> do- hPutChunksLocaleWith stderrTc stderr $ renderErrors errs- exitFailure- Right _ -> do- tc <- getTerminalCapabilitiesFromHandle stdout- hPutChunksLocaleWith tc stdout ["Settings parsed successfully."]- exitSuccess- BashCompletionScript progPath -> do- progname <- getProgName- generateBashCompletionScript progPath progname- exitSuccess- ZshCompletionScript progPath -> do- progname <- getProgName- generateZshCompletionScript progPath progname- exitSuccess- FishCompletionScript progPath -> do- progname <- getProgName- generateFishCompletionScript progPath progname- exitSuccess- CompletionQuery enriched index ws -> do- runCompletionQuery p' enriched index ws- exitSuccess- ParsedNormally a -> pure a + let mHelpConsumed = consumeSwitch ["-h", "--help"] argMap+ let (helpMode, args') = case mHelpConsumed of+ Nothing -> (False, argMap)+ Just am -> (True, am)++ if helpMode+ then do+ progname <- getProgName+ errOrDocs <- runHelpParser mDebugMode args' p+ case errOrDocs of+ Left errs -> do+ stderrTc <- getTerminalCapabilitiesFromHandle stderr+ hPutChunksLocaleWith stderrTc stderr $ renderErrors errs+ exitFailure+ Right mCommandDoc -> do+ tc <- getTerminalCapabilitiesFromHandle stdout+ hPutChunksLocaleWith tc stdout $ case mCommandDoc of+ Nothing -> renderHelpPage progname progDesc docs+ Just (path, cDoc) -> renderCommandHelpPage progname path cDoc+ exitSuccess+ else do+ let mCheckConsumed = consumeSwitch ["--run-settings-check"] args'+ let (checkMode, args) = case mCheckConsumed of+ Nothing -> (False, args')+ Just am -> (True, am)++ if checkMode+ then do+ stderrTc <- getTerminalCapabilitiesFromHandle stderr+ errOrSets <- runParserOn (Just stderrTc) p args envVars Nothing+ case errOrSets of+ Left errs -> do+ hPutChunksLocaleWith stderrTc stderr $ renderErrors errs+ exitFailure+ Right _ -> do+ tc <- getTerminalCapabilitiesFromHandle stdout+ hPutChunksLocaleWith tc stdout ["Settings parsed successfully."]+ exitSuccess+ else do+ errOrResult <-+ runParserOn+ mDebugMode+ p'+ args+ envVars+ Nothing+ case errOrResult of+ Left errs -> do+ tc <- getTerminalCapabilitiesFromHandle stderr+ hPutChunksLocaleWith tc stderr $ renderErrors errs+ exitFailure+ Right i -> case i of+ ShowHelp -> die "unreachable, this option is only here for documentation."+ ShowVersion -> do+ progname <- getProgName+ tc <- getTerminalCapabilitiesFromHandle stdout+ hPutChunksLocaleWith tc stdout $ renderVersionPage progname version+ exitSuccess+ RenderMan -> do+ progname <- getProgName+ tc <- getTerminalCapabilitiesFromHandle stdout+ hPutChunksLocaleWith tc stdout $ renderManPage progname version progDesc docs+ exitSuccess+ RenderDocumentation -> do+ progname <- getProgName+ tc <- getTerminalCapabilitiesFromHandle stdout+ hPutChunksLocaleWith tc stdout $ renderReferenceDocumentation progname docs+ exitSuccess+ RenderNixosOptions -> do+ putStrLn $ T.unpack $ renderParserNixOptions p'+ exitSuccess+ BashCompletionScript progPath -> do+ progname <- getProgName+ generateBashCompletionScript progPath progname+ exitSuccess+ ZshCompletionScript progPath -> do+ progname <- getProgName+ generateZshCompletionScript progPath progname+ exitSuccess+ FishCompletionScript progPath -> do+ progname <- getProgName+ generateFishCompletionScript progPath progname+ exitSuccess+ CompletionQuery enriched index ws -> do+ runCompletionQuery p' enriched index ws+ exitSuccess+ ParsedNormally a -> pure a+ -- Internal structure to help us do what the framework -- is supposed to. data Internal a@@ -195,7 +209,6 @@ | RenderMan | RenderDocumentation | RenderNixosOptions- | CheckSettings | BashCompletionScript (Path Abs File) | ZshCompletionScript (Path Abs File) | FishCompletionScript (Path Abs File)@@ -208,119 +221,103 @@ ![String] | ParsedNormally !a -settingsCheckSwitch :: NonEmpty Char-settingsCheckSwitch =- -- Pretty long so it probably doesn't collide.- 'r' :| "un-settings-check"- internalParser :: Version -> Parser a -> Parser (Internal a) internalParser version p =- let allowLeftovers :: Parser a -> Parser a- allowLeftovers p' = fst <$> ((,) <$> p' <*> many (setting [reader str, argument, hidden] :: Parser String))- in choice- [ allowLeftovers $- setting- [ switch ShowHelp,- short 'h',- long "help",- help "Show this help text"- ],- allowLeftovers $- setting- [ switch ShowVersion,- long "version",- help $ "Output version information: " <> showVersion version- ],- setting- [ switch RenderMan,- long "render-man-page",- hidden,- help "Render a manpage"- ],- setting- [ switch RenderDocumentation,- long "render-reference-documentation",- hidden,- help "Render reference documentation"- ],- setting- [ switch RenderNixosOptions,- long "render-nixos-options",- hidden,- help "Render nixos options"- ],- allowLeftovers $- setting- [ switch CheckSettings,- long $ NE.toList settingsCheckSwitch,+ choice+ [ setting+ [ switch ShowHelp,+ short 'h',+ long "help",+ help "Show this help text"+ ],+ setting+ [ switch ShowVersion,+ long "version",+ help $ "Output version information: " <> showVersion version+ ],+ setting+ [ switch RenderMan,+ long "render-man-page",+ hidden,+ help "Render a manpage"+ ],+ setting+ [ switch RenderDocumentation,+ long "render-reference-documentation",+ hidden,+ help "Render reference documentation"+ ],+ setting+ [ switch RenderNixosOptions,+ long "render-nix-options",+ hidden,+ help "Render Nix options"+ ],+ BashCompletionScript+ <$> mapIO+ parseAbsFile+ ( setting+ [ option,+ reader str,+ long "bash-completion-script", hidden,- help "Run the parser and exit if parsing succeeded."- ],- BashCompletionScript- <$> mapIO- parseAbsFile- ( setting- [ option,- reader str,- 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"- ]- ),- ZshCompletionScript- <$> mapIO- parseAbsFile- ( setting- [ option,- reader str,- long "fish-completion-script",- hidden,- help "Render the fish completion script"- ]- ),- setting- [ help "Query completion",- switch CompletionQuery,- -- Long string that no normal user would ever use.- long "query-opt-env-conf-completion",- hidden- ]- <*> setting- [ switch True,- long "completion-enriched",- value False,+ help "Render the bash completion script"+ ]+ ),+ ZshCompletionScript+ <$> mapIO+ parseAbsFile+ ( setting+ [ option,+ reader str,+ long "zsh-completion-script", hidden,- help "Whether to enable enriched completion"+ help "Render the zsh completion script" ]- <*> setting+ ),+ ZshCompletionScript+ <$> mapIO+ parseAbsFile+ ( setting [ option,- reader auto,- long "completion-index",+ reader str,+ long "fish-completion-script", hidden,- help "The index between the arguments where completion was invoked."+ help "Render the fish completion script" ]- <*> many- ( setting- [ option,- reader str,- long "completion-word",- hidden,- help "The words (arguments) that have already been typed"- ]- ),- ParsedNormally <$> p+ ),+ setting+ [ help "Query completion",+ switch CompletionQuery,+ -- Long string that no normal user would ever use.+ long "query-opt-env-conf-completion",+ hidden ]+ <*> setting+ [ switch True,+ long "completion-enriched",+ value False,+ hidden,+ help "Whether to enable enriched completion"+ ]+ <*> setting+ [ option,+ reader auto,+ long "completion-index",+ hidden,+ help "The index between the arguments where completion was invoked."+ ]+ <*> many+ ( setting+ [ option,+ reader str,+ long "completion-word",+ hidden,+ help "The words (arguments) that have already been typed"+ ]+ ),+ ParsedNormally <$> p+ ] -- | Run a parser on given arguments and environment instead of getting them -- from the current process.@@ -361,7 +358,13 @@ -- TODO: Consider keeping around all errors? mNext <- runNonDetTLazy ns case mNext of- Nothing -> pure $ Left firstErrors+ Nothing ->+ pure $+ Left $+ let f = case mDebugMode of+ Nothing -> eraseErrorSrcLocs+ Just _ -> id+ in f firstErrors Just ((eOR, _), ns') -> case eOR of Success a -> pure (Right a) Failure _ -> goNexts ns'@@ -515,7 +518,6 @@ markParsed pure a _ -> do- -- TODO do this without all the nesting mSwitch <- case settingSwitchValue of Nothing -> pure NotRun Just a -> do@@ -605,50 +607,60 @@ let mConfDoc = settingConfDoc set mConf <- case settingConfigVals of Nothing -> pure NotRun- Just (ConfigValSetting {..} :| _) -> do- -- TODO try parsing with the others+ Just confSets -> do mObj <- asks ppEnvConf case mObj of Nothing -> do debug ["no config object to set from"] pure NotFound Just obj -> do- let jsonParser :: JSON.Object -> NonEmpty String -> JSON.Parser (Maybe JSON.Value)- jsonParser o (k :| rest) = case NE.nonEmpty rest of- Nothing -> do- case KeyMap.lookup (Key.fromString k) o of- Nothing -> pure Nothing- Just v -> Just <$> parseJSON v- Just neRest -> do- mO' <- o .:? Key.fromString k- case mO' of- Nothing -> pure Nothing- Just o' -> jsonParser o' neRest- case JSON.parseEither (jsonParser obj) configValSettingPath of- Left err -> ppError mLoc $ ParseErrorConfigRead mConfDoc err- Right mV -> case mV of- Nothing -> do- debug- [ "could not set based on config value, not configured: ",- chunk $ T.pack $ show $ NE.toList configValSettingPath- ]- pure NotFound- Just v -> case JSON.parseEither (parseJSONVia configValSettingCodec) v of- Left err -> ppError mLoc $ ParseErrorConfigRead mConfDoc err- Right mA -> case mA of- Nothing -> do- debug- [ "could not set based on config value, configured to nothing: ",- chunk $ T.pack $ show $ NE.toList configValSettingPath- ]- pure NotFound- Just a -> do- debug- [ "set based on config value:",- chunk $ T.pack $ show v- ]- pure $ Found a-+ let goConfSet ConfigValSetting {..} = do+ let jsonParser :: JSON.Object -> NonEmpty String -> JSON.Parser (Maybe JSON.Value)+ jsonParser o (k :| rest) = case NE.nonEmpty rest of+ Nothing -> do+ case KeyMap.lookup (Key.fromString k) o of+ Nothing -> pure Nothing+ Just v -> Just <$> parseJSON v+ Just neRest -> do+ mO' <- o .:? Key.fromString k+ case mO' of+ Nothing -> pure Nothing+ Just o' -> jsonParser o' neRest+ case JSON.parseEither (jsonParser obj) configValSettingPath of+ Left err -> ppError mLoc $ ParseErrorConfigRead mConfDoc err+ Right mV -> case mV of+ Nothing -> do+ debug+ [ "could not set based on config value, not configured: ",+ chunk $ T.pack $ show $ NE.toList configValSettingPath+ ]+ pure Nothing+ Just v -> case JSON.parseEither (parseJSONVia configValSettingCodec) v of+ Left err -> ppError mLoc $ ParseErrorConfigRead mConfDoc err+ Right mA -> case mA of+ Nothing -> do+ debug+ [ "could not set based on config value, configured to nothing: ",+ chunk $ T.pack $ show $ NE.toList configValSettingPath+ ]+ pure Nothing+ Just a -> do+ debug+ [ "set based on config value:",+ chunk $ T.pack $ show v+ ]+ pure $ Just a+ let toRes = \case+ Nothing -> NotFound+ Just a -> Found a+ let goConfSets (confSet :| rest) = case NE.nonEmpty rest of+ Nothing -> toRes <$> goConfSet confSet+ Just ne -> do+ res <- goConfSet confSet+ case res of+ Just a -> pure $ Found a+ Nothing -> goConfSets ne+ goConfSets confSets case mConf of Found a -> do markParsed