diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,16 @@ # Changelog +## [0.4.0.0] - 2024-07-23 + +### Added + +* Added a hidden `--render-reference-documentation` command. +* Added a per-command `--help` page. + +### Changed + +* Changed the name of `mkSettingsCheck` to `makeSettingsCheck`. + ## [0.3.0.0] - 2024-07-19 ### 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.3.0.0 +version: 0.4.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 @@ -32,6 +32,7 @@ OptEnvConf.EnvMap OptEnvConf.Error OptEnvConf.Lint + OptEnvConf.Nix OptEnvConf.NonDet OptEnvConf.Output OptEnvConf.Parser @@ -46,7 +47,8 @@ ghc-options: -Wall build-depends: aeson - , autodocodec >=0.2.3.0 + , autodocodec >=0.3.0.0 + , autodocodec-nix , autodocodec-schema , autodocodec-yaml , base <5 diff --git a/src/OptEnvConf.hs b/src/OptEnvConf.hs --- a/src/OptEnvConf.hs +++ b/src/OptEnvConf.hs @@ -120,11 +120,12 @@ commaSeparatedSet, -- * Re-exports, just in case + module OptEnvConf.Casing, module OptEnvConf.Doc, + module OptEnvConf.Nix, module OptEnvConf.Parser, module OptEnvConf.Reader, module OptEnvConf.Run, - module OptEnvConf.Casing, module OptEnvConf.Setting, module Control.Applicative, ) @@ -133,6 +134,7 @@ import Control.Applicative import OptEnvConf.Casing import OptEnvConf.Doc +import OptEnvConf.Nix import OptEnvConf.Parser import OptEnvConf.Reader import OptEnvConf.Run diff --git a/src/OptEnvConf/Args.hs b/src/OptEnvConf/Args.hs --- a/src/OptEnvConf/Args.hs +++ b/src/OptEnvConf/Args.hs @@ -20,7 +20,6 @@ renderArg, Dashed (..), renderDashed, - renderDashedArg, prefixDashed, ) where @@ -393,11 +392,6 @@ renderDashed = \case DashedShort c -> ['-', c] DashedLong cs -> '-' : '-' : NE.toList cs - -renderDashedArg :: Dashed -> Arg -renderDashedArg = \case - DashedShort c -> ArgDashed False (c :| []) - DashedLong cs -> ArgDashed True cs prefixDashed :: String -> Dashed -> Dashed prefixDashed p = \case diff --git a/src/OptEnvConf/Doc.hs b/src/OptEnvConf/Doc.hs --- a/src/OptEnvConf/Doc.hs +++ b/src/OptEnvConf/Doc.hs @@ -7,7 +7,9 @@ module OptEnvConf.Doc ( renderVersionPage, parserDocs, + commandParserDocs, renderHelpPage, + renderCommandHelpPage, renderManPage, renderReferenceDocumentation, parserOptDocs, @@ -24,6 +26,7 @@ OptDoc (..), EnvDoc (..), ConfDoc (..), + CommandDoc (..), settingSetDoc, renderSetDoc, settingOptDoc, @@ -38,7 +41,6 @@ import Autodocodec.Schema import Autodocodec.Yaml.Schema -import Control.Arrow import Control.Monad import Data.List (intersperse) import Data.List.NonEmpty (NonEmpty (..)) @@ -99,27 +101,6 @@ | AnyDocsSingle !a deriving (Show) -instance Functor AnyDocs where - fmap f = \case - AnyDocsCommands cs -> AnyDocsCommands $ map (fmap f) cs - AnyDocsAnd as -> AnyDocsAnd $ fmap (fmap f) as - AnyDocsOr as -> AnyDocsOr $ fmap (fmap f) as - AnyDocsSingle a -> AnyDocsSingle $ f a - -instance Foldable AnyDocs where - foldMap f = \case - AnyDocsCommands cs -> foldMap (foldMap f) cs - AnyDocsAnd as -> foldMap (foldMap f) as - AnyDocsOr as -> foldMap (foldMap f) as - AnyDocsSingle a -> f a - -instance Traversable AnyDocs where - traverse f = \case - AnyDocsCommands cs -> AnyDocsCommands <$> traverse (traverse f) cs - AnyDocsAnd as -> AnyDocsAnd <$> traverse (traverse f) as - AnyDocsOr as -> AnyDocsOr <$> traverse (traverse f) as - AnyDocsSingle a -> AnyDocsSingle <$> f a - data CommandDoc a = CommandDoc { commandDocArgument :: String, commandDocHelp :: Help, @@ -127,15 +108,6 @@ } deriving (Show) -instance Functor CommandDoc where - fmap f cd = cd {commandDocs = fmap f (commandDocs cd)} - -instance Foldable CommandDoc where - foldMap f = foldMap f . commandDocs - -instance Traversable CommandDoc where - traverse f cd = (\d -> cd {commandDocs = d}) <$> traverse f (commandDocs cd) - mapMaybeDocs :: (a -> Maybe b) -> AnyDocs a -> AnyDocs b mapMaybeDocs func = simplifyAnyDocs . go where @@ -189,17 +161,18 @@ ParserMany p -> go p -- TODO: is this right? ParserAllOrNothing _ p -> go p ParserCheck _ _ _ p -> go p - ParserCommands _ cs -> AnyDocsCommands $ map goCommand cs + 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 - goCommand :: Command a -> CommandDoc SetDoc - goCommand Command {..} = - CommandDoc - { commandDocArgument = commandArg, - commandDocHelp = commandHelp, - commandDocs = go commandParser - } +commandParserDocs :: Command a -> CommandDoc SetDoc +commandParserDocs Command {..} = + CommandDoc + { commandDocArgument = commandArg, + commandDocHelp = commandHelp, + commandDocs = parserDocs commandParser + } + settingSetDoc :: Setting a -> Maybe SetDoc settingSetDoc Setting {..} = do guard $ not settingHidden @@ -208,7 +181,12 @@ let setDocTrySwitch = isJust settingSwitchValue let setDocTryOption = settingTryOption let setDocEnvVars = settingEnvVars - let setDocConfKeys = NE.map (second (\(DecodingCodec c) -> jsonSchemaVia c)) <$> settingConfigVals + let setDocConfKeys = + NE.map + ( \ConfigValSetting {..} -> + (configValSettingPath, jsonSchemaVia configValSettingCodec) + ) + <$> settingConfigVals let setDocDefault = snd <$> settingDefaultValue let setDocMetavar = settingMetavar let setDocHelp = settingHelp @@ -297,6 +275,7 @@ let optDocs = docsToOptDocs docs envDocs = docsToEnvDocs docs confDocs = docsToConfDocs docs + commandDocs = docsToCommandDocs docs in unlinesChunks $ -- See https://man.openbsd.org/mdoc#MACRO_OVERVIEW concat @@ -318,6 +297,12 @@ renderSetDocs docs ], concat + [ [ [".Sh ", "COMMANDS"], + renderCommandDocs docs + ] + | not (null commandDocs) + ], + concat [ [ [".Sh ", "OPTIONS"], renderLongOptDocs optDocs ] @@ -343,6 +328,7 @@ let optDocs = docsToOptDocs docs envDocs = docsToEnvDocs docs confDocs = docsToConfDocs docs + commandDocs = docsToCommandDocs docs in unlinesChunks $ concat [ [ usageChunk : renderShortOptDocs progname optDocs, @@ -351,6 +337,12 @@ renderSetDocs docs ], concat + [ [ headerChunks "All commands", + renderCommandDocs docs + ] + | not (null commandDocs) + ], + concat [ [ headerChunks "Options", renderLongOptDocs optDocs ] @@ -394,32 +386,40 @@ -- | Render the output of @--help@ renderHelpPage :: String -> String -> AnyDocs SetDoc -> [Chunk] renderHelpPage progname progDesc docs = - unlinesChunks - [ usageChunk : renderShortOptDocs progname (docsToOptDocs docs), - [], - unlinesChunks $ progDescLines progDesc, - headerChunks "Available settings", - renderSetDocs docs - ] + unlinesChunks $ + concat + [ [ usageChunk : renderShortOptDocs progname (docsToOptDocs docs), + [], + unlinesChunks $ progDescLines progDesc + ], + concat + [ [ headerChunks "Available settings", + renderSetDocs docs + ] + | not (nullDocs docs) + ], + concat + [ [ headerChunks "Available commands", + renderCommandDocsShort docs + ] + | not (null (docsToCommandDocs docs)) + ] + ] +renderCommandHelpPage :: String -> [String] -> CommandDoc SetDoc -> [Chunk] +renderCommandHelpPage progname commandPath CommandDoc {..} = + renderHelpPage (unwords $ progname : commandPath ++ [commandDocArgument]) commandDocHelp commandDocs + renderSetDocs :: AnyDocs SetDoc -> [Chunk] renderSetDocs = unlinesChunks . go where go :: AnyDocs SetDoc -> [[Chunk]] go = \case - AnyDocsCommands cs -> concatMap goCommand cs + AnyDocsCommands _ -> [] AnyDocsAnd ds -> concatMap go ds AnyDocsOr ds -> goOr ds AnyDocsSingle d -> indent (renderSetDoc d) - goCommand :: CommandDoc SetDoc -> [[Chunk]] - goCommand CommandDoc {..} = - indent $ - [helpChunk commandDocHelp] - : ["command: ", commandChunk commandDocArgument] - : go commandDocs - ++ [[]] - -- Group together settings with the same help (produced by combinators like enableDisableSwitch) goOr :: [AnyDocs SetDoc] -> [[Chunk]] goOr = \case @@ -433,7 +433,7 @@ in concat [ indent $ renderSetDocHeader (Just h), indent $ concatMap renderSetDocWithoutHeader $ d : sds, - [[]], + [[] | not (null rest)], goOr rest ] (d : ds) -> go d ++ goOr ds @@ -449,6 +449,73 @@ else ([], AnyDocsSingle d : ds) ds -> ([], ds) +renderCommandDocs :: AnyDocs SetDoc -> [Chunk] +renderCommandDocs = unlinesChunks . go True + where + go :: Bool -> AnyDocs SetDoc -> [[Chunk]] + go isTopLevel = \case + AnyDocsCommands cs -> concatMap goCommand cs + AnyDocsAnd ds -> concatMap (go isTopLevel) ds + AnyDocsOr ds -> goOr isTopLevel ds + AnyDocsSingle d + | isTopLevel -> [] + | otherwise -> indent (renderSetDoc d) + + goCommand :: CommandDoc SetDoc -> [[Chunk]] + goCommand CommandDoc {..} = + indent $ + [helpChunk commandDocHelp] + : ["command: ", commandChunk commandDocArgument] + : go False commandDocs + ++ [[]] + + -- Group together settings with the same help (produced by combinators like enableDisableSwitch) + goOr :: Bool -> [AnyDocs SetDoc] -> [[Chunk]] + goOr isTopLevel = \case + [] -> [] + [d] -> go isTopLevel d + (AnyDocsSingle d : ds) -> + case setDocHelp d of + Nothing -> go isTopLevel (AnyDocsSingle d) ++ goOr isTopLevel ds + Just h -> + let (sds, rest) = goSameHelp h ds + in concat + [ concat + [ concat + [ indent $ renderSetDocHeader (Just h), + indent $ concatMap renderSetDocWithoutHeader $ d : sds, + [[]] + ] + | not isTopLevel + ], + goOr isTopLevel rest + ] + (d : ds) -> go isTopLevel d ++ goOr isTopLevel ds + goSameHelp :: Help -> [AnyDocs SetDoc] -> ([SetDoc], [AnyDocs SetDoc]) + goSameHelp h = \case + [] -> ([], []) + (AnyDocsSingle d : ds) -> + if setDocHelp d == Just h + then + let (sds, rest) = goSameHelp h ds + in (d : sds, rest) + else ([], AnyDocsSingle d : ds) + ds -> ([], ds) + +renderCommandDocsShort :: AnyDocs SetDoc -> [Chunk] +renderCommandDocsShort = layoutAsTable . go + where + go :: AnyDocs SetDoc -> [[[Chunk]]] + go = \case + AnyDocsCommands cs -> concatMap goCommand cs + AnyDocsAnd ds -> concatMap go ds + AnyDocsOr ds -> concatMap go ds + AnyDocsSingle _ -> [] + + goCommand :: CommandDoc SetDoc -> [[[Chunk]]] + goCommand CommandDoc {..} = + [indent [[commandChunk commandDocArgument], [helpChunk commandDocHelp]]] + parserOptDocs :: Parser a -> AnyDocs OptDoc parserOptDocs = docsToOptDocs . parserDocs @@ -473,21 +540,9 @@ where go :: AnyDocs OptDoc -> [Chunk] go = \case - AnyDocsCommands cs -> - unwordsChunks $ - intersperse [orChunk] $ - map - ( \CommandDoc {..} -> - if nullDocs commandDocs - then [commandChunk commandDocArgument] - else - commandChunk commandDocArgument - : " " - : go commandDocs - ) - cs + AnyDocsCommands _ -> ["COMMAND"] AnyDocsAnd ds -> unwordsChunks $ map go ds - AnyDocsOr ds -> renderOrChunks (map go ds) + AnyDocsOr ds -> renderOrChunks $ map go ds AnyDocsSingle OptDoc {..} -> unwordsChunks $ concat @@ -614,6 +669,13 @@ settingConfDoc :: Setting a -> Maybe ConfDoc settingConfDoc = settingSetDoc >=> setDocConfDoc + +docsToCommandDocs :: AnyDocs SetDoc -> [CommandDoc SetDoc] +docsToCommandDocs = \case + AnyDocsCommands cs -> cs + AnyDocsAnd ds -> concatMap docsToCommandDocs ds + AnyDocsOr ds -> concatMap docsToCommandDocs ds + AnyDocsSingle _ -> [] -- | Render documentation of configuration values renderConfDocs :: AnyDocs ConfDoc -> [Chunk] diff --git a/src/OptEnvConf/Error.hs b/src/OptEnvConf/Error.hs --- a/src/OptEnvConf/Error.hs +++ b/src/OptEnvConf/Error.hs @@ -6,20 +6,16 @@ import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE -import Data.Set (Set) -import qualified Data.Set as S import qualified Data.Text as T import GHC.Stack (SrcLoc) import OptEnvConf.Doc import OptEnvConf.Output -import OptEnvConf.Parser (SrcLocHash, hashSrcLoc) import Text.Colour data ParseError = ParseError { parseErrorSrcLoc :: !(Maybe SrcLoc), parseErrorMessage :: !ParseErrorMessage } - deriving (Show) data ParseErrorMessage = ParseErrorEmpty @@ -133,6 +129,3 @@ ["Unrecognised args: " : unwordsChunks (map (pure . chunk . T.pack) (NE.toList leftovers))], maybe [] (pure . ("see " :) . pure . srcLocChunk) parseErrorSrcLoc ] - -errorSrcLocSet :: (Foldable f) => f ParseError -> Set SrcLocHash -errorSrcLocSet = foldl (\s e -> maybe s ((`S.insert` s) . hashSrcLoc) (parseErrorSrcLoc e)) S.empty diff --git a/src/OptEnvConf/Nix.hs b/src/OptEnvConf/Nix.hs new file mode 100644 --- /dev/null +++ b/src/OptEnvConf/Nix.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module OptEnvConf.Nix where + +import Autodocodec +import Autodocodec.Nix +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.Map (Map) +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import OptEnvConf.Parser +import OptEnvConf.Setting + +renderSettingsNixOptions :: forall a. (HasParser a) => Text +renderSettingsNixOptions = renderParserNixOptions (settingsParser :: Parser a) + +renderParserNixOptions :: Parser a -> Text +renderParserNixOptions = renderExpr . parserNixOptionExpr + +parserNixOptionExpr :: Parser a -> Expr +parserNixOptionExpr = withNixArgs . optionsExpr . parserNixOptions + +parserNixOptions :: Parser a -> Map Text Option +parserNixOptions = go + where + go :: Parser a -> Map Text Option + go = \case + ParserPure _ -> M.empty + ParserAp p1 p2 -> M.unionWith combineOption (go p1) (go p2) + ParserSelect p1 p2 -> M.unionWith combineOption (go p1) (go p2) + ParserEmpty _ -> M.empty + ParserAlt p1 p2 -> M.unionWith combineOption (go p1) (go p2) -- TODO is this right? + ParserMany p -> go p + ParserAllOrNothing _ p -> go p + ParserCheck _ _ _ p -> go p + ParserCommands _ cs -> M.unionsWith combineOption $ map goCommand cs + ParserWithConfig _ p1 p2 -> + -- I'm not sure if we need the first as well because you wouldn't use a + -- config to load a config but it's technically possible so let's + -- support it. + M.unionWith combineOption (go p1) (go p2) + ParserSetting _ s -> + let codecTups = maybe [] NE.toList (settingConfigVals s) + in M.unionsWith combineOption $ flip map codecTups $ \ConfigValSetting {..} -> + let go' :: NonEmpty Text -> Map Text Option + go' (p :| ps) = case NE.nonEmpty ps of + Nothing -> + let oc = + maybe + (optionalFieldWith' p configValSettingCodec) + (optionalFieldWith p configValSettingCodec) + (T.pack <$> settingHelp s) + in objectCodecNixOptions oc + Just rest -> + let m = go' rest + in M.singleton p $ emptyOption {optionType = Just (OptionTypeSubmodule m)} + in go' $ NE.map T.pack configValSettingPath + combineOption :: Option -> Option -> Option + combineOption o1 o2 = case (optionType o1, optionType o2) of + (Nothing, _) -> o2 + (Just ot1, Nothing) -> o2 {optionType = Just ot1} + (Just ot1, Just ot2) -> o2 {optionType = Just $ combineOptionType ot1 ot2} + + combineOptionType :: OptionType -> OptionType -> OptionType + combineOptionType ot1 ot2 = simplifyOptionType $ case (ot1, ot2) of + (OptionTypeSubmodule m1, OptionTypeSubmodule m2) -> OptionTypeSubmodule $ M.unionWith combineOption m1 m2 + _ -> OptionTypeOneOf [ot1, ot2] + goCommand :: Command a -> Map Text Option + goCommand = go . commandParser diff --git a/src/OptEnvConf/NonDet.hs b/src/OptEnvConf/NonDet.hs --- a/src/OptEnvConf/NonDet.hs +++ b/src/OptEnvConf/NonDet.hs @@ -8,7 +8,6 @@ runNonDetT, runNonDetTLazy, liftNonDetTList, - liftNonDetTListM, NonDetT, ) where @@ -16,7 +15,6 @@ import Control.Applicative import Control.Monad import Control.Monad.State -import Control.Selective import Data.Functor.Identity type NonDet = NonDetT Identity @@ -35,9 +33,6 @@ liftNonDetTList :: (Applicative m) => [a] -> NonDetT m a liftNonDetTList = liftListT -liftNonDetTListM :: (Applicative m) => [m a] -> NonDetT m a -liftNonDetTListM = liftListTM - -- The monadic list type data MList m a = MNil @@ -89,14 +84,6 @@ liftListT :: (Applicative m) => [a] -> ListT m a liftListT = ListT . pure . liftMList -liftListTM :: (Applicative m) => [m a] -> ListT m a -liftListTM = ListT . go - where - go :: (Applicative m) => [m a] -> m (MList m a) - go = \case - [] -> pure MNil - (ma : mas) -> MCons <$> ma <*> pure (go mas) - instance (Functor f) => Functor (ListT f) where fmap f = ListT . fmap (fmap f) . unListT @@ -107,19 +94,12 @@ a <- fa pure (f a) -instance (Monad f) => Selective (ListT f) where - select = selectM - instance (MonadIO m) => MonadIO (ListT m) where liftIO = lift . liftIO instance MonadTrans ListT where lift = ListT . fmap (`MCons` pure MNil) -instance (MonadState s m) => MonadState s (ListT m) where - get = lift get - put = lift . put - -- Note: This alternative instance only "alternates" on the nondeterminism, not the -- underlying effect. instance (Monad f) => Alternative (ListT f) where @@ -128,10 +108,6 @@ instance (Monad f) => Monad (ListT f) where (>>=) m f = joinListT $ fmap f m - -instance (Monad f) => MonadPlus (ListT f) where - mzero = empty - mplus = (<|>) joinListT :: (Monad m) => ListT m (ListT m a) -> ListT m a joinListT (ListT xss) = ListT . joinMMMList $ fmap (fmap unListT) xss diff --git a/src/OptEnvConf/Parser.hs b/src/OptEnvConf/Parser.hs --- a/src/OptEnvConf/Parser.hs +++ b/src/OptEnvConf/Parser.hs @@ -79,14 +79,13 @@ import Autodocodec.Yaml import Control.Applicative -import Control.Arrow (first) import Control.Monad import Control.Selective import Data.Aeson as JSON import qualified Data.Aeson.KeyMap as KM import Data.Functor.Identity import Data.Hashable -import Data.List.NonEmpty (NonEmpty (..), (<|)) +import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import Data.Maybe import Data.Set (Set) @@ -886,7 +885,7 @@ {-# ANN subConfig ("NOCOVER" :: String) #-} subConfig :: String -> Parser a -> Parser a subConfig prefix = parserMapSetting $ \s -> - s {settingConfigVals = NE.map (first (prefix <|)) <$> settingConfigVals s} + s {settingConfigVals = NE.map (prefixConfigValSetting prefix) <$> settingConfigVals s} -- | Helper function for calling 'subConfig' with 'toConfigCase'. -- @@ -996,8 +995,9 @@ -- The nothing part shouldn't happen but I don't know when it doesn't ParserSetting mLoc _ -> maybe S.empty (S.singleton . hashSrcLoc) mLoc +-- An 'Ord'-able SrcLoc newtype SrcLocHash = SrcLocHash Int - deriving (Show, Eq, Ord) + deriving (Eq, Ord) hashSrcLoc :: SrcLoc -> SrcLocHash hashSrcLoc = SrcLocHash . hash . prettySrcLoc diff --git a/src/OptEnvConf/Run.hs b/src/OptEnvConf/Run.hs --- a/src/OptEnvConf/Run.hs +++ b/src/OptEnvConf/Run.hs @@ -8,6 +8,7 @@ ( runSettingsParser, runParser, runParserOn, + runHelpParser, internalParser, ) where @@ -39,6 +40,7 @@ import qualified OptEnvConf.EnvMap as EnvMap import OptEnvConf.Error import OptEnvConf.Lint +import OptEnvConf.Nix import OptEnvConf.NonDet import OptEnvConf.Output import OptEnvConf.Parser @@ -124,9 +126,18 @@ Right i -> case i of ShowHelp -> do progname <- getProgName - tc <- getTerminalCapabilitiesFromHandle stdout - hPutChunksLocaleWith tc stdout $ renderHelpPage progname progDesc docs - exitSuccess + errOrDocs <- runHelpParser mDebugMode argMap' p + case errOrDocs of + Left errs -> do + stderrTc <- getTerminalCapabilitiesFromHandle stderr + hPutChunksLocaleWith stderrTc stderr $ renderErrors errs + exitFailure + Right mCommandDoc -> do + tc <- getTerminalCapabilitiesFromHandle stdout + hPutChunksLocaleWith tc stdout $ case mCommandDoc of + Nothing -> renderHelpPage progname progDesc docs + Just (path, cDoc) -> renderCommandHelpPage progname path cDoc + exitSuccess ShowVersion -> do progname <- getProgName tc <- getTerminalCapabilitiesFromHandle stdout @@ -137,6 +148,14 @@ tc <- getTerminalCapabilitiesFromHandle stdout hPutChunksLocaleWith tc stdout $ renderManPage progname version progDesc docs exitSuccess + RenderDocumentation -> do + progname <- getProgName + tc <- getTerminalCapabilitiesFromHandle stdout + hPutChunksLocaleWith tc stdout $ renderReferenceDocumentation progname docs + exitSuccess + RenderNixosOptions -> do + putStrLn $ T.unpack $ renderParserNixOptions p' + exitSuccess CheckSettings -> do let argMap'' = case consumeSwitch [DashedLong settingsCheckSwitch] argMap of Nothing -> error "If you see this there is a bug in opt-env-conf." @@ -174,6 +193,8 @@ = ShowHelp | ShowVersion | RenderMan + | RenderDocumentation + | RenderNixosOptions | CheckSettings | BashCompletionScript (Path Abs File) | ZshCompletionScript (Path Abs File) @@ -214,8 +235,20 @@ [ switch RenderMan, long "render-man-page", hidden, - help "Show this help text" + help "Render a manpage" ], + setting + [ switch RenderDocumentation, + long "render-reference-documentation", + hidden, + help "Render reference documentation" + ], + setting + [ switch RenderNixosOptions, + long "render-nixos-options", + hidden, + help "Render nixos options" + ], allowLeftovers $ setting [ switch CheckSettings, @@ -299,7 +332,7 @@ EnvMap -> Maybe JSON.Object -> IO (Either (NonEmpty ParseError) a) -runParserOn debugMode parser args envVars mConfig = do +runParserOn mDebugMode parser args envVars mConfig = do let ppState = PPState { ppStateArgs = args, @@ -309,7 +342,7 @@ PPEnv { ppEnvEnv = envVars, ppEnvConf = mConfig, - ppEnvDebug = debugMode, + ppEnvDebug = mDebugMode, ppEnvIndent = 0 } let go' = do @@ -328,7 +361,7 @@ -- TODO: Consider keeping around all errors? mNext <- runNonDetTLazy ns case mNext of - Nothing -> pure $ Left $ (if isJust debugMode then id else eraseErrorSrcLocs) firstErrors + Nothing -> pure $ Left firstErrors Just ((eOR, _), ns') -> case eOR of Success a -> pure (Right a) Failure _ -> goNexts ns' @@ -572,7 +605,7 @@ let mConfDoc = settingConfDoc set mConf <- case settingConfigVals of Nothing -> pure NotRun - Just ((ne, DecodingCodec c) :| _) -> do + Just (ConfigValSetting {..} :| _) -> do -- TODO try parsing with the others mObj <- asks ppEnvConf case mObj of @@ -591,22 +624,22 @@ case mO' of Nothing -> pure Nothing Just o' -> jsonParser o' neRest - case JSON.parseEither (jsonParser obj) ne of + case JSON.parseEither (jsonParser obj) configValSettingPath of Left err -> ppError mLoc $ ParseErrorConfigRead mConfDoc err Right mV -> case mV of Nothing -> do debug [ "could not set based on config value, not configured: ", - chunk $ T.pack $ show $ NE.toList ne + chunk $ T.pack $ show $ NE.toList configValSettingPath ] pure NotFound - Just v -> case JSON.parseEither (parseJSONVia c) v of + Just v -> case JSON.parseEither (parseJSONVia configValSettingCodec) 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 + chunk $ T.pack $ show $ NE.toList configValSettingPath ] pure NotFound Just a -> do @@ -663,6 +696,106 @@ (r : rl) -> case runReader r s of Left err -> go' (err <| errs) rl Right a -> Right a + +runHelpParser :: + -- DebugMode + Maybe TerminalCapabilities -> + Args -> + Parser a -> + IO (Either (NonEmpty ParseError) (Maybe ([String], CommandDoc SetDoc))) +runHelpParser mDebugMode args parser = do + let ppState = + PPState + { ppStateArgs = args, + ppStateParsedSettings = S.empty + } + let ppEnv = + PPEnv + { ppEnvEnv = EnvMap.empty, + ppEnvConf = Nothing, + ppEnvDebug = mDebugMode, + ppEnvIndent = 0 + } + mResOrNext <- runPPLazy (go' [] parser) ppState ppEnv + case mResOrNext of + Nothing -> pure $ Right Nothing + Just ((result, _), _) -> pure $ case result of + Failure errs -> Left errs + 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' path = + let go :: Parser a -> PP (Maybe ([String], CommandDoc SetDoc)) + go = go' path + in \case + ParserPure _ -> do + debug [syntaxChunk "pure value"] + pure Nothing + ParserAp ff fa -> do + debug [syntaxChunk "Ap"] + ppIndent $ do + mf <- go ff + ma <- go fa + pure $ ma <|> mf -- Reverse order + ParserSelect fe ff -> do + debug [syntaxChunk "Select"] + ppIndent $ do + me <- go fe + mf <- go ff + pure $ mf <|> me -- Reverse order + ParserEmpty mLoc -> do + debug [syntaxChunk "Empty", ": ", mSrcLocChunk mLoc] + pure Nothing + ParserAlt p1 p2 -> do + 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 + debug [syntaxChunk "Many"] + ppIndent $ go p' + ParserAllOrNothing mLoc p' -> do + debug [syntaxChunk "AllOrNothing", ": ", mSrcLocChunk mLoc] + ppIndent $ go p' + ParserCheck mLoc _ _ p' -> do + debug [syntaxChunk "Parser with check", ": ", mSrcLocChunk mLoc] + ppIndent $ go p' + ParserWithConfig mLoc pc pa -> do + debug [syntaxChunk "WithConfig", ": ", mSrcLocChunk mLoc] + ppIndent $ do + mNewConfig <- go pc + mRes <- go pa + pure $ mRes <|> mNewConfig -- Reverse order + ParserSetting mLoc _ -> do + debug [syntaxChunk "Setting", ": ", mSrcLocChunk mLoc] + pure Nothing + ParserCommands mLoc cs -> do + debug [syntaxChunk "Commands", ": ", mSrcLocChunk mLoc] + ppIndent $ do + mS <- ppArg + case mS of + Nothing -> do + debug ["No argument found for choosing a command."] + pure Nothing + Just s -> do + case find ((== s) . commandArg) cs of + Nothing -> do + debug ["Argument found, but no matching command: ", chunk $ T.pack $ show s] + pure Nothing + Just c -> do + debug ["Set command to ", commandChunk (commandArg c)] + mRes <- go' (commandArg c : path) $ commandParser c + pure $ case mRes of + Nothing -> Just (reverse path, commandParserDocs c) + Just res -> pure res type PP a = ReaderT PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a diff --git a/src/OptEnvConf/Setting.hs b/src/OptEnvConf/Setting.hs --- a/src/OptEnvConf/Setting.hs +++ b/src/OptEnvConf/Setting.hs @@ -1,10 +1,12 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} module OptEnvConf.Setting ( Setting (..), + ConfigValSetting (..), -- * Builders help, @@ -33,9 +35,9 @@ showSettingABit, completeBuilder, emptySetting, - DecodingCodec (..), Metavar, Help, + prefixConfigValSetting, ) where @@ -71,7 +73,7 @@ -- | Which env vars can be read. settingEnvVars :: !(Maybe (NonEmpty String)), -- | Which and how to parse config values - settingConfigVals :: !(Maybe (NonEmpty (NonEmpty String, DecodingCodec a))), + settingConfigVals :: !(Maybe (NonEmpty (ConfigValSetting a))), -- | Default value, if none of the above find the setting. settingDefaultValue :: !(Maybe (a, String)), -- | Example values @@ -83,8 +85,15 @@ settingHelp :: !(Maybe String) } -data DecodingCodec a = forall void. DecodingCodec (ValueCodec void (Maybe a)) +data ConfigValSetting a = forall void. + ConfigValSetting + { configValSettingPath :: !(NonEmpty String), + configValSettingCodec :: !(ValueCodec void (Maybe a)) + } +prefixConfigValSetting :: String -> ConfigValSetting a -> ConfigValSetting a +prefixConfigValSetting prefix c = c {configValSettingPath = prefix NE.<| configValSettingPath c} + -- | A 'mempty' 'Setting' to build up a setting from. emptySetting :: Setting a emptySetting = @@ -120,18 +129,7 @@ . showString " " . showsPrec 11 settingEnvVars . showString " " - . showMaybeWith - ( showListWith - ( \(k, DecodingCodec c) -> - showString "(" - . shows k - . showString ", " - . showString (showCodecABit c) - . showString ")" - ) - . NE.toList - ) - settingConfigVals + . showMaybeWith (showNonEmptyWith showConfigValSettingABit) settingConfigVals . showString " " . showMaybeWith (\_ -> showString "_") settingDefaultValue . showString " " @@ -139,10 +137,24 @@ . showString " " . showsPrec 11 settingHelp +showConfigValSettingABit :: ConfigValSetting a -> ShowS +showConfigValSettingABit ConfigValSetting {..} = + showString "ConfigValSetting " + . showsPrec 11 configValSettingPath + . showString " " + . showString (showCodecABit configValSettingCodec) + showMaybeWith :: (a -> ShowS) -> Maybe a -> ShowS showMaybeWith _ Nothing = showString "Nothing" showMaybeWith func (Just a) = showParen True $ showString "Just " . func a +showNonEmptyWith :: (a -> ShowS) -> NonEmpty a -> ShowS +showNonEmptyWith func (a :| as) = + showParen True $ + func a + . showString " :| " + . showListWith func as + -- | Builder for a 'Setting' newtype Builder a = Builder {unBuilder :: Setting a -> Setting a} @@ -257,7 +269,7 @@ -- | 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 = (k :| [], DecodingCodec c) + let t = ConfigValSetting {configValSettingPath = k :| [], configValSettingCodec = c} in Builder $ \s -> s {settingConfigVals = Just $ maybe (t :| []) (t <|) $ settingConfigVals s} -- | Set the default value diff --git a/src/OptEnvConf/Validation.hs b/src/OptEnvConf/Validation.hs --- a/src/OptEnvConf/Validation.hs +++ b/src/OptEnvConf/Validation.hs @@ -82,11 +82,6 @@ Left a -> f a Right b -> b -instance Monad (Validation e) where - return = pure - Success a >>= f = f a - Failure es >>= _ = Failure es - validationFailure :: e -> Validation e a validationFailure e = Failure (e :| [])