diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/opt-env-conf.cabal b/opt-env-conf.cabal --- a/opt-env-conf.cabal +++ b/opt-env-conf.cabal @@ -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 diff --git a/src/OptEnvConf/Run.hs b/src/OptEnvConf/Run.hs --- a/src/OptEnvConf/Run.hs +++ b/src/OptEnvConf/Run.hs @@ -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