opt-env-conf 0.0.0.0 → 0.1.0.0

raw patch · 6 files changed

+179/−70 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• opt-env-conf.cabal +9/−1
• src/OptEnvConf/Args.hs +113/−57
• src/OptEnvConf/Error.hs +5/−1
• src/OptEnvConf/Parser.hs +4/−4
• src/OptEnvConf/Run.hs +38/−7

@@ -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

@@ -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:

@@ -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

@@ -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     ] 

@@ -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

@@ -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