diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,19 @@ # Changelog +## [0.5.0.0] - 2024-08-03 + +### Changed + +* Made `Builder`s contain a list of `BuildInstructions` so library functions + can pattern-match on the builders. +* `yesNoSwitch` and `enableDisableSwitch` now no longer take a default value, + but accept default `value` builders instead. +* Renamed 'viaCodec' to 'viaStringCodec'. +* Clearer lints when using `name`. +* Clearer lint about loading configuration. +* Default values are now shown at the end but before example values in documentation. +* Proper `[--optional-option-docs]` + ## [0.4.0.5] - 2024-07-28 ### Added diff --git a/opt-env-conf.cabal b/opt-env-conf.cabal --- a/opt-env-conf.cabal +++ b/opt-env-conf.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: opt-env-conf -version: 0.4.0.5 +version: 0.5.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 diff --git a/src/OptEnvConf/Doc.hs b/src/OptEnvConf/Doc.hs --- a/src/OptEnvConf/Doc.hs +++ b/src/OptEnvConf/Doc.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} @@ -42,7 +43,7 @@ import Autodocodec.Schema import Autodocodec.Yaml.Schema import Control.Monad -import Data.List (intersperse) +import Data.List (intercalate, intersperse) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import Data.Maybe @@ -103,17 +104,21 @@ | AnyDocsAnd ![AnyDocs a] | AnyDocsOr ![AnyDocs a] | AnyDocsSingle !a - deriving (Show) + deriving (Show, Functor) data CommandDoc a = CommandDoc { commandDocArgument :: String, commandDocHelp :: Help, commandDocs :: AnyDocs a } - deriving (Show) + deriving (Show, Functor) mapMaybeDocs :: (a -> Maybe b) -> AnyDocs a -> AnyDocs b -mapMaybeDocs func = simplifyAnyDocs . go +mapMaybeDocs func = simplifyAnyDocs . mapMaybeDocs' func + +-- Like mapMaybeDocs but without simplifying +mapMaybeDocs' :: (a -> Maybe b) -> AnyDocs a -> AnyDocs b +mapMaybeDocs' func = go where go = \case AnyDocsCommands cs -> AnyDocsCommands $ map goCommandDoc cs @@ -131,9 +136,7 @@ AnyDocsAnd ds -> case concatMap goAnd ds of [a] -> a as -> AnyDocsAnd as - AnyDocsOr ds -> case concatMap goOr ds of - [a] -> a - as -> AnyDocsOr as + AnyDocsOr ds -> AnyDocsOr $ concatMap goOr ds AnyDocsSingle v -> AnyDocsSingle v goDoc cd = cd {commandDocs = go (commandDocs cd)} @@ -151,26 +154,27 @@ ds -> [go ds] -- | Derive parser documentation -parserDocs :: Parser a -> AnyDocs SetDoc +-- +-- API Note: We return a Maybe inside the AnyDocs so that we can keep track of hidden settings and use this information to know whether settings are optional or not. +parserDocs :: Parser a -> AnyDocs (Maybe SetDoc) parserDocs = simplifyAnyDocs . go where - noDocs = AnyDocsAnd [] - go :: Parser a -> AnyDocs SetDoc + go :: Parser a -> AnyDocs (Maybe SetDoc) go = \case - ParserPure _ -> noDocs + ParserPure _ -> AnyDocsSingle Nothing ParserAp pf pa -> AnyDocsAnd [go pf, go pa] ParserSelect p1 p2 -> AnyDocsAnd [go p1, go p2] ParserEmpty _ -> AnyDocsOr [] ParserAlt p1 p2 -> AnyDocsOr [go p1, go p2] - ParserMany p -> go p -- TODO: is this right? - ParserSome p -> go p -- TODO: is this right? + ParserMany p -> AnyDocsOr [go p, AnyDocsSingle Nothing] + ParserSome p -> AnyDocsAnd [go p, go (ParserMany p)] -- TODO: is this right? ParserAllOrNothing _ p -> go p ParserCheck _ _ _ p -> go p ParserCommands _ cs -> AnyDocsCommands $ map commandParserDocs 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? - ParserSetting _ set -> maybe noDocs AnyDocsSingle $ settingSetDoc set + ParserSetting _ set -> AnyDocsSingle $ settingSetDoc set -commandParserDocs :: Command a -> CommandDoc SetDoc +commandParserDocs :: Command a -> CommandDoc (Maybe SetDoc) commandParserDocs Command {..} = CommandDoc { commandDocArgument = commandArg, @@ -178,6 +182,9 @@ commandDocs = parserDocs commandParser } +withoutHiddenDocs :: AnyDocs (Maybe a) -> AnyDocs a +withoutHiddenDocs = mapMaybeDocs id + settingSetDoc :: Setting a -> Maybe SetDoc settingSetDoc Setting {..} = do guard $ not settingHidden @@ -215,13 +222,7 @@ renderSetDocWithoutHeader :: SetDoc -> [[Chunk]] renderSetDocWithoutHeader SetDoc {..} = concat - [ [ defaultValueChunks dv - | dv <- maybeToList setDocDefault - ], - [ exampleValuesChunks setDocExamples - | not (null setDocExamples) - ], - [ unwordsChunks + [ [ unwordsChunks [ ["argument:"], [mMetavarChunk setDocMetavar] ] @@ -267,7 +268,13 @@ ) (NE.toList confs) | confs <- maybeToList setDocConfKeys - ] + ], + [ defaultValueChunks dv + | dv <- maybeToList setDocDefault + ], + [ exampleValuesChunks setDocExamples + | not (null setDocExamples) + ] ] helpLines :: Help -> [[Chunk]] @@ -281,10 +288,11 @@ String -> Version -> String -> - AnyDocs SetDoc -> + AnyDocs (Maybe SetDoc) -> [Chunk] -renderManPage progname version progDesc docs = - let optDocs = docsToOptDocs docs +renderManPage progname version progDesc docs' = + let docs = withHelpAndVersionDocs (Just version) docs' + optDocs = docsToOptDocs docs envDocs = docsToEnvDocs docs confDocs = docsToConfDocs docs commandDocs = docsToCommandDocs docs @@ -304,7 +312,7 @@ [".Sh ", "VERSION"], [versionChunk version], [".Sh ", "SYNOPSIS"], - renderShortOptDocs progname optDocs, + renderShortOptDocs progname $ docsToOptDocs docs', [".Sh ", "SETTINGS"], renderSetDocs docs ], @@ -335,15 +343,16 @@ ] -- | Render reference documentation -renderReferenceDocumentation :: String -> AnyDocs SetDoc -> [Chunk] -renderReferenceDocumentation progname docs = - let optDocs = docsToOptDocs docs +renderReferenceDocumentation :: String -> AnyDocs (Maybe SetDoc) -> [Chunk] +renderReferenceDocumentation progname docs' = + let docs = withHelpAndVersionDocs Nothing docs' + optDocs = docsToOptDocs docs envDocs = docsToEnvDocs docs confDocs = docsToConfDocs docs commandDocs = docsToCommandDocs docs in unlinesChunks $ concat - [ [ usageChunk : renderShortOptDocs progname optDocs, + [ [ usageChunk : renderShortOptDocs progname (docsToOptDocs docs'), [], headerChunks "All settings", renderSetDocs docs @@ -395,21 +404,36 @@ ["\n"] ] --- | Render the output of @--help@ -renderHelpPage :: String -> String -> AnyDocs SetDoc -> [Chunk] -renderHelpPage progname progDesc docs = +-- | Render the output of top-level @--help@ +renderHelpPage :: String -> Version -> String -> AnyDocs (Maybe SetDoc) -> [Chunk] +renderHelpPage progname version = + renderHelpPageHelper progname [] (Just version) + +-- | Render the output of a @--help@ with at least one command +renderCommandHelpPage :: String -> [String] -> CommandDoc (Maybe SetDoc) -> [Chunk] +renderCommandHelpPage progname commandPath CommandDoc {..} = + renderHelpPageHelper + progname + (commandPath ++ [commandDocArgument]) + Nothing + commandDocHelp + commandDocs + +renderHelpPageHelper :: String -> [String] -> Maybe Version -> String -> AnyDocs (Maybe SetDoc) -> [Chunk] +renderHelpPageHelper progname' commandPath mVersion progDesc docs = unlinesChunks $ concat - [ [ usageChunk : renderShortOptDocs progname (docsToOptDocs docs), + [ [ let progname = unwords $ progname' : commandPath + in usageChunk : renderShortOptDocs progname (docsToOptDocs docs), [], unlinesChunks $ progDescLines progDesc ], - concat - [ [ headerChunks "Available settings", - renderSetDocs docs - ] - | not (nullDocs docs) - ], + [ headerChunks "Available settings", + renderSetDocs $ + if null commandPath + then withHelpAndVersionDocs mVersion docs + else withHelpDocs docs + ], concat [ [ headerChunks "Available commands", renderCommandDocsShort docs @@ -418,37 +442,63 @@ ] ] -renderCommandHelpPage :: String -> [String] -> CommandDoc SetDoc -> [Chunk] -renderCommandHelpPage progname commandPath CommandDoc {..} = - renderHelpPage (unwords $ progname : commandPath ++ [commandDocArgument]) commandDocHelp commandDocs +withHelpAndVersionDocs :: Maybe Version -> AnyDocs (Maybe SetDoc) -> AnyDocs (Maybe SetDoc) +withHelpAndVersionDocs mVersion sd = simplifyAnyDocs $ AnyDocsOr [helpDocs, versionDocs mVersion, sd] -renderSetDocs :: AnyDocs SetDoc -> [Chunk] -renderSetDocs = unlinesChunks . go +withHelpDocs :: AnyDocs (Maybe SetDoc) -> AnyDocs (Maybe SetDoc) +withHelpDocs sd = simplifyAnyDocs $ AnyDocsOr [helpDocs, sd] + +helpDocs :: AnyDocs (Maybe SetDoc) +helpDocs = + AnyDocsSingle $ + Just + SetDoc + { setDocTryArgument = False, + setDocTrySwitch = True, + setDocTryOption = False, + setDocDasheds = ["-h", "--help"], + setDocEnvVars = Nothing, + setDocConfKeys = Nothing, + setDocDefault = Nothing, + setDocExamples = [], + setDocMetavar = Nothing, + setDocHelp = Just "Show this help text" + } + +versionDocs :: Maybe Version -> AnyDocs (Maybe SetDoc) +versionDocs mVersion = + AnyDocsSingle $ + Just + SetDoc + { setDocTryArgument = False, + setDocTrySwitch = True, + setDocTryOption = False, + setDocDasheds = ["--version"], + setDocEnvVars = Nothing, + setDocConfKeys = Nothing, + setDocDefault = Nothing, + setDocExamples = [], + setDocMetavar = Nothing, + setDocHelp = Just $ case mVersion of + Nothing -> "Output version information" + Just version -> "Output version information: " <> showVersion version + } + +renderSetDocs :: AnyDocs (Maybe SetDoc) -> [Chunk] +renderSetDocs = unlinesChunks . intercalate [[]] . go . combineSetDocs . withoutHiddenDocs where - go :: AnyDocs SetDoc -> [[Chunk]] + -- One section each, so we can add empty lines inbetween + go :: AnyDocs (NonEmpty SetDoc) -> [[[Chunk]]] go = \case AnyDocsCommands _ -> [] AnyDocsAnd ds -> concatMap go ds - AnyDocsOr ds -> goOr ds - AnyDocsSingle d -> indent (renderSetDoc d) - - -- Group together settings with the same help (produced by combinators like enableDisableSwitch) - goOr :: [AnyDocs SetDoc] -> [[Chunk]] - goOr = \case - [] -> [] - [d] -> go d - (AnyDocsSingle d : ds) -> - case setDocHelp d of - Nothing -> go (AnyDocsSingle d) ++ goOr ds - Just h -> - let (sds, rest) = goSameHelp h ds - in concat - [ indent $ renderSetDocHeader (Just h), - indent $ concatMap renderSetDocWithoutHeader $ d : sds, - [[] | not (null rest)], - goOr rest - ] - (d : ds) -> go d ++ goOr ds + AnyDocsOr ds -> concatMap go ds + AnyDocsSingle (d :| ds) -> + [ concat + [ indent $ renderSetDocHeader (setDocHelp d), + indent $ concatMap renderSetDocWithoutHeader (d : ds) + ] + ] goSameHelp :: Help -> [AnyDocs SetDoc] -> ([SetDoc], [AnyDocs SetDoc]) goSameHelp h = \case @@ -461,8 +511,31 @@ else ([], AnyDocsSingle d : ds) ds -> ([], ds) -renderCommandDocs :: AnyDocs SetDoc -> [Chunk] -renderCommandDocs = unlinesChunks . go True + -- Group together settings with the same help (produced by combinators like enableDisableSwitch) + combineSetDocs :: AnyDocs SetDoc -> AnyDocs (NonEmpty SetDoc) + combineSetDocs = go' + where + go' :: AnyDocs SetDoc -> AnyDocs (NonEmpty SetDoc) + go' = \case + AnyDocsCommands _ -> AnyDocsCommands [] -- Don't care about commands here + AnyDocsOr ds -> AnyDocsOr $ goOr' ds + AnyDocsAnd ds -> AnyDocsAnd $ map go' ds + AnyDocsSingle d -> AnyDocsSingle (d :| []) + goOr' :: [AnyDocs SetDoc] -> [AnyDocs (NonEmpty SetDoc)] + goOr' = \case + [] -> [] + [d] -> [go' d] + (AnyDocsSingle d : ds) -> + case setDocHelp d of + Nothing -> go' (AnyDocsSingle d) : goOr' ds + Just h -> + let (sds, rest) = goSameHelp h ds + ne = d :| sds + in AnyDocsSingle ne : goOr' rest + (d : ds) -> go' d : goOr' ds + +renderCommandDocs :: AnyDocs (Maybe SetDoc) -> [Chunk] +renderCommandDocs = unlinesChunks . go True . withoutHiddenDocs where go :: Bool -> AnyDocs SetDoc -> [[Chunk]] go isTopLevel = \case @@ -514,8 +587,8 @@ else ([], AnyDocsSingle d : ds) ds -> ([], ds) -renderCommandDocsShort :: AnyDocs SetDoc -> [Chunk] -renderCommandDocsShort = layoutAsTable . go +renderCommandDocsShort :: AnyDocs (Maybe SetDoc) -> [Chunk] +renderCommandDocsShort = layoutAsTable . go . withoutHiddenDocs where go :: AnyDocs SetDoc -> [[[Chunk]]] go = \case @@ -528,11 +601,11 @@ goCommand CommandDoc {..} = [indent [[commandChunk commandDocArgument], [helpChunk commandDocHelp]]] -parserOptDocs :: Parser a -> AnyDocs OptDoc +parserOptDocs :: Parser a -> AnyDocs (Maybe OptDoc) parserOptDocs = docsToOptDocs . parserDocs -docsToOptDocs :: AnyDocs SetDoc -> AnyDocs OptDoc -docsToOptDocs = mapMaybeDocs setDocOptDoc +docsToOptDocs :: AnyDocs (Maybe SetDoc) -> AnyDocs (Maybe OptDoc) +docsToOptDocs = mapMaybeDocs (>>= Just . setDocOptDoc) setDocOptDoc :: SetDoc -> Maybe OptDoc setDocOptDoc SetDoc {..} = do @@ -548,47 +621,64 @@ pure OptDoc {..} -- | Render short-form documentation of options -renderShortOptDocs :: String -> AnyDocs OptDoc -> [Chunk] -renderShortOptDocs progname = unwordsChunks . (\cs -> [[progNameChunk progname], cs]) . go +renderShortOptDocs :: String -> AnyDocs (Maybe OptDoc) -> [Chunk] +renderShortOptDocs progname = unwordsChunks . (\cs -> [[progNameChunk progname], cs]) . fromMaybe [] . go False where - go :: AnyDocs OptDoc -> [Chunk] - go = \case - AnyDocsCommands _ -> ["COMMAND"] - AnyDocsAnd ds -> unwordsChunks $ map go ds - AnyDocsOr ds -> renderOrChunks $ map go ds - AnyDocsSingle OptDoc {..} -> - unwordsChunks $ - concat - [ [ [mMetavarChunk optDocMetavar] - | optDocTryArgument - ], - [ concat $ maybeToList $ dashedChunks optDocDasheds - | optDocTrySwitch - ], - [ concat - [ concat $ maybeToList $ dashedChunks optDocDasheds, - [" ", mMetavarChunk optDocMetavar] + withoutNothings = + filter + ( \case + AnyDocsSingle Nothing -> False + AnyDocsAnd [] -> False + AnyDocsOr [] -> False + _ -> True + ) + go :: + -- Need parens + Bool -> + AnyDocs (Maybe OptDoc) -> + Maybe [Chunk] + go b = + \case + AnyDocsCommands _ -> Just ["COMMAND"] + AnyDocsAnd ds -> + case mapMaybe (go False) (withoutNothings ds) of + [] -> Nothing + [c] -> Just c + cs -> Just $ (if b then parenthesise else id) $ unwordsChunks cs + AnyDocsOr ds -> + case mapMaybe (go False) (withoutNothings ds) of + [] -> Nothing + cs -> Just $ bracketise $ unwordsChunks $ intersperse [orChunk] cs + AnyDocsSingle mOd -> case mOd of + Nothing -> Nothing + Just OptDoc {..} -> + Just + $ ( if isJust optDocDefault + then bracketise + else id + ) + $ unwordsChunks + $ concat + [ [ [mMetavarChunk optDocMetavar] + | optDocTryArgument + ], + [ concat $ maybeToList $ dashedChunks optDocDasheds + | optDocTrySwitch + ], + [ concat + [ concat $ maybeToList $ dashedChunks optDocDasheds, + [" ", mMetavarChunk optDocMetavar] + ] + | optDocTryOption ] - | optDocTryOption - ] - ] - -renderOrChunks :: [[Chunk]] -> [Chunk] -renderOrChunks os = - unwordsChunks $ - intersperse [orChunk] $ - map parenthesise os - where - parenthesise :: [Chunk] -> [Chunk] - parenthesise [c] = [c] - parenthesise cs = fore cyan "(" : cs ++ [fore cyan ")"] + ] orChunk :: Chunk orChunk = fore cyan "|" -- | Render long-form documentation of options -renderLongOptDocs :: AnyDocs OptDoc -> [Chunk] -renderLongOptDocs = unlinesChunks . go +renderLongOptDocs :: AnyDocs (Maybe OptDoc) -> [Chunk] +renderLongOptDocs = unlinesChunks . go . withoutHiddenDocs where go :: AnyDocs OptDoc -> [[Chunk]] go = \case @@ -635,8 +725,8 @@ parserEnvDocs :: Parser a -> AnyDocs EnvDoc parserEnvDocs = docsToEnvDocs . parserDocs -docsToEnvDocs :: AnyDocs SetDoc -> AnyDocs EnvDoc -docsToEnvDocs = mapMaybeDocs setDocEnvDoc +docsToEnvDocs :: AnyDocs (Maybe SetDoc) -> AnyDocs EnvDoc +docsToEnvDocs = mapMaybeDocs (>>= setDocEnvDoc) setDocEnvDoc :: SetDoc -> Maybe EnvDoc setDocEnvDoc SetDoc {..} = do @@ -678,8 +768,8 @@ parserConfDocs :: Parser a -> AnyDocs ConfDoc parserConfDocs = docsToConfDocs . parserDocs -docsToConfDocs :: AnyDocs SetDoc -> AnyDocs ConfDoc -docsToConfDocs = mapMaybeDocs setDocConfDoc +docsToConfDocs :: AnyDocs (Maybe SetDoc) -> AnyDocs ConfDoc +docsToConfDocs = mapMaybeDocs (>>= setDocConfDoc) setDocConfDoc :: SetDoc -> Maybe ConfDoc setDocConfDoc SetDoc {..} = do @@ -692,7 +782,7 @@ settingConfDoc :: Setting a -> Maybe ConfDoc settingConfDoc = settingSetDoc >=> setDocConfDoc -docsToCommandDocs :: AnyDocs SetDoc -> [CommandDoc SetDoc] +docsToCommandDocs :: AnyDocs (Maybe SetDoc) -> [CommandDoc (Maybe SetDoc)] docsToCommandDocs = \case AnyDocsCommands cs -> cs AnyDocsAnd ds -> concatMap docsToCommandDocs ds diff --git a/src/OptEnvConf/Lint.hs b/src/OptEnvConf/Lint.hs --- a/src/OptEnvConf/Lint.hs +++ b/src/OptEnvConf/Lint.hs @@ -131,6 +131,8 @@ ] LintErrorNoReaderForOption -> [ [ functionChunk "option", + " or ", + functionChunk "name", " has no ", functionChunk "reader", "." @@ -147,6 +149,8 @@ ] LintErrorNoMetavarForOption -> [ [ functionChunk "option", + " or ", + functionChunk "name", " has no ", functionChunk "metavar", "." @@ -174,6 +178,8 @@ ] LintErrorNoReaderForEnvVar -> [ [ functionChunk "env", + " or ", + functionChunk "name", " has no ", functionChunk "reader", "." @@ -181,6 +187,8 @@ ] LintErrorNoMetavarForEnvVar -> [ [ functionChunk "env", + " or ", + functionChunk "name", " has no ", functionChunk "metavar", "." @@ -201,7 +209,15 @@ ] LintErrorConfigWithoutLoad -> [ [ functionChunk "conf", + " or ", + functionChunk "name", " was called with no way to load configuration." + ], + [ "You can load configuration with ", + functionChunk "withConfig", + ", or explicitly not load any configuration with ", + functionChunk "withoutConfig", + "." ] ] LintErrorManyInfinite -> diff --git a/src/OptEnvConf/Output.hs b/src/OptEnvConf/Output.hs --- a/src/OptEnvConf/Output.hs +++ b/src/OptEnvConf/Output.hs @@ -85,3 +85,11 @@ indent :: [[Chunk]] -> [[Chunk]] indent = map (" " :) + +parenthesise :: [Chunk] -> [Chunk] +parenthesise [c] = [c] +parenthesise cs = fore cyan "(" : cs ++ [fore cyan ")"] + +bracketise :: [Chunk] -> [Chunk] +bracketise [c] = [fore cyan "[", c, fore cyan "]"] +bracketise cs = fore cyan "[" : cs ++ [fore cyan "]"] diff --git a/src/OptEnvConf/Parser.hs b/src/OptEnvConf/Parser.hs --- a/src/OptEnvConf/Parser.hs +++ b/src/OptEnvConf/Parser.hs @@ -728,35 +728,33 @@ -- | Define a setting for a 'Bool' with a given default value. -- --- If you pass in `long` values, it will have @--foobar@ and @--no-foobar@ switches. --- If you pass in `env` values, it will read those environment variables too. --- If you pass in `conf` values, it will read those configuration values too. +-- If you pass in 'long' values, it will have @--foobar@ and @--no-foobar@ switches. +-- If you pass in 'env' values, it will read those environment variables too. +-- If you pass in 'conf' values, it will read those configuration values too. +-- If you pass in a 'value' value, it will use that as the default value. yesNoSwitch :: (HasCallStack) => - -- | Default value - Bool -> -- | Builders [Builder Bool] -> Parser Bool -yesNoSwitch defaultBool builders = +yesNoSwitch builders = withFrozenCallStack $ - makeDoubleSwitch "" "no-" "[no-]" defaultBool builders + makeDoubleSwitch "" "no-" "[no-]" builders -- | Define a setting for a 'Bool' with a given default value. -- --- If you pass in `long` values, it will have @--enable-foobar@ and @--disable-foobar@ switches. --- If you pass in `env` values, it will read those environment variables too. --- If you pass in `conf` values, it will read those configuration values too. +-- If you pass in 'long' values, it will have @--enable-foobar@ and @--disable-foobar@ switches. +-- If you pass in 'env' values, it will read those environment variables too. +-- If you pass in 'conf' values, it will read those configuration values too. +-- If you pass in a 'value' value, it will use that as the default value. enableDisableSwitch :: (HasCallStack) => - -- | Default value - Bool -> -- | Builders [Builder Bool] -> Parser Bool -enableDisableSwitch defaultBool builders = +enableDisableSwitch builders = withFrozenCallStack $ - makeDoubleSwitch "enable-" "disable-" "(enable|disable)-" defaultBool builders + makeDoubleSwitch "enable-" "disable-" "(enable|disable)-" builders makeDoubleSwitch :: (HasCallStack) => @@ -766,12 +764,10 @@ String -> -- | Prefix for the documented 'long's String -> - -- | Default nvnalue - Bool -> -- | Builders [Builder Bool] -> Parser Bool -makeDoubleSwitch truePrefix falsePrefix helpPrefix defaultBool builders = +makeDoubleSwitch truePrefix falsePrefix helpPrefix builders = withFrozenCallStack $ choice $ catMaybes @@ -780,11 +776,16 @@ Just parseEnableSwitch, parseEnv, parseConfigVal, - Just $ pure defaultBool + parseDefaultVal ] where - s = buildSetting builders mLoc = snd <$> listToMaybe (getCallStack callStack) + s = buildSetting builders + parseDefaultVal :: Maybe (Parser Bool) + parseDefaultVal = do + (dv, _) <- settingDefaultValue s + pure $ pure dv + parseEnableSwitch :: Parser Bool parseEnableSwitch = ParserSetting mLoc $ @@ -865,7 +866,7 @@ { settingDasheds = mapMaybe (prefixDashedLong helpPrefix) (settingDasheds s), settingReaders = [], settingTryArgument = False, - settingSwitchValue = Just defaultBool, -- Unused + settingSwitchValue = Just True, -- Unused settingTryOption = False, settingEnvVars = Nothing, settingConfigVals = Nothing, diff --git a/src/OptEnvConf/Reader.hs b/src/OptEnvConf/Reader.hs --- a/src/OptEnvConf/Reader.hs +++ b/src/OptEnvConf/Reader.hs @@ -12,7 +12,7 @@ str, auto, exists, - viaCodec, + viaStringCodec, -- * Constructing your own reader maybeReader, @@ -88,8 +88,9 @@ exists :: Reader Bool exists = Reader $ const $ pure True -viaCodec :: (HasCodec a) => Reader a -viaCodec = eitherReader $ parseEither $ parseJSONViaCodec . JSON.String . T.pack +-- | Read a value as if it were specified as a 'String' and parsed via the given 'Codec'. +viaStringCodec :: (HasCodec a) => Reader a +viaStringCodec = eitherReader $ parseEither $ parseJSONViaCodec . JSON.String . T.pack -- | Turn a 'Maybe' parsing function into a 'Reader' maybeReader :: (String -> Maybe a) -> Reader a diff --git a/src/OptEnvConf/Run.hs b/src/OptEnvConf/Run.hs --- a/src/OptEnvConf/Run.hs +++ b/src/OptEnvConf/Run.hs @@ -105,8 +105,7 @@ hPutChunksLocaleWith tc stderr $ renderLintErrors errs exitFailure Nothing -> do - let p' = internalParser version p - let docs = parserDocs p' + let docs = parserDocs p mDebugMode <- if debugMode @@ -130,7 +129,7 @@ Right mCommandDoc -> do tc <- getTerminalCapabilitiesFromHandle stdout hPutChunksLocaleWith tc stdout $ case mCommandDoc of - Nothing -> renderHelpPage progname progDesc docs + Nothing -> renderHelpPage progname version progDesc docs Just (path, cDoc) -> renderCommandHelpPage progname path cDoc exitSuccess else do @@ -152,6 +151,7 @@ hPutChunksLocaleWith tc stdout ["Settings parsed successfully."] exitSuccess else do + let p' = internalParser p errOrResult <- runParserOn mDebugMode @@ -165,7 +165,6 @@ hPutChunksLocaleWith tc stderr $ renderErrors errs exitFailure Right i -> case i of - ShowHelp -> die "unreachable, this option is only here for documentation." ShowVersion -> do progname <- getProgName tc <- getTerminalCapabilitiesFromHandle stdout @@ -204,8 +203,7 @@ -- Internal structure to help us do what the framework -- is supposed to. data Internal a - = ShowHelp - | ShowVersion + = ShowVersion | RenderMan | RenderDocumentation | RenderNixosOptions @@ -221,19 +219,13 @@ ![String] | ParsedNormally !a -internalParser :: Version -> Parser a -> Parser (Internal a) -internalParser version p = +internalParser :: Parser a -> Parser (Internal a) +internalParser p = choice [ setting - [ switch ShowHelp, - short 'h', - long "help", - help "Show this help text" - ], - setting [ switch ShowVersion, long "version", - help $ "Output version information: " <> showVersion version + hidden ], setting [ switch RenderMan, @@ -653,7 +645,7 @@ pure Nothing Just a -> do debug - [ "set based on config value:", + [ "set based on config value: ", chunk $ T.pack $ show v ] pure $ Just a @@ -721,7 +713,7 @@ Maybe TerminalCapabilities -> Args -> Parser a -> - IO (Either (NonEmpty ParseError) (Maybe ([String], CommandDoc SetDoc))) + IO (Either (NonEmpty ParseError) (Maybe ([String], CommandDoc (Maybe SetDoc)))) runHelpParser mDebugMode args parser = do let ppState = PPState @@ -743,9 +735,9 @@ Success mDocs -> Right mDocs where -- We try to parse the commands as deep as possible and ignore everything else. - go' :: [String] -> Parser a -> PP (Maybe ([String], CommandDoc SetDoc)) + go' :: [String] -> Parser a -> PP (Maybe ([String], CommandDoc (Maybe SetDoc))) go' path = - let go :: Parser a -> PP (Maybe ([String], CommandDoc SetDoc)) + let go :: Parser a -> PP (Maybe ([String], CommandDoc (Maybe SetDoc))) go = go' path in \case ParserPure _ -> do diff --git a/src/OptEnvConf/Setting.hs b/src/OptEnvConf/Setting.hs --- a/src/OptEnvConf/Setting.hs +++ b/src/OptEnvConf/Setting.hs @@ -30,6 +30,7 @@ shownExample, hidden, Builder (..), + BuildInstruction (..), -- * Internal showSettingABit, @@ -44,6 +45,7 @@ import Autodocodec import Data.List.NonEmpty (NonEmpty (..), (<|)) import qualified Data.List.NonEmpty as NE +import Data.Maybe import OptEnvConf.Args (Dashed (..)) import OptEnvConf.Casing import OptEnvConf.Reader @@ -156,30 +158,64 @@ . showListWith func as -- | Builder for a 'Setting' -newtype Builder a = Builder {unBuilder :: Setting a -> Setting a} +newtype Builder a = Builder {unBuilder :: [BuildInstruction a]} +data BuildInstruction a + = BuildAddHelp !String + | BuildSetMetavar !String + | BuildTryArgument + | BuildTryOption + | BuildSetSwitchValue !a + | BuildAddReader !(Reader a) + | BuildAddLong !(NonEmpty Char) + | BuildAddShort !Char + | BuildAddEnv !String + | BuildAddConf !(ConfigValSetting a) + | BuildSetDefault !a !String + | BuildAddExample !String + | BuildSetHidden + +applyBuildInstructions :: [BuildInstruction a] -> Setting a -> Setting a +applyBuildInstructions is s = foldr applyBuildInstruction s is + +applyBuildInstruction :: BuildInstruction a -> Setting a -> Setting a +applyBuildInstruction bi s = case bi of + BuildAddHelp h -> s {settingHelp = Just $ maybe h (<> h) (settingHelp s)} + BuildSetMetavar mv -> s {settingMetavar = Just mv} + BuildTryArgument -> s {settingTryArgument = True} + BuildTryOption -> s {settingTryOption = True} + BuildSetSwitchValue a -> s {settingSwitchValue = Just a} + BuildAddReader r -> s {settingReaders = r : settingReaders s} + BuildAddLong l -> s {settingDasheds = DashedLong l : settingDasheds s} + BuildAddShort c -> s {settingDasheds = DashedShort c : settingDasheds s} + BuildAddEnv v -> s {settingEnvVars = Just $ maybe (v :| []) (v <|) $ settingEnvVars s} + BuildAddConf t -> s {settingConfigVals = Just $ maybe (t :| []) (t <|) $ settingConfigVals s} + BuildSetDefault a shown -> s {settingDefaultValue = Just (a, shown)} + BuildAddExample e -> s {settingExamples = e : settingExamples s} + BuildSetHidden -> s {settingHidden = True} + instance Semigroup (Builder f) where - (<>) (Builder f1) (Builder f2) = Builder (f1 . f2) + (<>) (Builder f1) (Builder f2) = Builder (f1 <> f2) instance Monoid (Builder f) where - mempty = Builder id + mempty = Builder [] mappend = (<>) -- | Complete a 'Builder' into a 'Setting' completeBuilder :: Builder a -> Setting a -completeBuilder b = unBuilder b emptySetting +completeBuilder b = applyBuildInstructions (unBuilder b) emptySetting -- | Document a setting -- -- Multiple 'help's concatenate help on new lines. help :: String -> Builder a -help s = Builder $ \op -> op {settingHelp = Just $ maybe s (s <>) (settingHelp op)} +help s = Builder [BuildAddHelp s] -- | Document an 'option' or 'env' var. -- -- Multiple 'metavar's override eachother. metavar :: String -> Builder a -metavar mv = Builder $ \s -> s {settingMetavar = Just mv} +metavar mv = Builder [BuildSetMetavar mv] -- | Try to parse an argument. -- @@ -187,7 +223,7 @@ -- -- Multiple 'argument's are redundant. argument :: Builder a -argument = Builder $ \s -> s {settingTryArgument = True} +argument = Builder [BuildTryArgument] -- | Try to parse an argument. -- @@ -196,7 +232,7 @@ -- -- Multiple 'option's are redundant. option :: Builder a -option = Builder $ \s -> s {settingTryOption = True} +option = Builder [BuildTryOption] -- | Try to parse a switch, activate the given value when succesful -- @@ -204,11 +240,11 @@ -- -- Multiple 'switch's override eachother. switch :: a -> Builder a -switch v = Builder $ \s -> s {settingSwitchValue = Just v} +switch v = Builder [BuildSetSwitchValue v] -- | Declare how to parse an argument, option, or environment variable. reader :: Reader a -> Builder a -reader r = Builder $ \s -> s {settingReaders = r : settingReaders s} +reader r = Builder [BuildAddReader r] -- | Try to parse this 'long' 'option' or 'switch'. -- @@ -221,9 +257,7 @@ -- Multiple 'long's will be tried in order. -- Empty 'long's will be ignored. long :: String -> Builder a -long l = Builder $ \s -> case NE.nonEmpty l of - Nothing -> s - Just ne -> s {settingDasheds = DashedLong ne : settingDasheds s} +long l = Builder [BuildAddLong ne | ne <- maybeToList (NE.nonEmpty l)] -- | Try to parse this 'short' 'option' or 'switch'. -- @@ -234,7 +268,7 @@ -- -- Multiple 'short's will be tried in order. short :: Char -> Builder a -short c = Builder $ \s -> s {settingDasheds = DashedShort c : settingDasheds s} +short c = Builder [BuildAddShort c] -- | Try to parse an environment variable. -- @@ -242,7 +276,7 @@ -- -- Multiple 'env's will be tried in order. env :: String -> Builder a -env v = Builder $ \s -> s {settingEnvVars = Just $ maybe (v :| []) (v <|) $ settingEnvVars s} +env v = Builder [BuildAddEnv v] -- | Try to parse a configuration value at the given key. -- @@ -250,6 +284,16 @@ conf :: (HasCodec a) => String -> Builder a conf k = confWith k codec +-- | Like 'conf' but with a custom 'Codec' for parsing the value. +confWith :: String -> ValueCodec void a -> Builder a +confWith k c = confWith' k (maybeCodec c) + +-- | Like 'confWith' but allows interpreting 'Null' as a value other than "Not found". +confWith' :: String -> ValueCodec void (Maybe a) -> Builder a +confWith' k c = + let t = ConfigValSetting {configValSettingPath = k :| [], configValSettingCodec = c} + in Builder [BuildAddConf t] + -- | Short-hand function for 'option', 'long', 'env', and 'conf' at the same time. -- -- Multiple 'name's will be tried in order. @@ -262,16 +306,6 @@ conf (toConfigCase s) ] --- | Like 'conf' but with a custom 'Codec' for parsing the value. -confWith :: String -> ValueCodec void a -> Builder a -confWith k c = confWith' k (maybeCodec c) - --- | Like 'confWith' but allows interpreting 'Null' as a value other than "Not found". -confWith' :: String -> ValueCodec void (Maybe a) -> Builder a -confWith' k c = - let t = ConfigValSetting {configValSettingPath = k :| [], configValSettingCodec = c} - in Builder $ \s -> s {settingConfigVals = Just $ maybe (t :| []) (t <|) $ settingConfigVals s} - -- | Set the default value -- -- Multiple 'value's override eachother. @@ -283,7 +317,7 @@ -- | Set the default value, along with a shown version of it. valueWithShown :: a -> String -> Builder a -valueWithShown a shown = Builder $ \s -> s {settingDefaultValue = Just (a, shown)} +valueWithShown a shown = Builder [BuildSetDefault a shown] -- | Provide an example value for documentation. -- @@ -291,7 +325,7 @@ -- -- If you use 'reader' 'auto', you'll want to use 'shownExample' instead. example :: String -> Builder a -example s = Builder $ \set -> set {settingExamples = s : settingExamples set} +example s = Builder [BuildAddExample s] -- | Use 'Show' to show an 'example'. -- @@ -303,4 +337,4 @@ -- -- Multiple 'hidden's are redundant. hidden :: Builder a -hidden = Builder $ \s -> s {settingHidden = True} +hidden = Builder [BuildSetHidden]