opt-env-conf 0.3.0.0 → 0.4.0.0
raw patch · 12 files changed
+403/−148 lines, 12 filesdep +autodocodec-nixdep ~autodocodec
Dependencies added: autodocodec-nix
Dependency ranges changed: autodocodec
Files
- CHANGELOG.md +11/−0
- opt-env-conf.cabal +4/−2
- src/OptEnvConf.hs +3/−1
- src/OptEnvConf/Args.hs +0/−6
- src/OptEnvConf/Doc.hs +133/−71
- src/OptEnvConf/Error.hs +0/−7
- src/OptEnvConf/Nix.hs +75/−0
- src/OptEnvConf/NonDet.hs +0/−24
- src/OptEnvConf/Parser.hs +4/−4
- src/OptEnvConf/Run.hs +145/−12
- src/OptEnvConf/Setting.hs +28/−16
- src/OptEnvConf/Validation.hs +0/−5
CHANGELOG.md view
@@ -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
opt-env-conf.cabal view
@@ -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
src/OptEnvConf.hs view
@@ -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
src/OptEnvConf/Args.hs view
@@ -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
src/OptEnvConf/Doc.hs view
@@ -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]
src/OptEnvConf/Error.hs view
@@ -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
+ src/OptEnvConf/Nix.hs view
@@ -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
src/OptEnvConf/NonDet.hs view
@@ -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
src/OptEnvConf/Parser.hs view
@@ -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
src/OptEnvConf/Run.hs view
@@ -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
src/OptEnvConf/Setting.hs view
@@ -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
src/OptEnvConf/Validation.hs view
@@ -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 :| [])