diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,15 @@ # Changelog +## [0.1.0.0] - 2024-07-16 + +### Changed + +* `xdgYamlConfigFile` now returns a `Path Abs File` instead of a `FilePath`. +* Fixed a bug in `withFirstYamlConfig` and `withCombinedYamlConfig` in which the `--config-file` option was required. +* `--run-settings-check` now allows you to define a static settings check. +* Parse the combination of optional switches and optional arguments correctly. +* Fail to parse if any arguments are leftover. + ## [0.0.0.0] - 2024-07-08 First version diff --git a/opt-env-conf.cabal b/opt-env-conf.cabal --- a/opt-env-conf.cabal +++ b/opt-env-conf.cabal @@ -5,14 +5,22 @@ -- see: https://github.com/sol/hpack name: opt-env-conf -version: 0.0.0.0 +version: 0.1.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 license: LGPL-3 license-file: LICENSE build-type: Simple extra-source-files: CHANGELOG.md + +source-repository head + type: git + location: https://github.com/NorfairKing/opt-env-conf library exposed-modules: diff --git a/src/OptEnvConf/Args.hs b/src/OptEnvConf/Args.hs --- a/src/OptEnvConf/Args.hs +++ b/src/OptEnvConf/Args.hs @@ -1,11 +1,13 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} module OptEnvConf.Args ( -- * Public API Args (..), emptyArgs, + argsLeftovers, parseArgs, consumeArgument, consumeOption, @@ -91,9 +93,10 @@ -- 'consumeArgument', 'consumeOption' and 'consumeSwitch'. -- -- In order to implement folded short dashed options, we need to use tombstones --- for consumed arguments. -newtype Args = Args - { unArgs :: [Tomb Arg] +-- for consumed argumentsn +data Args = Args + { argsBefore :: [Tomb Arg], + argsAfter :: [Tomb Arg] } deriving (Show, Eq, Generic) @@ -101,63 +104,106 @@ instance IsList Args where type Item Args = Tomb Arg - fromList = Args - toList = unArgs + fromList l = Args {argsBefore = [], argsAfter = l} + toList = rebuildArgs -- | Empty list of arguments emptyArgs :: Args -emptyArgs = Args [] +emptyArgs = parseArgs [] --- | Create 'Args' with all-live arguments. +rebuildArgs :: Args -> [Tomb Arg] +rebuildArgs Args {..} = argsBefore ++ argsAfter + +argsLeftovers :: Args -> Maybe (NonEmpty String) +argsLeftovers = + NE.nonEmpty + . mapMaybe + ( \case + Live a -> Just (renderArg a) + Dead -> Nothing + ) + . rebuildArgs + +-- | Create 'Args' with all-live arguments and cursor at the start. parseArgs :: [String] -> Args -parseArgs args = Args $ map (Live . parseArg) args +parseArgs args = Args {argsBefore = [], argsAfter = map (Live . parseArg) args} -- | Consume a single positional argument. -- -- The result are all possible results -consumeArgument :: Args -> [(String, Args)] -consumeArgument am = do - (s, opts') <- go $ unArgs am - pure (s, am {unArgs = opts'}) - where - go :: [Tomb Arg] -> [(String, [Tomb Arg])] - go = \case - -- Nothing to consume - [] -> [] - -- If the last argument is dead, don't consume it. - [Dead] -> [] - -- Every arg could be the argument we consume. - [Live o] -> [(renderArg o, [])] - -- Skip dead args - (Dead : rest) -> map (second (Dead :)) (go rest) - -- Anything after a "--" should be considered an argument and we can stop looking after that - -- TODO: This means that we can never consume '--' as a bare argument - -- unless it's the last arg. Is that intentional? - (Live ArgBareDoubleDash : rest) -> map (second (Live ArgBareDoubleDash :)) (goBare rest) - -- A bare dash could be an argument and we can stop looking after that - (Live ArgBareDash : rest) -> [(renderArg ArgBareDash, Dead : rest)] - -- A plain argument could definitely be an argument and we can stop looking after that - (Live (ArgPlain a) : rest) -> [(a, Dead : rest)] - -- Any argument after a dashed argument could be an option value so we - -- should also keep looking after that. - (Live o1@(ArgDashed {}) : Live o2 : rest) -> - -- TODO put this option at the back so it's considered last ? - (renderArg o1, Dead : Live o2 : rest) - : (renderArg o2, Live o1 : Dead : rest) - : map (second ((Live o1 :) . (Live o2 :))) (go rest) - -- Any argument with a dead one after it can only be a switch or an argument - (Live o1@(ArgDashed {}) : Dead : rest) -> - -- TODO put this option at the back so it's considered last ? - (renderArg o1, Dead : rest) - : map (second (Live o1 :)) (go rest) - goBare :: [Tomb Arg] -> [(String, [Tomb Arg])] - goBare = \case - [] -> [] - -- Skip dead arguments - (Dead : rest) -> map (second (Dead :)) (goBare rest) - -- Consume a live argument. - -- No need to tombstone it because anything after -- can only be an argument. - (Live o : rest) -> [(renderArg o, rest)] +consumeArgument :: Args -> [(Maybe String, Args)] +consumeArgument as = do + case argsAfter as of + [] -> [(Nothing, as)] + (firstArg : afters) -> + let befores = argsBefore as + consumed = Args (befores ++ [Dead]) afters + in case firstArg of + -- Skip any dead argument + Dead -> consumeArgument consumed + Live a -> case a of + -- Plain argument: that's the only option, consume it. + ArgPlain plain -> [(Just plain, consumed)] + -- A single dash is always an argument + ArgBareDash -> [(Just "-", consumed)] + -- Bare double-dash + ArgBareDoubleDash -> case afters of + -- If it's the last argument, consume it as an argument + [] -> [(Just "--", consumed)] + -- If there's only a dead argument after the double dash, that + -- means we've been parsing bare args and are now done. + -- We can stop consuming but get rid of the tombstone as well. + -- Otherwise there will be a leftover unconsumed '--' after all parsing is done. + [Dead] -> [(Nothing, Args befores [])] + -- If it's not the last argument, anything after here is an argument. + -- In order to not have to maintain whether the cursor is after + -- a bare double dash already, we keep the cursor here and just + -- pop the args as they come. + _ -> + let go = \case + [] -> Nothing + (Dead : rest) -> go rest + (Live a' : rest) -> Just (a', rest) + in case go afters of + Nothing -> [(Nothing, as)] + Just (firstLive, rest) -> + -- We need to leave the dead argument there so that + -- we don't consume the double-dash as an argument + -- after consuming all the arguments after it as bare + -- arguments. + [ ( Just $ renderArg firstLive, + Args befores (Live ArgBareDoubleDash : Dead : rest) + ) + ] + ArgDashed {} -> + -- Dead after dashed, two options, in order that they should be considered: + -- * The dashed is a switch (don't consume an arg) + -- * The dashed is an argument + -- TODO we need to continue looking too + let switchCase = + consumeArgument (Args (befores ++ [firstArg]) afters) + ++ [ (Just (renderArg a), consumed) + ] + in case afters of + -- Last argument is is dashed, that's the same as being followed by a dead argument + [] -> switchCase + (Dead : _) -> switchCase + (Live a' : rest) -> + -- Live after dashed, three options, in order that they should be considered: + -- * The dashed is an option and the live is the value + -- * The dashed is a switch and the live is an argument + -- * The dashed is an argument + ( case a' of + ArgDashed {} -> + consumeArgument (Args (befores ++ [Live a]) afters) + ++ [ (Just (renderArg a), consumed) + ] + _ -> + consumeArgument (Args (befores ++ [Live a, Live a']) rest) + ++ [ (Just (renderArg a'), Args (befores ++ [Live a, Dead]) rest), + (Just (renderArg a), consumed) + ] + ) -- | Consume an option. -- @@ -169,9 +215,14 @@ -- * @["--foo=foo"]@ -- * @["-ffoo"]@ consumeOption :: [Dashed] -> Args -> Maybe (String, Args) -consumeOption dasheds am = do - (mS, opts') <- go $ unArgs am - pure (mS, am {unArgs = opts'}) +consumeOption dasheds as = do + case go (argsBefore as) of + Just (val, newBefores) -> Just (val, as {argsBefore = newBefores}) + Nothing -> + -- TODO option value on the border + case go (argsAfter as) of + Just (val, newAfters) -> Just (val, as {argsAfter = newAfters}) + Nothing -> Nothing where go :: [Tomb Arg] -> Maybe (String, [Tomb Arg]) go = \case @@ -182,6 +233,7 @@ (Live k : rest) -> case k of -- We can either consume it as-is, or as a shorthand option. + ArgBareDoubleDash -> Nothing ArgDashed isLong cs -> case consumeDashedShorthandOption dasheds isLong cs of Just v -> Just (v, Dead : rest) @@ -264,15 +316,19 @@ -- * @["--foo"]@ -- * @["-df"]@ consumeSwitch :: [Dashed] -> Args -> Maybe Args -consumeSwitch dasheds am = do - opts' <- go $ unArgs am - pure $ am {unArgs = opts'} +consumeSwitch dasheds as = do + case go (argsBefore as) of + Just newBefores -> Just $ as {argsBefore = newBefores} + Nothing -> case go (argsAfter as) of + Just newAfters -> Just $ as {argsAfter = newAfters} + Nothing -> Nothing where go :: [Tomb Arg] -> Maybe [Tomb Arg] go = \case [] -> Nothing (Dead : rest) -> (Dead :) <$> go rest (Live o : rest) -> case o of + ArgBareDoubleDash -> Nothing ArgDashed isLong cs -> case consumeDashedSwitch dasheds isLong cs of Nothing -> (Live o :) <$> go rest Just Nothing -> Just $ Dead : rest diff --git a/src/OptEnvConf/Error.hs b/src/OptEnvConf/Error.hs --- a/src/OptEnvConf/Error.hs +++ b/src/OptEnvConf/Error.hs @@ -37,6 +37,7 @@ | ParseErrorMissingCommand ![String] | ParseErrorUnrecognisedCommand !String ![String] | ParseErrorAllOrNothing + | ParseErrorUnrecognised !(NonEmpty String) deriving (Show) -- | Whether the other side of an 'Alt' should be tried if we find this error. @@ -61,6 +62,7 @@ ParseErrorMissingCommand cs -> not $ null cs ParseErrorUnrecognisedCommand _ _ -> False ParseErrorAllOrNothing -> False + ParseErrorUnrecognised _ -> False eraseErrorSrcLocs :: (Functor f) => f ParseError -> f ParseError eraseErrorSrcLocs = fmap eraseErrorSrcLoc @@ -125,7 +127,9 @@ ] ParseErrorAllOrNothing -> [ ["You are seeing this error because at least one, but not all, of the settings in an allOrNothing (or subSettings) parser have been defined."] - ], + ] + ParseErrorUnrecognised leftovers -> + ["Unrecognised args: " : unwordsChunks (map (pure . chunk . T.pack) (NE.toList leftovers))], maybe [] (pure . ("see " :) . pure . fore cyan . chunk . T.pack . prettySrcLoc) parseErrorSrcLoc ] diff --git a/src/OptEnvConf/Parser.hs b/src/OptEnvConf/Parser.hs --- a/src/OptEnvConf/Parser.hs +++ b/src/OptEnvConf/Parser.hs @@ -588,14 +588,14 @@ -- | Load the Yaml config in the first of the filepaths that points to something that exists. withFirstYamlConfig :: Parser [Path Abs File] -> Parser a -> Parser a -withFirstYamlConfig parsers = withConfig $ mapIO readFirstYamlConfigFile $ (:) <$> configuredConfigFile <*> parsers +withFirstYamlConfig parsers = withConfig $ mapIO readFirstYamlConfigFile $ (<>) <$> (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 withCombinedYamlConfigs = withCombinedYamlConfigs' combineConfigObjects withCombinedYamlConfigs' :: (Object -> JSON.Object -> JSON.Object) -> Parser [Path Abs File] -> Parser a -> Parser a -withCombinedYamlConfigs' combiner parsers = withConfig $ mapIO (foldM resolveYamlConfigFile Nothing) $ (:) <$> configuredConfigFile <*> parsers +withCombinedYamlConfigs' combiner parsers = withConfig $ mapIO (foldM resolveYamlConfigFile Nothing) $ (<>) <$> (maybeToList <$> optional configuredConfigFile) <*> parsers where resolveYamlConfigFile :: Maybe JSON.Object -> Path Abs File -> IO (Maybe JSON.Object) resolveYamlConfigFile acc = fmap (combineMaybeObjects acc . join) . readYamlConfigFile @@ -613,7 +613,7 @@ combineValues v _ = v -- | Load @config.yaml@ from the given XDG configuration subdirectory -xdgYamlConfigFile :: (HasCallStack) => FilePath -> Parser FilePath +xdgYamlConfigFile :: (HasCallStack) => FilePath -> Parser (Path Abs File) xdgYamlConfigFile subdir = mapIO ( \mXdgDir -> do @@ -623,7 +623,7 @@ home <- getHomeDir resolveDir home ".config" configDir <- resolveDir xdgDir subdir - fromAbsFile <$> resolveFile configDir "config.yaml" + resolveFile configDir "config.yaml" ) $ optional $ withFrozenCallStack diff --git a/src/OptEnvConf/Run.hs b/src/OptEnvConf/Run.hs --- a/src/OptEnvConf/Run.hs +++ b/src/OptEnvConf/Run.hs @@ -130,6 +130,21 @@ tc <- getTerminalCapabilitiesFromHandle stdout hPutChunksLocaleWith tc stdout $ renderManPage progname version progDesc docs 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 + errOrSets <- runParserOn p argMap'' envVars Nothing + case errOrSets of + Left errs -> do + tc <- getTerminalCapabilitiesFromHandle stderr + -- Don't erase rcs locs because they'll probably be useful anyway. + hPutChunksLocaleWith tc stderr $ renderErrors errs + exitFailure + Right _ -> do + tc <- getTerminalCapabilitiesFromHandle stdout + hPutChunksLocaleWith tc stdout ["Settings parsed successfully."] + exitSuccess BashCompletionScript progPath -> do progname <- getProgName generateBashCompletionScript progPath progname @@ -153,6 +168,7 @@ = ShowHelp | ShowVersion | RenderMan + | CheckSettings | BashCompletionScript (Path Abs File) | ZshCompletionScript (Path Abs File) | FishCompletionScript (Path Abs File) @@ -165,6 +181,11 @@ ![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 = choice @@ -185,6 +206,12 @@ hidden, help "Show this help text" ], + setting + [ switch CheckSettings, + long $ NE.toList settingsCheckSwitch, + hidden, + help "Run the parser and exit if parsing succeeded." + ], BashCompletionScript <$> mapIO parseAbsFile @@ -270,7 +297,13 @@ { ppEnvEnv = envVars, ppEnvConf = mConfig } - mTup <- runPPLazy (go parser) ppState ppEnv + let go' = do + result <- go parser + leftoverArgs <- gets ppStateArgs + case argsLeftovers leftoverArgs of + Nothing -> pure result + Just leftovers -> ppError Nothing $ ParseErrorUnrecognised leftovers + mTup <- runPPLazy go' ppState ppEnv case mTup of Nothing -> error "TODO figure out when this list can be empty" Just ((errOrRes, _), nexts) -> case errOrRes of @@ -569,12 +602,10 @@ ppArg :: PP (Maybe String) ppArg = do args <- gets ppStateArgs - case Args.consumeArgument args of - [] -> pure Nothing - as -> do - (a, args') <- ppNonDetList as - modify' (\s -> s {ppStateArgs = args'}) - pure (Just a) + let consumePossibilities = Args.consumeArgument args + (mA, args') <- ppNonDetList consumePossibilities + modify' (\s -> s {ppStateArgs = args'}) + pure mA ppOpt :: [Dashed] -> PP (Maybe String) ppOpt ds = do