diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 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.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 diff --git a/src/OptEnvConf/Args.hs b/src/OptEnvConf/Args.hs --- a/src/OptEnvConf/Args.hs +++ b/src/OptEnvConf/Args.hs @@ -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 diff --git a/src/OptEnvConf/Completion.hs b/src/OptEnvConf/Completion.hs --- a/src/OptEnvConf/Completion.hs +++ b/src/OptEnvConf/Completion.hs @@ -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 [] diff --git a/src/OptEnvConf/Doc.hs b/src/OptEnvConf/Doc.hs --- a/src/OptEnvConf/Doc.hs +++ b/src/OptEnvConf/Doc.hs @@ -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 (" " :) diff --git a/src/OptEnvConf/Error.hs b/src/OptEnvConf/Error.hs --- a/src/OptEnvConf/Error.hs +++ b/src/OptEnvConf/Error.hs @@ -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 diff --git a/src/OptEnvConf/Lint.hs b/src/OptEnvConf/Lint.hs --- a/src/OptEnvConf/Lint.hs +++ b/src/OptEnvConf/Lint.hs @@ -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 diff --git a/src/OptEnvConf/Output.hs b/src/OptEnvConf/Output.hs new file mode 100644 --- /dev/null +++ b/src/OptEnvConf/Output.hs @@ -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 (" " :) diff --git a/src/OptEnvConf/Parser.hs b/src/OptEnvConf/Parser.hs --- a/src/OptEnvConf/Parser.hs +++ b/src/OptEnvConf/Parser.hs @@ -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 diff --git a/src/OptEnvConf/Run.hs b/src/OptEnvConf/Run.hs --- a/src/OptEnvConf/Run.hs +++ b/src/OptEnvConf/Run.hs @@ -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