opt-env-conf 0.2.0.0 → 0.3.0.0
raw patch · 10 files changed
+549/−314 lines, 10 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- OptEnvConf.Args: argsLeftovers :: Args -> Maybe (NonEmpty String)
+ OptEnvConf.Args: recogniseLeftovers :: Args -> Maybe (NonEmpty String)
+ OptEnvConf.Output: commandChunk :: String -> Chunk
+ OptEnvConf.Output: confValChunk :: NonEmpty String -> Chunk
+ OptEnvConf.Output: dashedChunk :: Dashed -> Chunk
+ OptEnvConf.Output: dashedChunks :: [Dashed] -> Maybe [Chunk]
+ OptEnvConf.Output: dashedChunksNE :: NonEmpty Dashed -> [Chunk]
+ OptEnvConf.Output: defaultValueChunks :: String -> [Chunk]
+ OptEnvConf.Output: envVarChunk :: String -> Chunk
+ OptEnvConf.Output: envVarChunksNE :: NonEmpty String -> [Chunk]
+ OptEnvConf.Output: headerChunks :: Text -> [Chunk]
+ OptEnvConf.Output: helpChunk :: Help -> Chunk
+ OptEnvConf.Output: indent :: [[Chunk]] -> [[Chunk]]
+ OptEnvConf.Output: mHelpChunk :: Maybe Help -> Chunk
+ OptEnvConf.Output: mMetavarChunk :: Maybe Metavar -> Chunk
+ OptEnvConf.Output: mSrcLocChunk :: Maybe SrcLoc -> Chunk
+ OptEnvConf.Output: metavarChunk :: Metavar -> Chunk
+ OptEnvConf.Output: progNameChunk :: String -> Chunk
+ OptEnvConf.Output: srcLocChunk :: SrcLoc -> Chunk
+ OptEnvConf.Output: stringLines :: String -> [[Chunk]]
+ OptEnvConf.Output: syntaxChunk :: String -> Chunk
+ OptEnvConf.Output: usageChunk :: Chunk
+ OptEnvConf.Output: versionChunk :: Version -> Chunk
- OptEnvConf: mapIO :: (a -> IO b) -> Parser a -> Parser b
+ OptEnvConf: mapIO :: HasCallStack => (a -> IO b) -> Parser a -> Parser b
- OptEnvConf: withCombinedYamlConfigs' :: (Object -> Object -> Object) -> Parser [Path Abs File] -> Parser a -> Parser a
+ OptEnvConf: withCombinedYamlConfigs' :: HasCallStack => (Object -> Object -> Object) -> Parser [Path Abs File] -> Parser a -> Parser a
- OptEnvConf: withConfig :: Parser (Maybe Object) -> Parser a -> Parser a
+ OptEnvConf: withConfig :: HasCallStack => Parser (Maybe Object) -> Parser a -> Parser a
- OptEnvConf: withConfigurableYamlConfig :: Parser (Path Abs File) -> Parser a -> Parser a
+ OptEnvConf: withConfigurableYamlConfig :: HasCallStack => Parser (Path Abs File) -> Parser a -> Parser a
- OptEnvConf: withFirstYamlConfig :: Parser [Path Abs File] -> Parser a -> Parser a
+ OptEnvConf: withFirstYamlConfig :: HasCallStack => Parser [Path Abs File] -> Parser a -> Parser a
- OptEnvConf: withLocalYamlConfig :: Parser a -> Parser a
+ OptEnvConf: withLocalYamlConfig :: HasCallStack => Parser a -> Parser a
- OptEnvConf: withYamlConfig :: Parser (Maybe (Path Abs File)) -> Parser a -> Parser a
+ OptEnvConf: withYamlConfig :: HasCallStack => Parser (Maybe (Path Abs File)) -> Parser a -> Parser a
- OptEnvConf: withoutConfig :: Parser a -> Parser a
+ OptEnvConf: withoutConfig :: HasCallStack => Parser a -> Parser a
- OptEnvConf.Parser: [ParserCommands] :: !Maybe SrcLoc -> [Command a] -> Parser a
+ OptEnvConf.Parser: [ParserCommands] :: !Maybe SrcLoc -> ![Command a] -> Parser a
- OptEnvConf.Parser: [ParserWithConfig] :: Parser (Maybe Object) -> !Parser a -> Parser a
+ OptEnvConf.Parser: [ParserWithConfig] :: !Maybe SrcLoc -> !Parser (Maybe Object) -> !Parser a -> Parser a
- OptEnvConf.Parser: configuredConfigFile :: Parser (Path Abs File)
+ OptEnvConf.Parser: configuredConfigFile :: HasCallStack => Parser (Path Abs File)
- OptEnvConf.Parser: mapIO :: (a -> IO b) -> Parser a -> Parser b
+ OptEnvConf.Parser: mapIO :: HasCallStack => (a -> IO b) -> Parser a -> Parser b
- OptEnvConf.Parser: runIO :: IO a -> Parser a
+ OptEnvConf.Parser: runIO :: HasCallStack => IO a -> Parser a
- OptEnvConf.Parser: withCombinedYamlConfigs' :: (Object -> Object -> Object) -> Parser [Path Abs File] -> Parser a -> Parser a
+ OptEnvConf.Parser: withCombinedYamlConfigs' :: HasCallStack => (Object -> Object -> Object) -> Parser [Path Abs File] -> Parser a -> Parser a
- OptEnvConf.Parser: withConfig :: Parser (Maybe Object) -> Parser a -> Parser a
+ OptEnvConf.Parser: withConfig :: HasCallStack => Parser (Maybe Object) -> Parser a -> Parser a
- OptEnvConf.Parser: withConfigurableYamlConfig :: Parser (Path Abs File) -> Parser a -> Parser a
+ OptEnvConf.Parser: withConfigurableYamlConfig :: HasCallStack => Parser (Path Abs File) -> Parser a -> Parser a
- OptEnvConf.Parser: withFirstYamlConfig :: Parser [Path Abs File] -> Parser a -> Parser a
+ OptEnvConf.Parser: withFirstYamlConfig :: HasCallStack => Parser [Path Abs File] -> Parser a -> Parser a
- OptEnvConf.Parser: withLocalYamlConfig :: Parser a -> Parser a
+ OptEnvConf.Parser: withLocalYamlConfig :: HasCallStack => Parser a -> Parser a
- OptEnvConf.Parser: withYamlConfig :: Parser (Maybe (Path Abs File)) -> Parser a -> Parser a
+ OptEnvConf.Parser: withYamlConfig :: HasCallStack => Parser (Maybe (Path Abs File)) -> Parser a -> Parser a
- OptEnvConf.Parser: withoutConfig :: Parser a -> Parser a
+ OptEnvConf.Parser: withoutConfig :: HasCallStack => Parser a -> Parser a
- OptEnvConf.Run: runParserOn :: Parser a -> Args -> EnvMap -> Maybe Object -> IO (Either (NonEmpty ParseError) a)
+ OptEnvConf.Run: runParserOn :: Maybe TerminalCapabilities -> Parser a -> Args -> EnvMap -> Maybe Object -> IO (Either (NonEmpty ParseError) a)
Files
- CHANGELOG.md +8/−0
- opt-env-conf.cabal +2/−1
- src/OptEnvConf/Args.hs +16/−11
- src/OptEnvConf/Completion.hs +6/−1
- src/OptEnvConf/Doc.hs +3/−60
- src/OptEnvConf/Error.hs +3/−2
- src/OptEnvConf/Lint.hs +1/−1
- src/OptEnvConf/Output.hs +81/−0
- src/OptEnvConf/Parser.hs +84/−38
- src/OptEnvConf/Run.hs +345/−200
CHANGELOG.md view
@@ -1,5 +1,13 @@ # Changelog +## [0.3.0.0] - 2024-07-19++### Changed++* Debug mode now provides much more info about all the settings that were and weren't parsed, and why.+* Fixed a bug in which arguments that were consumed in a failed branch were not being unconsumed afterwards.+* Nix functions now produce completion as well as man pages.+ ## [0.2.0.0] -- 2024-07-18 ### Changed
opt-env-conf.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: opt-env-conf-version: 0.2.0.0+version: 0.3.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@@ -33,6 +33,7 @@ OptEnvConf.Error OptEnvConf.Lint OptEnvConf.NonDet+ OptEnvConf.Output OptEnvConf.Parser OptEnvConf.Reader OptEnvConf.Run
src/OptEnvConf/Args.hs view
@@ -7,11 +7,11 @@ ( -- * Public API Args (..), emptyArgs,- argsLeftovers, parseArgs, consumeArgument, consumeOption, consumeSwitch,+ recogniseLeftovers, -- ** Internals Tomb (..),@@ -114,16 +114,6 @@ 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 {argsBefore = [], argsAfter = map (Live . parseArg) args}@@ -370,6 +360,21 @@ (c :| [], True) (first (c NE.<|)) new++recogniseLeftovers :: Args -> Maybe (NonEmpty String)+recogniseLeftovers Args {..} = NE.nonEmpty $ live argsBefore ++ live (modDoubleDash argsAfter)+ where+ -- If arguments were parsed after a double dash, don't consider the double+ -- dash leftover.+ modDoubleDash = \case+ Live ArgBareDoubleDash : Dead : rest -> rest+ a -> a+ live =+ mapMaybe+ ( \case+ Live a -> Just (renderArg a)+ Dead -> Nothing+ ) data Dashed = DashedShort !Char
src/OptEnvConf/Completion.hs view
@@ -202,7 +202,12 @@ ParserCommands _ cs -> do -- Don't re-use the state accross commands Just . concat . catMaybes <$> mapM goCommand cs- ParserWithConfig _ p -> go p+ ParserWithConfig _ p1 p2 -> do+ c1 <- go p1+ case c1 of+ Just [] -> go p2+ Just ss -> pure $ Just ss+ Nothing -> pure $ Just [] ParserSetting _ Setting {..} -> if settingHidden then pure $ Just []
src/OptEnvConf/Doc.hs view
@@ -40,15 +40,14 @@ import Autodocodec.Yaml.Schema import Control.Arrow import Control.Monad-import Data.List (intercalate, intersperse)+import Data.List (intersperse) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import Data.Maybe-import Data.Text (Text) import qualified Data.Text as T import Data.Version import OptEnvConf.Args (Dashed (..))-import qualified OptEnvConf.Args as Args+import OptEnvConf.Output import OptEnvConf.Parser import OptEnvConf.Setting import Text.Colour@@ -191,7 +190,7 @@ ParserAllOrNothing _ p -> go p ParserCheck _ _ _ p -> go p ParserCommands _ cs -> AnyDocsCommands $ map goCommand cs- ParserWithConfig p1 p2 -> AnyDocsAnd [go p1, go p2] -- TODO: is this right? Maybe we want to document that it's not a pure parser?+ ParserWithConfig _ p1 p2 -> AnyDocsAnd [go p1, go p2] -- TODO: is this right? Maybe we want to document that it's not a pure parser? ParserSetting _ set -> maybe noDocs AnyDocsSingle $ settingSetDoc set goCommand :: Command a -> CommandDoc SetDoc goCommand Command {..} =@@ -287,11 +286,6 @@ progDescLines :: String -> [[Chunk]] progDescLines = stringLines -stringLines :: String -> [[Chunk]]-stringLines s =- let ls = T.lines (T.pack s)- in map (pure . chunk) ls- -- | Render the output of `--render-man-page` for reading with @man@ renderManPage :: String ->@@ -644,54 +638,3 @@ [confValChunk key, ":"] : indent ls ) (NE.toList confDocKeys)--progNameChunk :: String -> Chunk-progNameChunk = fore yellow . chunk . T.pack--versionChunk :: Version -> Chunk-versionChunk = chunk . T.pack . showVersion--usageChunk :: Chunk-usageChunk = fore cyan "Usage: "--commandChunk :: String -> Chunk-commandChunk = fore magenta . chunk . T.pack--mMetavarChunk :: Maybe Metavar -> Chunk-mMetavarChunk = metavarChunk . fromMaybe "METAVAR"--metavarChunk :: Metavar -> Chunk-metavarChunk = fore yellow . chunk . T.pack--dashedChunks :: [Dashed] -> Maybe [Chunk]-dashedChunks = fmap dashedChunksNE . NE.nonEmpty--dashedChunksNE :: NonEmpty Dashed -> [Chunk]-dashedChunksNE = intersperse (fore cyan "|") . map dashedChunk . NE.toList--dashedChunk :: Dashed -> Chunk-dashedChunk = fore white . chunk . T.pack . Args.renderDashed--envVarChunksNE :: NonEmpty String -> [Chunk]-envVarChunksNE = intersperse (fore cyan "|") . map envVarChunk . NE.toList--envVarChunk :: String -> Chunk-envVarChunk = fore white . chunk . T.pack--confValChunk :: NonEmpty String -> Chunk-confValChunk = fore white . chunk . T.pack . intercalate "." . NE.toList--defaultValueChunks :: String -> [Chunk]-defaultValueChunks val = ["default: ", fore yellow $ chunk $ T.pack val]--mHelpChunk :: Maybe Help -> Chunk-mHelpChunk = maybe (fore red "undocumented") helpChunk--helpChunk :: Help -> Chunk-helpChunk = fore blue . chunk . T.pack--headerChunks :: Text -> [Chunk]-headerChunks t = [fore cyan (chunk t), ":"]--indent :: [[Chunk]] -> [[Chunk]]-indent = map (" " :)
src/OptEnvConf/Error.hs view
@@ -9,8 +9,9 @@ import Data.Set (Set) import qualified Data.Set as S import qualified Data.Text as T-import GHC.Stack (SrcLoc, prettySrcLoc)+import GHC.Stack (SrcLoc) import OptEnvConf.Doc+import OptEnvConf.Output import OptEnvConf.Parser (SrcLocHash, hashSrcLoc) import Text.Colour @@ -130,7 +131,7 @@ ] ParseErrorUnrecognised leftovers -> ["Unrecognised args: " : unwordsChunks (map (pure . chunk . T.pack) (NE.toList leftovers))],- maybe [] (pure . ("see " :) . pure . fore cyan . chunk . T.pack . prettySrcLoc) parseErrorSrcLoc+ maybe [] (pure . ("see " :) . pure . srcLocChunk) parseErrorSrcLoc ] errorSrcLocSet :: (Foldable f) => f ParseError -> Set SrcLocHash
src/OptEnvConf/Lint.hs view
@@ -248,7 +248,7 @@ if null ls then validationTFailure $ LintError mLoc LintErrorNoCommands else and <$> traverse (go . commandParser) ls -- TODO is this right?- ParserWithConfig p1 p2 -> do+ ParserWithConfig _ p1 p2 -> do c1 <- go p1 c2 <- local (const True) (go p2) pure $ c1 || c2
+ src/OptEnvConf/Output.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE OverloadedStrings #-}++module OptEnvConf.Output where++import Data.List (intercalate, intersperse)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as T+import Data.Version+import GHC.Stack (SrcLoc, prettySrcLoc)+import OptEnvConf.Args (Dashed (..))+import qualified OptEnvConf.Args as Args+import OptEnvConf.Parser+import Text.Colour++stringLines :: String -> [[Chunk]]+stringLines s =+ let ls = T.lines (T.pack s)+ in map (pure . chunk) ls++progNameChunk :: String -> Chunk+progNameChunk = fore yellow . chunk . T.pack++versionChunk :: Version -> Chunk+versionChunk = chunk . T.pack . showVersion++usageChunk :: Chunk+usageChunk = fore cyan "Usage: "++commandChunk :: String -> Chunk+commandChunk = fore magenta . chunk . T.pack++mMetavarChunk :: Maybe Metavar -> Chunk+mMetavarChunk = metavarChunk . fromMaybe "METAVAR"++metavarChunk :: Metavar -> Chunk+metavarChunk = fore yellow . chunk . T.pack++dashedChunks :: [Dashed] -> Maybe [Chunk]+dashedChunks = fmap dashedChunksNE . NE.nonEmpty++dashedChunksNE :: NonEmpty Dashed -> [Chunk]+dashedChunksNE = intersperse (fore cyan "|") . map dashedChunk . NE.toList++dashedChunk :: Dashed -> Chunk+dashedChunk = fore white . chunk . T.pack . Args.renderDashed++envVarChunksNE :: NonEmpty String -> [Chunk]+envVarChunksNE = intersperse (fore cyan "|") . map envVarChunk . NE.toList++envVarChunk :: String -> Chunk+envVarChunk = fore white . chunk . T.pack++confValChunk :: NonEmpty String -> Chunk+confValChunk = fore white . chunk . T.pack . intercalate "." . NE.toList++defaultValueChunks :: String -> [Chunk]+defaultValueChunks val = ["default: ", fore yellow $ chunk $ T.pack val]++mHelpChunk :: Maybe Help -> Chunk+mHelpChunk = maybe (fore red "undocumented") helpChunk++helpChunk :: Help -> Chunk+helpChunk = fore blue . chunk . T.pack++headerChunks :: Text -> [Chunk]+headerChunks t = [fore cyan (chunk t), ":"]++syntaxChunk :: String -> Chunk+syntaxChunk = fore blue . chunk . T.pack++mSrcLocChunk :: Maybe SrcLoc -> Chunk+mSrcLocChunk = maybe "without srcLoc" srcLocChunk++srcLocChunk :: SrcLoc -> Chunk+srcLocChunk = fore cyan . chunk . T.pack . prettySrcLoc++indent :: [[Chunk]] -> [[Chunk]]+indent = map (" " :)
src/OptEnvConf/Parser.hs view
@@ -150,14 +150,30 @@ -- Functor ParserPure :: !a -> Parser a -- Applicative- ParserAp :: !(Parser (a -> b)) -> !(Parser a) -> Parser b+ ParserAp ::+ !(Parser (a -> b)) ->+ !(Parser a) ->+ Parser b -- Selective- ParserSelect :: !(Parser (Either a b)) -> !(Parser (a -> b)) -> Parser b+ ParserSelect ::+ !(Parser (Either a b)) ->+ !(Parser (a -> b)) ->+ Parser b -- Alternative- ParserEmpty :: !(Maybe SrcLoc) -> Parser a- ParserAlt :: !(Parser a) -> !(Parser a) -> Parser a- ParserMany :: !(Parser a) -> Parser [a]- ParserAllOrNothing :: !(Maybe SrcLoc) -> !(Parser a) -> Parser a+ ParserEmpty ::+ !(Maybe SrcLoc) ->+ Parser a+ ParserAlt ::+ !(Parser a) ->+ !(Parser a) ->+ Parser a+ ParserMany ::+ !(Parser a) ->+ Parser [a]+ ParserAllOrNothing ::+ !(Maybe SrcLoc) ->+ !(Parser a) ->+ Parser a -- Map, Check, and IO ParserCheck :: !(Maybe SrcLoc) ->@@ -167,11 +183,21 @@ !(Parser a) -> Parser b -- Commands- ParserCommands :: !(Maybe SrcLoc) -> [Command a] -> Parser a+ ParserCommands ::+ !(Maybe SrcLoc) ->+ ![Command a] ->+ Parser a -- | Load a configuration value and use it for the continuing parser- ParserWithConfig :: Parser (Maybe JSON.Object) -> !(Parser a) -> Parser a+ ParserWithConfig ::+ !(Maybe SrcLoc) ->+ !(Parser (Maybe JSON.Object)) ->+ !(Parser a) ->+ Parser a -- | General settings- ParserSetting :: !(Maybe SrcLoc) -> !(Setting a) -> Parser a+ ParserSetting ::+ !(Maybe SrcLoc) ->+ !(Setting a) ->+ Parser a instance Functor Parser where -- We case-match to produce shallower parser structures.@@ -183,7 +209,7 @@ ParserAlt p1 p2 -> ParserAlt (fmap f p1) (fmap f p2) ParserCheck mLoc forgivable g p -> ParserCheck mLoc forgivable (fmap (fmap f) . g) p ParserCommands mLoc cs -> ParserCommands mLoc $ map (fmap f) cs- ParserWithConfig pc pa -> ParserWithConfig pc (fmap f pa)+ ParserWithConfig mLoc pc pa -> ParserWithConfig mLoc pc (fmap f pa) -- TODO: make setting a functor and fmap here p -> ParserCheck Nothing True (pure . Right . f) p @@ -211,7 +237,7 @@ ParserAllOrNothing _ p -> isEmpty p ParserCheck _ _ _ p -> isEmpty p ParserCommands _ cs -> null cs- ParserWithConfig pc ps -> isEmpty pc && isEmpty ps+ ParserWithConfig _ pc ps -> isEmpty pc && isEmpty ps ParserSetting _ _ -> False in case (isEmpty p1, isEmpty p2) of (True, True) -> ParserEmpty Nothing@@ -278,9 +304,11 @@ . showListWith showCommandABit cs- ParserWithConfig p1 p2 ->+ ParserWithConfig mLoc p1 p2 -> showParen (d > 10) $ showString "WithConfig _ "+ . showsPrec 11 mLoc+ . showString " " . go 11 p1 . showString " " . go 11 p2@@ -455,14 +483,14 @@ -- This is intended for use-cases like resolving a file to an absolute path. -- It is morally ok for read-only IO actions but you will -- have a bad time if the action is not read-only.-mapIO :: (a -> IO b) -> Parser a -> Parser b-mapIO func = checkMapIO $ fmap Right . func+mapIO :: (HasCallStack) => (a -> IO b) -> Parser a -> Parser b+mapIO func = withFrozenCallStack $ checkMapIO $ fmap Right . func -- | Run an IO action without parsing anything -- -- This action may be run more than once, so prefer to do IO outside of the parser.-runIO :: IO a -> Parser a-runIO func = mapIO (\() -> func) $ pure ()+runIO :: (HasCallStack) => IO a -> Parser a+runIO func = withFrozenCallStack $ mapIO (\() -> func) $ pure () -- | Like 'checkMapMaybe' but without changing the type checkMaybe :: (HasCallStack) => (a -> Maybe a) -> Parser a -> Parser a@@ -569,33 +597,44 @@ mLoc = snd <$> listToMaybe (getCallStack callStack) -- | Load a configuration value and use it for the given parser-withConfig :: Parser (Maybe JSON.Object) -> Parser a -> Parser a-withConfig = ParserWithConfig+withConfig :: (HasCallStack) => Parser (Maybe JSON.Object) -> Parser a -> Parser a+withConfig = ParserWithConfig mLoc+ where+ mLoc = snd <$> listToMaybe (getCallStack callStack) -- | Don't load any configuration, but still shut up lint errors about 'conf' -- being used without defining any way to load configuration. -- -- This may be useful if you use a library's 'Parser' that uses 'conf' but do -- not want to parse any configuration.-withoutConfig :: Parser a -> Parser a-withoutConfig = withConfig (pure Nothing)+withoutConfig :: (HasCallStack) => Parser a -> Parser a+withoutConfig p = withFrozenCallStack $ withConfig (pure Nothing) p -- | Load a YAML config file and use it for the given parser-withYamlConfig :: Parser (Maybe (Path Abs File)) -> Parser a -> Parser a+withYamlConfig :: (HasCallStack) => Parser (Maybe (Path Abs File)) -> Parser a -> Parser a withYamlConfig pathParser =- withConfig $- mapIO (fmap join . mapM readYamlConfigFile) pathParser+ withFrozenCallStack $+ withConfig $+ mapIO (fmap join . mapM readYamlConfigFile) pathParser -- | 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 $ (<>) <$> (maybeToList <$> optional configuredConfigFile) <*> parsers+withFirstYamlConfig :: (HasCallStack) => Parser [Path Abs File] -> Parser a -> Parser a+withFirstYamlConfig parsers =+ withFrozenCallStack $+ 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) $ (<>) <$> (maybeToList <$> optional configuredConfigFile) <*> parsers+withCombinedYamlConfigs' :: (HasCallStack) => (Object -> JSON.Object -> JSON.Object) -> Parser [Path Abs File] -> Parser a -> Parser a+withCombinedYamlConfigs' combiner parsers =+ withFrozenCallStack $+ 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@@ -637,18 +676,21 @@ -- | Load a config file that is reconfigurable with an option and environment -- variable but @config.yaml@ in the local working directory by default.-withLocalYamlConfig :: Parser a -> Parser a-withLocalYamlConfig = withConfigurableYamlConfig $ mapIO resolveFile' $ pure "config.yaml"+withLocalYamlConfig :: (HasCallStack) => Parser a -> Parser a+withLocalYamlConfig p =+ withFrozenCallStack $+ withConfigurableYamlConfig (mapIO resolveFile' (pure "config.yaml")) p -- | Use the given 'Parser' for deciding which configuration file to load, but -- only if 'configuredConfigFile' fails to define it first.-withConfigurableYamlConfig :: Parser (Path Abs File) -> Parser a -> Parser a-withConfigurableYamlConfig p = withYamlConfig $ Just <$> (configuredConfigFile <|> p)+withConfigurableYamlConfig :: (HasCallStack) => Parser (Path Abs File) -> Parser a -> Parser a+withConfigurableYamlConfig pf pa =+ withFrozenCallStack $ withYamlConfig (Just <$> (configuredConfigFile <|> pf)) pa -- | A standard parser for defining which configuration file to load. -- -- This has no default value so you will have to combine it somehow.-configuredConfigFile :: Parser (Path Abs File)+configuredConfigFile :: (HasCallStack) => Parser (Path Abs File) configuredConfigFile = filePathSetting [ option,@@ -669,7 +711,9 @@ -- | Builders [Builder Bool] -> Parser Bool-yesNoSwitch defaultBool builders = withFrozenCallStack $ makeDoubleSwitch "" "no-" "[no-]" defaultBool builders+yesNoSwitch defaultBool builders =+ withFrozenCallStack $+ makeDoubleSwitch "" "no-" "[no-]" defaultBool builders -- | Define a setting for a 'Bool' with a given default value. --@@ -683,7 +727,9 @@ -- | Builders [Builder Bool] -> Parser Bool-enableDisableSwitch defaultBool builders = withFrozenCallStack $ makeDoubleSwitch "enable-" "disable-" "(enable|disable)-" defaultBool builders+enableDisableSwitch defaultBool builders =+ withFrozenCallStack $+ makeDoubleSwitch "enable-" "disable-" "(enable|disable)-" defaultBool builders makeDoubleSwitch :: (HasCallStack) =>@@ -881,8 +927,8 @@ ParserMany p -> ParserMany (go p) ParserAllOrNothing _ p -> ParserAllOrNothing Nothing (go p) ParserCheck _ forgivable f p -> ParserCheck Nothing forgivable f (go p)- ParserCommands mLoc cs -> ParserCommands mLoc $ map commandEraseSrcLocs cs- ParserWithConfig p1 p2 -> ParserWithConfig (go p1) (go p2)+ ParserCommands _ cs -> ParserCommands Nothing $ map commandEraseSrcLocs cs+ ParserWithConfig _ p1 p2 -> ParserWithConfig Nothing (go p1) (go p2) ParserSetting _ s -> ParserSetting Nothing s commandEraseSrcLocs :: Command a -> Command a@@ -918,7 +964,7 @@ ParserAllOrNothing mLoc p -> ParserAllOrNothing mLoc <$> go p ParserCheck mLoc forgivable f p -> ParserCheck mLoc forgivable f <$> go p ParserCommands mLoc cs -> ParserCommands mLoc <$> traverse (commandTraverseSetting func) cs- ParserWithConfig p1 p2 -> ParserWithConfig <$> go p1 <*> go p2+ ParserWithConfig mLoc p1 p2 -> ParserWithConfig mLoc <$> go p1 <*> go p2 ParserSetting mLoc s -> ParserSetting mLoc <$> func s {-# ANN commandTraverseSetting ("NOCOVER" :: String) #-}@@ -946,7 +992,7 @@ ParserAllOrNothing _ p -> go p -- TODO is this right? ParserCheck _ _ _ p -> go p ParserCommands _ cs -> S.unions $ map (go . commandParser) cs- ParserWithConfig p1 p2 -> S.union (go p1) (go p2)+ ParserWithConfig _ p1 p2 -> S.union (go p1) (go p2) -- The nothing part shouldn't happen but I don't know when it doesn't ParserSetting mLoc _ -> maybe S.empty (S.singleton . hashSrcLoc) mLoc
src/OptEnvConf/Run.hs view
@@ -14,6 +14,7 @@ import Autodocodec import Control.Arrow (left)+import Control.Monad import Control.Monad.Reader hiding (Reader, reader, runReader) import Control.Monad.State import Data.Aeson (parseJSON, (.:?))@@ -27,6 +28,7 @@ import Data.Maybe import Data.Set (Set) import qualified Data.Set as S+import qualified Data.Text as T import Data.Traversable import Data.Version import GHC.Stack (SrcLoc)@@ -38,6 +40,7 @@ import OptEnvConf.Error import OptEnvConf.Lint import OptEnvConf.NonDet+import OptEnvConf.Output import OptEnvConf.Parser import OptEnvConf.Reader import OptEnvConf.Setting@@ -102,8 +105,13 @@ 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@@ -111,8 +119,7 @@ case errOrResult of Left errs -> do tc <- getTerminalCapabilitiesFromHandle stderr- let f = if debugMode then id else eraseErrorSrcLocs- hPutChunksLocaleWith tc stderr $ renderErrors $ f errs+ hPutChunksLocaleWith tc stderr $ renderErrors errs exitFailure Right i -> case i of ShowHelp -> do@@ -134,12 +141,11 @@ 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+ stderrTc <- getTerminalCapabilitiesFromHandle stderr+ errOrSets <- runParserOn (Just stderrTc) 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+ hPutChunksLocaleWith stderrTc stderr $ renderErrors errs exitFailure Right _ -> do tc <- getTerminalCapabilitiesFromHandle stdout@@ -286,12 +292,14 @@ -- | Run a parser on given arguments and environment instead of getting them -- from the current process. runParserOn ::+ -- DebugMode+ Maybe TerminalCapabilities -> Parser a -> Args -> EnvMap -> Maybe JSON.Object -> IO (Either (NonEmpty ParseError) a)-runParserOn parser args envVars mConfig = do+runParserOn debugMode parser args envVars mConfig = do let ppState = PPState { ppStateArgs = args,@@ -300,12 +308,14 @@ let ppEnv = PPEnv { ppEnvEnv = envVars,- ppEnvConf = mConfig+ ppEnvConf = mConfig,+ ppEnvDebug = debugMode,+ ppEnvIndent = 0 } let go' = do result <- go parser leftoverArgs <- gets ppStateArgs- case argsLeftovers leftoverArgs of+ case recogniseLeftovers leftoverArgs of Nothing -> pure result Just leftovers -> ppError Nothing $ ParseErrorUnrecognised leftovers mTup <- runPPLazy go' ppState ppEnv@@ -318,7 +328,7 @@ -- TODO: Consider keeping around all errors? mNext <- runNonDetTLazy ns case mNext of- Nothing -> pure (Left firstErrors)+ Nothing -> pure $ Left $ (if isJust debugMode then id else eraseErrorSrcLocs) firstErrors Just ((eOR, _), ns') -> case eOR of Success a -> pure (Right a) Failure _ -> goNexts ns'@@ -328,205 +338,308 @@ Parser a -> PP a go = \case- ParserPure a -> pure a- ParserAp ff fa -> go ff <*> go fa- ParserEmpty mLoc -> ppError mLoc ParseErrorEmpty- ParserSelect fe ff -> select (go fe) (go ff)+ ParserPure a -> do+ debug [syntaxChunk "pure value"]+ pure a+ ParserAp ff fa -> do+ debug [syntaxChunk "Ap"]+ ppIndent $ go ff <*> go fa+ ParserEmpty mLoc -> do+ debug [syntaxChunk "Empty", ": ", mSrcLocChunk mLoc]+ ppError mLoc ParseErrorEmpty+ ParserSelect fe ff -> do+ debug [syntaxChunk "Select"]+ ppIndent $ select (go fe) (go ff) ParserAlt p1 p2 -> do- eor <- tryPP (go p1)- case eor of- Just a -> pure a- Nothing -> go p2+ debug [syntaxChunk "Alt"]+ ppIndent $ do+ debug ["Trying left side."]+ eor <- ppIndent $ tryPP (go p1)+ case eor of+ Just a -> do+ debug ["Left side succeeded."]+ pure a+ Nothing -> do+ debug ["Left side failed, trying right side."]+ ppIndent $ go p2 ParserMany p' -> do- eor <- tryPP $ go p'- case eor of- Nothing -> pure []- Just a -> do- as <- go (ParserMany p')- pure (a : as)+ debug [syntaxChunk "Many"]+ ppIndent $ do+ eor <- tryPP $ go p'+ case eor of+ Nothing -> pure []+ Just a -> do+ as <- go (ParserMany p')+ pure (a : as) ParserAllOrNothing mLoc p' -> do- e <- ask- s <- get- results <- liftIO $ runPP (go p') s e- (result, s') <- ppNonDetList results- put s'- case result of- Success a -> pure a- Failure errs -> do- if not $ all errorIsForgivable errs- then ppErrors' errs- else do- -- Settings available below- let settingsSet = parserSettingsSet p'- -- Settings that have been parsed- parsedSet <- gets ppStateParsedSettings- -- Settings that have been parsed below- let parsedSettingsSet = settingsSet `S.intersection` parsedSet- -- If any settings have been parsed below, and parsing still failed- -- (this is the case because we're in the failure branch)- -- with only forgivable errors- -- (this is the case because we're in the branch where that's been checked)- -- then this should be an unforgivable error.- if not (null parsedSettingsSet)- then ppErrors' $ errs <> (ParseError mLoc ParseErrorAllOrNothing :| [])- else ppErrors' errs+ debug [syntaxChunk "AllOrNothing", ": ", mSrcLocChunk mLoc]+ ppIndent $ do+ e <- ask+ s <- get+ results <- liftIO $ runPP (go p') s e+ (result, s') <- ppNonDetList results+ put s'+ case result of+ Success a -> pure a+ Failure errs -> do+ if not $ all errorIsForgivable errs+ then ppErrors' errs+ else do+ -- Settings available below+ let settingsSet = parserSettingsSet p'+ -- Settings that have been parsed+ parsedSet <- gets ppStateParsedSettings+ -- Settings that have been parsed below+ let parsedSettingsSet = settingsSet `S.intersection` parsedSet+ -- If any settings have been parsed below, and parsing still failed+ -- (this is the case because we're in the failure branch)+ -- with only forgivable errors+ -- (this is the case because we're in the branch where that's been checked)+ -- then this should be an unforgivable error.+ if not (null parsedSettingsSet)+ then ppErrors' $ errs <> (ParseError mLoc ParseErrorAllOrNothing :| [])+ else ppErrors' errs ParserCheck mLoc forgivable f p' -> do- a <- go p'- errOrB <- liftIO $ f a- case errOrB of- Left err -> ppError mLoc $ ParseErrorCheckFailed forgivable err- Right b -> pure b+ debug [syntaxChunk "Parser with check", ": ", mSrcLocChunk mLoc]+ ppIndent $ do+ debug ["parser"]+ a <- ppIndent $ go p'+ debug ["check"]+ ppIndent $ do+ errOrB <- liftIO $ f a+ case errOrB of+ Left err -> do+ debug ["failed, forgivable: ", chunk $ T.pack $ show forgivable]+ ppError mLoc $ ParseErrorCheckFailed forgivable err+ Right b -> do+ debug ["succeeded"]+ pure b ParserCommands mLoc cs -> do- mS <- ppArg- case mS of- Nothing -> ppError mLoc $ ParseErrorMissingCommand $ map commandArg cs- Just s -> case find ((== s) . commandArg) cs of- Nothing -> ppError mLoc $ ParseErrorUnrecognisedCommand s (map commandArg cs)- Just c -> go $ commandParser c- ParserWithConfig pc pa -> do- mNewConfig <- go pc- local (\e -> e {ppEnvConf = mNewConfig}) $ go pa+ debug [syntaxChunk "Commands", ": ", mSrcLocChunk mLoc]+ ppIndent $ do+ mS <- ppArg+ case mS of+ Nothing -> do+ debug ["No argument found for choosing a command."]+ ppError mLoc $ ParseErrorMissingCommand $ map commandArg cs+ Just s -> do+ case find ((== s) . commandArg) cs of+ Nothing -> do+ debug ["Argument found, but no matching command: ", chunk $ T.pack $ show s]+ ppError mLoc $ ParseErrorUnrecognisedCommand s (map commandArg cs)+ Just c -> do+ debug ["Set command to ", commandChunk (commandArg c)]+ go $ commandParser c+ ParserWithConfig mLoc pc pa -> do+ debug [syntaxChunk "WithConfig", ": ", mSrcLocChunk mLoc]+ ppIndent $ do+ debug ["loading config"]+ mNewConfig <- ppIndent $ go pc+ debug ["with loaded config"]+ ppIndent $+ local (\e -> e {ppEnvConf = mNewConfig}) $+ go pa ParserSetting mLoc set@Setting {..} -> do- let markParsed = do- maybe- (pure ())- ( \loc -> modify' $ \s ->- s- { ppStateParsedSettings =- S.insert- (hashSrcLoc loc)- (ppStateParsedSettings s)- }- )- mLoc- let mOptDoc = settingOptDoc set- mArg <-- if settingTryArgument- then do- -- Require readers before finding the argument so the parser- -- always fails if it's missing a reader.- rs <- requireReaders settingReaders- mS <- ppArg- case mS of- Nothing -> pure NotFound- Just argStr -> do- case tryReaders rs argStr of- Left errs -> ppError mLoc $ ParseErrorArgumentRead mOptDoc errs- Right a -> pure $ Found a- else pure NotRun-- case mArg of- Found a -> do- markParsed- pure a- _ -> do- -- TODO do this without all the nesting- mSwitch <- case settingSwitchValue of- Nothing -> pure NotRun- Just a -> do- mS <- ppSwitch settingDasheds+ debug [syntaxChunk "Setting", ": ", mSrcLocChunk mLoc]+ ppIndent $ do+ let markParsed = do+ maybe+ (pure ())+ ( \loc -> modify' $ \s ->+ s+ { ppStateParsedSettings =+ S.insert+ (hashSrcLoc loc)+ (ppStateParsedSettings s)+ }+ )+ mLoc+ let mOptDoc = settingOptDoc set+ mArg <-+ if settingTryArgument+ then do+ -- Require readers before finding the argument so the parser+ -- always fails if it's missing a reader.+ rs <- requireReaders settingReaders+ mS <- ppArg case mS of- Nothing -> pure NotFound- Just () -> pure $ Found a+ Nothing -> do+ debug ["could not set based on argument: no argument"]+ pure NotFound+ Just argStr -> do+ case tryReaders rs argStr of+ Left errs -> ppError mLoc $ ParseErrorArgumentRead mOptDoc errs+ Right a -> do+ debug+ [ "set based on argument: ",+ chunk $ T.pack $ show argStr+ ]+ pure $ Found a+ else pure NotRun - case mSwitch of- Found a -> do- markParsed- pure a- _ -> do- mOpt <-- if settingTryOption- then do- -- Require readers before finding the option so the parser- -- always fails if it's missing a reader.- rs <- requireReaders settingReaders- mS <- ppOpt settingDasheds- case mS of- Nothing -> pure NotFound- Just optionStr -> do- case tryReaders rs optionStr of- Left err -> ppError mLoc $ ParseErrorOptionRead mOptDoc err- Right a -> pure $ Found a- else pure NotRun+ case mArg of+ Found a -> do+ markParsed+ pure a+ _ -> do+ -- TODO do this without all the nesting+ mSwitch <- case settingSwitchValue of+ Nothing -> pure NotRun+ Just a -> do+ mS <- ppSwitch settingDasheds+ case mS of+ Nothing -> do+ debug+ [ "could not set based on switch, no switch: ",+ chunk $ T.pack $ show $ map renderDashed settingDasheds+ ]+ pure NotFound+ Just () -> do+ debug ["set based on switch."]+ pure $ Found a - case mOpt of- Found a -> do- markParsed- pure a- _ -> do- let mEnvDoc = settingEnvDoc set- mEnv <- case settingEnvVars of- Nothing -> pure NotRun- Just ne -> do- -- Require readers before finding the env vars so the parser+ case mSwitch of+ Found a -> do+ markParsed+ pure a+ _ -> do+ mOpt <-+ if settingTryOption+ then do+ -- Require readers before finding the option so the parser -- always fails if it's missing a reader. rs <- requireReaders settingReaders- es <- asks ppEnvEnv- let founds = mapMaybe (`EnvMap.lookup` es) (NE.toList ne)- -- Run the parser on all specified env vars before- -- returning the first because we want to fail if any- -- of them fail, even if they wouldn't be the parse- -- result.- results <- for founds $ \varStr ->- case tryReaders rs varStr of- Left errs -> ppError mLoc $ ParseErrorEnvRead mEnvDoc errs- Right a -> pure a- pure $ maybe NotFound Found $ listToMaybe results+ mS <- ppOpt settingDasheds+ case mS of+ Nothing -> do+ debug+ [ "could not set based on options, no option: ",+ chunk $ T.pack $ show $ map renderDashed settingDasheds+ ]+ pure NotFound+ Just optionStr -> do+ case tryReaders rs optionStr of+ Left err -> ppError mLoc $ ParseErrorOptionRead mOptDoc err+ Right a -> do+ debug+ [ "set based on option: ",+ chunk $ T.pack $ show optionStr+ ]+ pure $ Found a+ else pure NotRun - case mEnv of- Found a -> do- markParsed- pure a- _ -> do- let mConfDoc = settingConfDoc set- mConf <- case settingConfigVals of- Nothing -> pure NotRun- Just ((ne, DecodingCodec c) :| _) -> do- -- TODO try parsing with the others- mObj <- asks ppEnvConf- case mObj of- Nothing -> 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+ case mOpt of+ Found a -> do+ markParsed+ pure a+ _ -> do+ let mEnvDoc = settingEnvDoc set+ mEnv <- case settingEnvVars of+ Nothing -> pure NotRun+ Just ne -> do+ -- Require readers before finding the env vars so the parser+ -- always fails if it's missing a reader.+ rs <- requireReaders settingReaders+ es <- asks ppEnvEnv+ let founds = mapMaybe (`EnvMap.lookup` es) (NE.toList ne)+ -- Run the parser on all specified env vars before+ -- returning the first because we want to fail if any+ -- of them fail, even if they wouldn't be the parse+ -- result.+ results <- for founds $ \varStr ->+ case tryReaders rs varStr of+ Left errs -> ppError mLoc $ ParseErrorEnvRead mEnvDoc errs+ Right a -> do+ debug+ [ "set based on env: ",+ chunk $ T.pack $ show varStr+ ]+ pure a+ case listToMaybe results of+ Nothing -> do+ debug+ [ "could not set based on env vars, no var: ",+ chunk $ T.pack $ show $ maybe [] NE.toList settingEnvVars+ ]+ pure NotFound+ Just a -> pure $ Found a++ case mEnv of+ Found a -> do+ markParsed+ pure a+ _ -> do+ let mConfDoc = settingConfDoc set+ mConf <- case settingConfigVals of+ Nothing -> pure NotRun+ Just ((ne, DecodingCodec c) :| _) -> do+ -- TODO try parsing with the others+ 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) ne of+ Left err -> ppError mLoc $ ParseErrorConfigRead mConfDoc err+ Right mV -> case mV 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) ne of- Left err -> ppError mLoc $ ParseErrorConfigRead mConfDoc err- Right mV -> case mV of- Nothing -> pure NotFound- Just v -> case JSON.parseEither (parseJSONVia c) v of- Left err -> ppError mLoc $ ParseErrorConfigRead mConfDoc err- Right a -> pure $ maybe NotFound Found a+ debug+ [ "could not set based on config value, not configured: ",+ chunk $ T.pack $ show $ NE.toList ne+ ]+ pure NotFound+ Just v -> case JSON.parseEither (parseJSONVia c) 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 ne+ ]+ pure NotFound+ Just a -> do+ debug+ [ "set based on config value:",+ chunk $ T.pack $ show v+ ]+ pure $ Found a - case mConf of- Found a -> do- markParsed- pure a- _ ->- case settingDefaultValue of- Just (a, _) -> pure a -- Don't mark as parsed- Nothing -> do- let parseResultError e res = case res of- NotRun -> Nothing- NotFound -> Just e- Found _ -> Nothing -- Should not happen.- maybe (ppError mLoc ParseErrorEmptySetting) (ppErrors mLoc) $- NE.nonEmpty $- catMaybes- [ parseResultError (ParseErrorMissingArgument mOptDoc) mArg,- parseResultError (ParseErrorMissingSwitch mOptDoc) mSwitch,- parseResultError (ParseErrorMissingOption mOptDoc) mOpt,- parseResultError (ParseErrorMissingEnvVar mEnvDoc) mEnv,- parseResultError (ParseErrorMissingConfVal mConfDoc) mConf- ]+ case mConf of+ Found a -> do+ markParsed+ pure a+ _ ->+ case settingDefaultValue of+ Just (a, _) -> do+ debug ["set to default value"]+ pure a -- Don't mark as parsed+ Nothing -> do+ let parseResultError e res = case res of+ NotRun -> Nothing+ NotFound -> Just e+ Found _ -> Nothing -- Should not happen.+ debug ["not found"]+ maybe (ppError mLoc ParseErrorEmptySetting) (ppErrors mLoc) $+ NE.nonEmpty $+ catMaybes+ [ parseResultError (ParseErrorMissingArgument mOptDoc) mArg,+ parseResultError (ParseErrorMissingSwitch mOptDoc) mSwitch,+ parseResultError (ParseErrorMissingOption mOptDoc) mOpt,+ parseResultError (ParseErrorMissingEnvVar mEnvDoc) mEnv,+ parseResultError (ParseErrorMissingConfVal mConfDoc) mConf+ ] data ParseResult a = NotRun@@ -580,13 +693,15 @@ e <- ask results <- liftIO $ runPP pp s e (errOrRes, s') <- ppNonDetList results- put s' case errOrRes of Failure errs -> if all errorIsForgivable errs- then pure Nothing+ then do+ pure Nothing else ppErrors' errs- Success a -> pure $ Just a+ Success a -> do+ put s' -- Only set state if parsing succeeded.+ pure $ Just a ppNonDet :: NonDetT IO a -> PP a ppNonDet = lift . lift . lift@@ -601,14 +716,44 @@ data PPEnv = PPEnv { ppEnvEnv :: !EnvMap,- ppEnvConf :: !(Maybe JSON.Object)+ ppEnvConf :: !(Maybe JSON.Object),+ -- Nothing means "not debug mode"+ ppEnvDebug :: !(Maybe TerminalCapabilities),+ ppEnvIndent :: !Int } +debug :: [Chunk] -> PP ()+debug chunks = do+ debugMode <- asks ppEnvDebug+ forM_ debugMode $ \tc -> do+ i <- asks ppEnvIndent+ -- Debug mode needs to involve an impure print because parsers can run IO+ -- actions and we need to see their output interleaved with the debug+ -- output+ liftIO $+ hPutChunksLocaleWith tc stderr $+ (replicate i " " ++ chunks)+ ++ [ "\n"+ ]++ppIndent :: PP a -> PP a+ppIndent =+ local+ (\e -> e {ppEnvIndent = succ (ppEnvIndent e)})+ ppArg :: PP (Maybe String) ppArg = do args <- gets ppStateArgs+ debug ["Trying to consume an argument"] let consumePossibilities = Args.consumeArgument args- (mA, args') <- ppNonDetList consumePossibilities+ if null consumePossibilities+ then debug ["Found no consume possibilities."]+ else do+ debug ["Found these possibilities to consume an argument:"]+ forM_ consumePossibilities $ \p ->+ debug [chunk $ T.pack $ show p]+ p@(mA, args') <- ppNonDetList consumePossibilities+ debug ["Considering this posibility: ", chunk $ T.pack $ show p] modify' (\s -> s {ppStateArgs = args'}) pure mA