opt-env-conf 0.11.1.0 → 0.12.1.0

raw patch · 13 files changed

+567/−291 lines, 13 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−0
• opt-env-conf.cabal +3/−1
• src/OptEnvConf.hs +1/−0
• src/OptEnvConf/Check.hs +92/−0
• src/OptEnvConf/Completion.hs +1/−1
• src/OptEnvConf/Doc.hs +1/−1
• src/OptEnvConf/Error.hs +6/−1
• src/OptEnvConf/Lint.hs +1/−1
• src/OptEnvConf/Main.hs +305/−0
• src/OptEnvConf/Nix.hs +1/−1
• src/OptEnvConf/Output.hs +10/−0
• src/OptEnvConf/Parser.hs +73/−15
• src/OptEnvConf/Run.hs +64/−270

@@ -1,5 +1,14 @@ # Changelog +## [0.12.0.0] - 2025-11-25++### Added++* Support for capabilities during settings parsing, and disabling them in the+  settings check.++This is technically a breaking change, but if you don't use any `opt-env-conf`+internals, nothing should break for you.  ## [0.11.1.0] - 2025-10-23 

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           opt-env-conf-version:        0.11.1.0+version:        0.12.1.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@@ -27,12 +27,14 @@       OptEnvConf       OptEnvConf.Args       OptEnvConf.Casing+      OptEnvConf.Check       OptEnvConf.Completer       OptEnvConf.Completion       OptEnvConf.Doc       OptEnvConf.EnvMap       OptEnvConf.Error       OptEnvConf.Lint+      OptEnvConf.Main       OptEnvConf.Nix       OptEnvConf.NonDet       OptEnvConf.Output

@@ -150,6 +150,7 @@ import OptEnvConf.Casing import OptEnvConf.Completer import OptEnvConf.Doc+import OptEnvConf.Main import OptEnvConf.Nix import OptEnvConf.Parser import OptEnvConf.Reader

@@ -0,0 +1,92 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module OptEnvConf.Check+  ( runSettingsCheck,+    runSettingsCheckOn,+  )+where++import qualified Data.Aeson as JSON+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Data.Maybe+import GHC.Generics (Generic)+import GHC.Stack (SrcLoc)+import OptEnvConf.Args as Args+import OptEnvConf.EnvMap (EnvMap (..))+import OptEnvConf.Error+import OptEnvConf.Parser+import OptEnvConf.Run+import OptEnvConf.Terminal (getTerminalCapabilitiesFromHandle)+import System.Exit+import System.IO (stderr, stdout)+import Text.Colour++runSettingsCheck :: Capabilities -> Parser a -> Args -> EnvMap -> Maybe JSON.Object -> IO void+runSettingsCheck capabilities p args envVars mConfig = do+  stderrTc <- getTerminalCapabilitiesFromHandle stderr+  errOrSets <- runSettingsCheckOn capabilities stderrTc p args envVars mConfig+  case errOrSets of+    CheckFailed errs -> do+      hPutChunksLocaleWith stderrTc stderr $ renderErrors errs+      exitFailure+    CheckIncapable missingCaps -> do+      tc <- getTerminalCapabilitiesFromHandle stdout+      hPutChunksLocaleWith tc stdout ["Could not complete parsing settings because of missing capabilities, but no errors were found so far."]+      hPutChunksLocaleWith stderrTc stderr $ renderMissingCapabilities missingCaps+      exitSuccess+    CheckSucceeded _ -> do+      tc <- getTerminalCapabilitiesFromHandle stdout+      hPutChunksLocaleWith tc stdout ["Settings parsed successfully."]+      exitSuccess++renderMissingCapabilities :: NonEmpty MissingCapability -> [Chunk]+renderMissingCapabilities = renderErrors . NE.map capabilityErorr+  where+    capabilityErorr (MissingCapability mLoc cap) =+      ParseError mLoc $ ParseErrorMissingCapability cap++data CheckResult a+  = -- | Check succeeded+    CheckSucceeded a+  | -- | Check could not be completed because of missing capability+    CheckIncapable (NonEmpty MissingCapability)+  | -- | Check failed with parse errors+    CheckFailed (NonEmpty ParseError)+  deriving (Show, Generic, Functor)++data MissingCapability+  = MissingCapability+      -- Where the capability was needed+      !(Maybe SrcLoc)+      -- Where the capability was needed+      !Capability+  deriving (Show, Generic)++runSettingsCheckOn ::+  Capabilities ->+  -- DebugMode, always on+  TerminalCapabilities ->+  Parser a ->+  Args ->+  EnvMap ->+  Maybe JSON.Object ->+  IO (CheckResult a)+runSettingsCheckOn capabilities debugMode p args envVars mConfig = do+  errOrSets <- runParserOn capabilities (Just debugMode) p args envVars mConfig+  pure $ case errOrSets of+    Right a -> CheckSucceeded a+    Left errs ->+      let missingCaps =+            mapMaybe+              ( \case+                  ParseError mLoc (ParseErrorMissingCapability cap) -> Just (MissingCapability mLoc cap)+                  _ -> Nothing+              )+              (NE.toList errs)+       in case NE.nonEmpty missingCaps of+            Just ne -> CheckIncapable ne+            Nothing -> CheckFailed errs

@@ -284,7 +284,7 @@           Nothing -> pure Nothing           Just os -> fmap (os ++) <$> go p       ParserAllOrNothing _ p -> go p-      ParserCheck _ _ _ p -> go p+      ParserCheck _ _ _ _ p -> go p       ParserWithConfig _ p1 p2 ->         -- The config-file auto-completion is probably less important, we put it second.         andCompletions p2 p1

@@ -172,7 +172,7 @@       ParserMany _ p -> AnyDocsOr [go p, AnyDocsSingle Nothing]       ParserSome mLoc p -> AnyDocsAnd [go p, go (ParserMany mLoc p)] -- TODO: is this right?       ParserAllOrNothing _ p -> go p-      ParserCheck _ _ _ p -> go p+      ParserCheck _ _ _ _ p -> go p       ParserCommands _ mDefault cs -> AnyDocsCommands mDefault $ 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 -> AnyDocsSingle $ settingSetDoc set

@@ -12,6 +12,7 @@ import GHC.Stack (SrcLoc) import OptEnvConf.Doc import OptEnvConf.Output+import OptEnvConf.Parser import OptEnvConf.Setting import Text.Colour @@ -39,6 +40,7 @@   | ParseErrorUnrecognisedCommand !String ![CommandDoc ()]   | ParseErrorAllOrNothing !(Map SettingHash SrcLoc)   | ParseErrorUnrecognised !(NonEmpty String)+  | ParseErrorMissingCapability !Capability   deriving (Show)  -- | Whether the other side of an 'Alt' should be tried if we find this error.@@ -64,6 +66,7 @@   ParseErrorUnrecognisedCommand _ _ -> False   ParseErrorAllOrNothing _ -> False   ParseErrorUnrecognised _ -> False+  ParseErrorMissingCapability _ -> False  eraseErrorSrcLocs :: (Functor f) => f ParseError -> f ParseError eraseErrorSrcLocs = fmap eraseErrorSrcLoc@@ -131,7 +134,9 @@           ]             ++ map (pure . srcLocChunk) (M.elems locs)         ParseErrorUnrecognised leftovers ->-          ["Unrecognised args: " : unwordsChunks (map (pure . chunk . T.pack) (NE.toList leftovers))],+          ["Unrecognised args: " : unwordsChunks (map (pure . chunk . T.pack) (NE.toList leftovers))]+        ParseErrorMissingCapability cap ->+          ["Missing capability: " : [chunk $ T.pack $ show cap]],       maybe [] (pure . ("see " :) . pure . srcLocChunk) parseErrorSrcLoc     ] 

@@ -271,7 +271,7 @@             validationTFailure LintErrorManyInfinite         pure c       ParserAllOrNothing _ p -> go p-      ParserCheck _ _ _ p -> go p+      ParserCheck _ _ _ _ p -> go p       ParserCommands mLoc mDefault cs -> do         if null cs           then validationTFailure $ LintError mLoc LintErrorNoCommands

@@ -0,0 +1,305 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module OptEnvConf.Main+  ( runSettingsParser,+    runParser,+    internalParser,+  )+where++import qualified Data.Text as T+import Data.Version+import OptEnvConf.Args as Args+import OptEnvConf.Check+import OptEnvConf.Completion+import OptEnvConf.Doc+import qualified OptEnvConf.EnvMap as EnvMap+import OptEnvConf.Error+import OptEnvConf.Lint+import OptEnvConf.Nix+import OptEnvConf.Parser+import OptEnvConf.Reader+import OptEnvConf.Run+import OptEnvConf.Setting+import OptEnvConf.Terminal (getTerminalCapabilitiesFromHandle)+import Path+import System.Environment (getArgs, getEnvironment, getProgName)+import System.Exit+import System.IO+import Text.Colour++-- | Run 'runParser' on your @Settings@' type's 'settingsParser'.+--+-- __This is most likely the function you want to be using.__+runSettingsParser ::+  (HasParser a) =>+  -- | Program version, get this from Paths_your_package_name+  Version ->+  -- | Program description+  String ->+  IO a+runSettingsParser version progDesc =+  runParser version progDesc settingsParser++-- | Run a parser+--+-- This function with exit on:+--+--     * Parse failure: show a nice error message.+--     * @-h|--help@: Show help text+--     * @--version@: Show version information+--     * @--render-man-page@: Render a man page+--     * @--bash-completion-script@: Render a bash completion script+--     * @--zsh-completion-script@: Render a zsh completion script+--     * @--fish-completion-script@: Render a fish completion script+--     * @query-opt-env-conf-completion@: Perform a completion query+--+-- This gets the arguments and environment variables from the current process.+runParser ::+  -- | Program version, get this from Paths_your_package_name+  Version ->+  -- | Program description+  String ->+  Parser a ->+  IO a+runParser version progDesc p = do+  completeEnv <- getEnvironment+  let envVars = EnvMap.parse completeEnv++  case lintParser p of+    Just errs -> do+      tc <- getTerminalCapabilitiesFromHandle stderr+      hPutChunksLocaleWith tc stderr $ renderLintErrors errs+      exitFailure+    Nothing -> do+      let docs = parserDocs p++      allArgs <- getArgs+      let (debugMode, args) = consumeDebugMode allArgs++      mDebugMode <-+        if debugMode+          then Just <$> getTerminalCapabilitiesFromHandle stderr+          else pure Nothing++      let (helpMode, args') = consumeHelpMode args++      if helpMode+        then do+          progname <- getProgName+          errOrDocs <- runHelpParser mDebugMode (Args.parseArgs args') 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 version progDesc docs+                Just (path, cDoc) -> renderCommandHelpPage progname path cDoc+              exitSuccess+        else do+          let (capabilities, args'') = consumeCapabilities args'+          let (checkMode, args''') = consumeCheckMode args''++          let readyArgs = Args.parseArgs args'''++          let mConfig = Nothing -- We start with no config loaded.+          if checkMode+            then runSettingsCheck capabilities p readyArgs envVars mConfig+            else do+              let p' = internalParser p+              errOrResult <-+                runParserOn+                  capabilities+                  mDebugMode+                  p'+                  readyArgs+                  envVars+                  mConfig+              case errOrResult of+                Left errs -> do+                  tc <- getTerminalCapabilitiesFromHandle stderr+                  hPutChunksLocaleWith tc stderr $ renderErrors errs+                  exitFailure+                Right i -> case i of+                  ShowVersion -> do+                    progname <- getProgName+                    tc <- getTerminalCapabilitiesFromHandle stdout+                    hPutChunksLocaleWith tc stdout $ renderVersionPage progname version+                    exitSuccess+                  RenderMan -> do+                    progname <- getProgName+                    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+                  BashCompletionScript progPath -> do+                    progname <- getProgName+                    generateBashCompletionScript progPath progname+                    exitSuccess+                  ZshCompletionScript progPath -> do+                    progname <- getProgName+                    generateZshCompletionScript progPath progname+                    exitSuccess+                  FishCompletionScript progPath -> do+                    progname <- getProgName+                    generateFishCompletionScript progPath progname+                    exitSuccess+                  CompletionQuery enriched index ws -> do+                    runCompletionQuery p' enriched index ws+                    exitSuccess+                  ParsedNormally a -> pure a++-- We use [String] instead of [Args] because we want to remove these args, and act on them, before any real arg parsing happens.+consumeExactArg :: String -> [String] -> (Bool, [String])+consumeExactArg arg = go+  where+    go = \case+      [] -> (False, [])+      (x : xs)+        | x == arg -> (True, xs)+        | otherwise ->+            let (found, rest) = go xs+             in (found, x : rest)++consumeDebugMode :: [String] -> (Bool, [String])+consumeDebugMode = consumeExactArg "--debug-optparse"++-- Note: Here we only consume exact -h as an arg, not -h as part of another arg like -hu+consumeHelpMode :: [String] -> (Bool, [String])+consumeHelpMode as =+  let (found, as') = consumeExactArg "--help" as+   in if found+        then (True, as')+        else consumeExactArg "-h" as'++consumeCheckMode :: [String] -> (Bool, [String])+consumeCheckMode = consumeExactArg "--run-settings-check"++consumeCapabilities :: [String] -> (Capabilities, [String])+consumeCapabilities = go allCapabilities+  where+    go :: Capabilities -> [String] -> (Capabilities, [String])+    go caps = \case+      [] -> (caps, [])+      (x : xs) ->+        let t = T.pack x+         in case T.stripPrefix "--settings-capabilities-disable-" t of+              Just capName -> go (disableCapability (Capability capName) caps) xs+              Nothing -> case T.stripPrefix "--settings-capabilities-enable-" t of+                Just capName -> go (enableCapability (Capability capName) caps) xs+                Nothing ->+                  let (finalCaps, rest) = go caps xs+                   in (finalCaps, x : rest)++-- Internal structure to help us do what the framework+-- is supposed to.+data Internal a+  = ShowVersion+  | RenderMan+  | RenderDocumentation+  | RenderNixosOptions+  | BashCompletionScript (Path Abs File)+  | ZshCompletionScript (Path Abs File)+  | FishCompletionScript (Path Abs File)+  | CompletionQuery+      -- Enriched+      !Bool+      -- Index+      !Int+      -- Args+      ![String]+  | ParsedNormally !a++internalParser :: Parser a -> Parser (Internal a)+internalParser p =+  choice+    [ setting+        [ switch ShowVersion,+          long "version",+          hidden+        ],+      setting+        [ switch RenderMan,+          long "render-man-page",+          hidden,+          help "Render a manpage"+        ],+      setting+        [ switch RenderDocumentation,+          long "render-reference-documentation",+          hidden,+          help "Render reference documentation"+        ],+      setting+        [ switch RenderNixosOptions,+          long "render-nix-options",+          hidden,+          help "Render Nix options"+        ],+      BashCompletionScript+        <$> setting+          [ option,+            reader $ maybeReader parseAbsFile,+            long "bash-completion-script",+            hidden,+            help "Render the bash completion script"+          ],+      ZshCompletionScript+        <$> setting+          [ option,+            reader $ maybeReader parseAbsFile,+            long "zsh-completion-script",+            hidden,+            help "Render the zsh completion script"+          ],+      ZshCompletionScript+        <$> setting+          [ option,+            reader $ maybeReader parseAbsFile,+            long "fish-completion-script",+            hidden,+            help "Render the fish completion script"+          ],+      setting+        [ help "Query completion",+          switch CompletionQuery,+          -- Long string that no normal user would ever use.+          long "query-opt-env-conf-completion",+          hidden+        ]+        <*> setting+          [ switch True,+            long "completion-enriched",+            value False,+            hidden,+            help "Whether to enable enriched completion"+          ]+        <*> setting+          [ option,+            reader auto,+            long "completion-index",+            hidden,+            help "The index between the arguments where completion was invoked."+          ]+        <*> many+          ( setting+              [ option,+                reader str,+                long "completion-word",+                hidden,+                help "The words (arguments) that have already been typed"+              ]+          ),+      ParsedNormally <$> p+    ]

@@ -39,7 +39,7 @@       ParserMany _ p -> go p       ParserSome _ p -> go p       ParserAllOrNothing _ p -> go p-      ParserCheck _ _ _ 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

@@ -6,6 +6,8 @@ import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import Data.Maybe+import Data.Set (Set)+import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T import Data.Version@@ -79,6 +81,14 @@  syntaxChunk :: String -> Chunk syntaxChunk = fore blue . chunk . T.pack++capabilitiesChunks :: Set Capability -> [Chunk]+capabilitiesChunks caps = case Set.toList caps of+  [] -> []+  cs -> intersperse ", " (map capabilityChunk cs)++capabilityChunk :: Capability -> Chunk+capabilityChunk = fore green . chunk . unCapability  mSrcLocChunk :: Maybe SrcLoc -> Chunk mSrcLocChunk = maybe "without srcLoc" srcLocChunk

@@ -1,5 +1,8 @@ {-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}@@ -25,6 +28,7 @@     checkMapIOForgivable,     checkMapMaybeForgivable,     allOrNothing,+    requireCapability,     commands,     command,     defaultCommand,@@ -56,9 +60,11 @@     readSecretTextFile,     secretTextFileSetting,     secretTextFileOrBareSetting,+    readSecretCapability,      -- * Parser implementation     Parser (..),+    Capability (..),     HasParser (..),     Command (..),     CommandsBuilder (..),@@ -93,10 +99,14 @@ import Data.Map (Map) import qualified Data.Map as M import Data.Maybe+import Data.Set (Set)+import qualified Data.Set as Set import Data.String import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T+import Data.Validity+import GHC.Generics (Generic) import GHC.Stack (HasCallStack, SrcLoc, callStack, getCallStack, withFrozenCallStack) import OptEnvConf.Args (Dashed (..), prefixDashed) import OptEnvConf.Casing@@ -191,6 +201,9 @@     !(Maybe SrcLoc) ->     -- | Forgivable     !Bool ->+    -- | Necessary capabilities+    !(Set Capability) ->+    -- | Check function     !(a -> IO (Either String b)) ->     !(Parser a) ->     Parser b@@ -213,6 +226,20 @@     !(Setting a) ->     Parser a +newtype Capability = Capability {unCapability :: Text}+  deriving stock (Generic)+  deriving newtype (Show, Eq, Ord, IsString)++instance Validity Capability++-- | The annotation for any setting reading secrets.+--+-- We add these so that we can disable them in settings checks, to avoid+-- failing settings checks when secrets are read at runtime instead of+-- build-time.+readSecretCapability :: String+readSecretCapability = "read-secret"+ instance Functor Parser where   -- We case-match to produce shallower parser structures.   fmap f = \case@@ -221,11 +248,11 @@     ParserSelect pe pf -> ParserSelect (fmap (fmap f) pe) (fmap (fmap f) pf)     ParserEmpty mLoc -> ParserEmpty mLoc     ParserAlt p1 p2 -> ParserAlt (fmap f p1) (fmap f p2)-    ParserCheck mLoc forgivable g p -> ParserCheck mLoc forgivable (fmap (fmap f) . g) p+    ParserCheck mLoc forgivable caps g p -> ParserCheck mLoc forgivable caps (fmap (fmap f) . g) p     ParserCommands mLoc mDefault cs -> ParserCommands mLoc mDefault $ map (fmap f) cs     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+    -- If we ever make Setting a functor, then we need to fmap here+    p -> ParserCheck Nothing True Set.empty (pure . Right . f) p  instance Applicative Parser where   pure = ParserPure@@ -250,7 +277,7 @@           ParserMany _ p -> isEmpty p           ParserSome _ p -> isEmpty p           ParserAllOrNothing _ p -> isEmpty p-          ParserCheck _ _ _ p -> isEmpty p+          ParserCheck _ _ _ _ p -> isEmpty p           ParserCommands _ _ cs -> null cs           ParserWithConfig _ pc ps -> isEmpty pc && isEmpty ps           ParserSetting _ _ -> False@@ -331,12 +358,14 @@             . showsPrec 11 mLoc             . showString " "             . go 11 p-      ParserCheck mLoc forgivable _ p ->+      ParserCheck mLoc forgivable caps _ p ->         showParen (d > 10) $           showString "Check "             . showsPrec 11 mLoc             . showString " "             . showsPrec 11 forgivable+            . showString " "+            . showsPrec 11 caps             . showString " _ "             . go 11 p       ParserCommands mLoc mDefault cs ->@@ -599,11 +628,11 @@  -- | Check a 'Parser' after the fact, purely. checkMapEither :: (HasCallStack) => (a -> Either String b) -> Parser a -> Parser b-checkMapEither func p = withFrozenCallStack $ checkMapIO (pure . func) p+checkMapEither f = withFrozenCallStack $ checkMapIO (pure . f)  -- | Check a 'Parser' after the fact, allowing IO. checkMapIO :: (HasCallStack) => (a -> IO (Either String b)) -> Parser a -> Parser b-checkMapIO = ParserCheck mLoc False+checkMapIO = ParserCheck mLoc False Set.empty   where     mLoc = snd <$> listToMaybe (getCallStack callStack) @@ -634,6 +663,26 @@   where     mLoc = snd <$> listToMaybe (getCallStack callStack) +-- | Require the given capability for running the given parser.+--+-- This lets us annotate a parser with a power that it needs to be executed so+-- that we can run a settings check without that power to still check the rest+-- of the parser.+--+-- This only makes sense when used with a 'checkMap', 'checkEither', 'mapIO',+-- 'runIO', or similar function because the capability requirement is attached+-- to the Check node in the parser tree.+-- When used without such a node, this will attach a no-op Check node to the+-- parser tree and as such still try to do all the parsing below but not above.+requireCapability :: (HasCallStack) => String -> Parser a -> Parser a+requireCapability capName = \case+  ParserCheck mLoc' forgivable caps f p ->+    ParserCheck mLoc' forgivable (Set.insert cap caps) f p+  p -> ParserCheck mLoc False (Set.singleton cap) (pure . Right) p+  where+    cap = Capability (T.pack capName)+    mLoc = snd <$> listToMaybe (getCallStack callStack)+ -- | Like 'checkMapMaybe', but allow trying the other side of any alternative if the result is Nothing. checkMapMaybeForgivable :: (HasCallStack) => (a -> Maybe b) -> Parser a -> Parser b checkMapMaybeForgivable func p =@@ -647,12 +696,11 @@  -- | Like 'checkMapEither', but allow trying the other side of any alternative if the result is Nothing. checkMapEitherForgivable :: (HasCallStack) => (a -> Either String b) -> Parser a -> Parser b-checkMapEitherForgivable func p = withFrozenCallStack $ checkMapIOForgivable (pure . func) p+checkMapEitherForgivable f = withFrozenCallStack $ checkMapIOForgivable (pure . f)  -- | Like 'checkMapIO', but allow trying the other side of any alternative if the result is Nothing.--- TODO add a SRCLoc here checkMapIOForgivable :: (HasCallStack) => (a -> IO (Either String b)) -> Parser a -> Parser b-checkMapIOForgivable = ParserCheck mLoc True+checkMapIOForgivable = ParserCheck mLoc True Set.empty   where     mLoc = snd <$> listToMaybe (getCallStack callStack) @@ -964,7 +1012,11 @@  -- | Load a secret from a text file, with 'readSecretTextFile' secretTextFileSetting :: (HasCallStack) => [Builder FilePath] -> Parser Text-secretTextFileSetting bs = withFrozenCallStack $ mapIO readSecretTextFile $ filePathSetting bs+secretTextFileSetting bs =+  withFrozenCallStack $+    requireCapability readSecretCapability $+      mapIO readSecretTextFile $+        filePathSetting bs  -- | Load a secret from a text file, with 'readSecretTextFile', or specify it -- directly@@ -990,7 +1042,13 @@     fileSetting p f = do       let s = completeBuilder $ mconcat [mapMaybeBuilder f b, reader str, metavar "FILE_PATH"]       guard $ p s-      pure $ mapIO (resolveFile' >=> readSecretTextFile) $ ParserSetting mLoc s+      pure $+        requireCapability readSecretCapability $+          -- These two mapIOs are not combined because the capability should+          -- only apply to the reading, not the resolving.+          mapIO readSecretTextFile $+            mapIO resolveFile' $+              ParserSetting mLoc s      bareOption = bareSetting settingTryOption $ \case       BuildTryArgument -> Nothing@@ -1117,7 +1175,7 @@       ParserMany _ p -> ParserMany Nothing (go p)       ParserSome _ p -> ParserSome Nothing (go p)       ParserAllOrNothing _ p -> ParserAllOrNothing Nothing (go p)-      ParserCheck _ forgivable f p -> ParserCheck Nothing forgivable f (go p)+      ParserCheck _ forgivable caps f p -> ParserCheck Nothing forgivable caps f (go p)       ParserCommands _ mDefault cs -> ParserCommands Nothing mDefault $ map commandEraseSrcLocs cs       ParserWithConfig _ p1 p2 -> ParserWithConfig Nothing (go p1) (go p2)       ParserSetting _ s -> ParserSetting Nothing s@@ -1154,7 +1212,7 @@       ParserMany mLoc p -> ParserMany mLoc <$> go p       ParserSome mLoc p -> ParserSome mLoc <$> go p       ParserAllOrNothing mLoc p -> ParserAllOrNothing mLoc <$> go p-      ParserCheck mLoc forgivable f p -> ParserCheck mLoc forgivable f <$> go p+      ParserCheck mLoc forgivable caps f p -> ParserCheck mLoc forgivable caps f <$> go p       ParserCommands mLoc mDefault cs -> ParserCommands mLoc mDefault <$> traverse (commandTraverseSetting func) cs       ParserWithConfig mLoc p1 p2 -> ParserWithConfig mLoc <$> go p1 <*> go p2       ParserSetting mLoc s -> ParserSetting mLoc <$> func s@@ -1183,7 +1241,7 @@       ParserMany _ p -> go p       ParserSome _ p -> go p       ParserAllOrNothing _ p -> go p -- TODO is this right?-      ParserCheck _ _ _ p -> go p+      ParserCheck _ _ _ _ p -> go p       ParserCommands _ _ cs -> M.unions $ map (go . commandParser) cs       ParserWithConfig _ p1 p2 -> M.union (go p1) (go p2)       -- The nothing part shouldn't happen but I don't know when it doesn't

@@ -1,15 +1,20 @@ {-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}  module OptEnvConf.Run-  ( runSettingsParser,-    runParser,+  ( Capabilities (..),+    allCapabilities,+    enableCapability,+    disableCapability,     runParserOn,     runHelpParser,-    internalParser,   ) where @@ -29,282 +34,52 @@ import Data.Map (Map) import qualified Data.Map as M import Data.Maybe+import Data.Set (Set)+import qualified Data.Set as Set import qualified Data.Text as T import Data.Traversable-import Data.Version+import Data.Validity (Validity)+import GHC.Generics (Generic) import GHC.Stack (SrcLoc) import OptEnvConf.Args as Args-import OptEnvConf.Completion import OptEnvConf.Doc import OptEnvConf.EnvMap (EnvMap (..)) import qualified OptEnvConf.EnvMap as EnvMap import OptEnvConf.Error-import OptEnvConf.Lint-import OptEnvConf.Nix import OptEnvConf.NonDet import OptEnvConf.Output import OptEnvConf.Parser import OptEnvConf.Reader import OptEnvConf.Setting-import OptEnvConf.Terminal (getTerminalCapabilitiesFromHandle) import OptEnvConf.Validation-import Path-import System.Environment (getArgs, getEnvironment, getProgName)-import System.Exit import System.IO import Text.Colour --- | Run 'runParser' on your @Settings@' type's 'settingsParser'.------ __This is most likely the function you want to be using.__-runSettingsParser ::-  (HasParser a) =>-  -- | Program version, get this from Paths_your_package_name-  Version ->-  -- | Program description-  String ->-  IO a-runSettingsParser version progDesc =-  runParser version progDesc settingsParser---- | Run a parser------ This function with exit on:------     * Parse failure: show a nice error message.---     * @-h|--help@: Show help text---     * @--version@: Show version information---     * @--render-man-page@: Render a man page---     * @--bash-completion-script@: Render a bash completion script---     * @--zsh-completion-script@: Render a zsh completion script---     * @--fish-completion-script@: Render a fish completion script---     * @query-opt-env-conf-completion@: Perform a completion query------ This gets the arguments and environment variables from the current process.-runParser ::-  -- | Program version, get this from Paths_your_package_name-  Version ->-  -- | Program description-  String ->-  Parser a ->-  IO a-runParser version progDesc p = do-  allArgs <- getArgs-  let argMap' = parseArgs allArgs-  let mArgMap = consumeSwitch ["--debug-optparse"] argMap'-  let (debugMode, argMap) = case mArgMap of-        Nothing -> (False, argMap')-        Just am -> (True, am)--  completeEnv <- getEnvironment-  let envVars = EnvMap.parse completeEnv--  case lintParser p of-    Just errs -> do-      tc <- getTerminalCapabilitiesFromHandle stderr-      hPutChunksLocaleWith tc stderr $ renderLintErrors errs-      exitFailure-    Nothing -> do-      let docs = parserDocs p--      mDebugMode <--        if debugMode-          then Just <$> getTerminalCapabilitiesFromHandle stderr-          else pure Nothing+-- Set of disabled capabilities+newtype Capabilities = Capabilities {unCapabilities :: Set Capability}+  deriving (Show, Generic) -      let mHelpConsumed = consumeSwitch ["-h", "--help"] argMap-      let (helpMode, args') = case mHelpConsumed of-            Nothing -> (False, argMap)-            Just am -> (True, am)+instance Validity Capabilities -      if helpMode-        then do-          progname <- getProgName-          errOrDocs <- runHelpParser mDebugMode args' 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 version progDesc docs-                Just (path, cDoc) -> renderCommandHelpPage progname path cDoc-              exitSuccess-        else do-          let mCheckConsumed = consumeSwitch ["--run-settings-check"] args'-          let (checkMode, args) = case mCheckConsumed of-                Nothing -> (False, args')-                Just am -> (True, am)+allCapabilities :: Capabilities+allCapabilities = Capabilities {unCapabilities = Set.empty} -          if checkMode-            then do-              stderrTc <- getTerminalCapabilitiesFromHandle stderr-              errOrSets <- runParserOn (Just stderrTc) p args envVars Nothing-              case errOrSets of-                Left errs -> do-                  hPutChunksLocaleWith stderrTc stderr $ renderErrors errs-                  exitFailure-                Right _ -> do-                  tc <- getTerminalCapabilitiesFromHandle stdout-                  hPutChunksLocaleWith tc stdout ["Settings parsed successfully."]-                  exitSuccess-            else do-              let p' = internalParser p-              errOrResult <--                runParserOn-                  mDebugMode-                  p'-                  args-                  envVars-                  Nothing-              case errOrResult of-                Left errs -> do-                  tc <- getTerminalCapabilitiesFromHandle stderr-                  hPutChunksLocaleWith tc stderr $ renderErrors errs-                  exitFailure-                Right i -> case i of-                  ShowVersion -> do-                    progname <- getProgName-                    tc <- getTerminalCapabilitiesFromHandle stdout-                    hPutChunksLocaleWith tc stdout $ renderVersionPage progname version-                    exitSuccess-                  RenderMan -> do-                    progname <- getProgName-                    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-                  BashCompletionScript progPath -> do-                    progname <- getProgName-                    generateBashCompletionScript progPath progname-                    exitSuccess-                  ZshCompletionScript progPath -> do-                    progname <- getProgName-                    generateZshCompletionScript progPath progname-                    exitSuccess-                  FishCompletionScript progPath -> do-                    progname <- getProgName-                    generateFishCompletionScript progPath progname-                    exitSuccess-                  CompletionQuery enriched index ws -> do-                    runCompletionQuery p' enriched index ws-                    exitSuccess-                  ParsedNormally a -> pure a+enableCapability :: Capability -> Capabilities -> Capabilities+enableCapability cap (Capabilities caps) =+  Capabilities (Set.delete cap caps) --- Internal structure to help us do what the framework--- is supposed to.-data Internal a-  = ShowVersion-  | RenderMan-  | RenderDocumentation-  | RenderNixosOptions-  | BashCompletionScript (Path Abs File)-  | ZshCompletionScript (Path Abs File)-  | FishCompletionScript (Path Abs File)-  | CompletionQuery-      -- Enriched-      !Bool-      -- Index-      !Int-      -- Args-      ![String]-  | ParsedNormally !a+disableCapability :: Capability -> Capabilities -> Capabilities+disableCapability cap (Capabilities caps) =+  Capabilities (Set.insert cap caps) -internalParser :: Parser a -> Parser (Internal a)-internalParser p =-  choice-    [ setting-        [ switch ShowVersion,-          long "version",-          hidden-        ],-      setting-        [ switch RenderMan,-          long "render-man-page",-          hidden,-          help "Render a manpage"-        ],-      setting-        [ switch RenderDocumentation,-          long "render-reference-documentation",-          hidden,-          help "Render reference documentation"-        ],-      setting-        [ switch RenderNixosOptions,-          long "render-nix-options",-          hidden,-          help "Render Nix options"-        ],-      BashCompletionScript-        <$> setting-          [ option,-            reader $ maybeReader parseAbsFile,-            long "bash-completion-script",-            hidden,-            help "Render the bash completion script"-          ],-      ZshCompletionScript-        <$> setting-          [ option,-            reader $ maybeReader parseAbsFile,-            long "zsh-completion-script",-            hidden,-            help "Render the zsh completion script"-          ],-      ZshCompletionScript-        <$> setting-          [ option,-            reader $ maybeReader parseAbsFile,-            long "fish-completion-script",-            hidden,-            help "Render the fish completion script"-          ],-      setting-        [ help "Query completion",-          switch CompletionQuery,-          -- Long string that no normal user would ever use.-          long "query-opt-env-conf-completion",-          hidden-        ]-        <*> setting-          [ switch True,-            long "completion-enriched",-            value False,-            hidden,-            help "Whether to enable enriched completion"-          ]-        <*> setting-          [ option,-            reader auto,-            long "completion-index",-            hidden,-            help "The index between the arguments where completion was invoked."-          ]-        <*> many-          ( setting-              [ option,-                reader str,-                long "completion-word",-                hidden,-                help "The words (arguments) that have already been typed"-              ]-          ),-      ParsedNormally <$> p-    ]+missingCapabilities :: Capabilities -> Set Capability -> Maybe (NonEmpty Capability)+missingCapabilities (Capabilities caps) requiredCapabilities =+  NE.nonEmpty (Set.toList (Set.intersection requiredCapabilities caps))  -- | Run a parser on given arguments and environment instead of getting them -- from the current process. runParserOn ::+  Capabilities ->   -- DebugMode   Maybe TerminalCapabilities ->   Parser a ->@@ -312,7 +87,7 @@   EnvMap ->   Maybe JSON.Object ->   IO (Either (NonEmpty ParseError) a)-runParserOn mDebugMode parser args envVars mConfig = do+runParserOn capabilities mDebugMode parser args envVars mConfig = do   let ppState =         PPState           { ppStateArgs = args,@@ -344,6 +119,7 @@                 Nothing ->                   pure $                     Left $+                      -- Only show source locations in debug mode.                       let f = case mDebugMode of                             Nothing -> eraseErrorSrcLocs                             Just _ -> id@@ -425,21 +201,30 @@                   if null parsedSettingsMap                     then ppErrors' errs                     else ppErrors' $ errs <> (ParseError mLoc (ParseErrorAllOrNothing parsedSettingsMap) :| [])-      ParserCheck mLoc forgivable f p' -> do+      ParserCheck mLoc forgivable requiredCapabilities f p' -> do         debug [syntaxChunk "Parser with check", ": ", mSrcLocChunk mLoc]+        when (not (Set.null requiredCapabilities)) $+          debug $+            "Requires capabilities: "+              : capabilitiesChunks requiredCapabilities+         ppIndent $ do           debug ["parser"]+          -- Definitely parse below           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+          -- Only perform the check (IO) if capabilities are sufficient+          ppIndent $ case missingCapabilities capabilities requiredCapabilities of+            Just missings -> ppErrors mLoc $ NE.map ParseErrorMissingCapability missings+            Nothing -> 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 mDefault cs -> do         debug [syntaxChunk "Commands", ": ", mSrcLocChunk mLoc]         forM_ mDefault $ \d -> debug ["default:", chunk $ T.pack $ show d]@@ -778,7 +563,7 @@             ParserAllOrNothing mLoc p' -> do               debug [syntaxChunk "AllOrNothing", ": ", mSrcLocChunk mLoc]               ppIndent $ go p'-            ParserCheck mLoc _ _ p' -> do+            ParserCheck mLoc _ _ _ p' -> do               debug [syntaxChunk "Parser with check", ": ", mSrcLocChunk mLoc]               ppIndent $ go p'             ParserWithConfig mLoc pc pa -> do@@ -811,14 +596,23 @@                           Nothing -> Just (reverse path, commandParserDocs c)                           Just res -> pure res -type PP a = ReaderT PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a+newtype PP a = PP (ReaderT PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a)+  deriving+    ( Functor,+      Applicative,+      Selective,+      Monad,+      MonadIO,+      MonadReader PPEnv,+      MonadState PPState+    )  runPP ::   PP a ->   PPState ->   PPEnv ->   IO [(Validation ParseError a, PPState)]-runPP p args envVars =+runPP (PP p) args envVars =   runNonDetT (runStateT (runValidationT (runReaderT p envVars)) args)  runPPLazy ::@@ -831,7 +625,7 @@           NonDetT IO (Validation ParseError a, PPState)         )     )-runPPLazy p args envVars =+runPPLazy (PP p) args envVars =   runNonDetTLazy (runStateT (runValidationT (runReaderT p envVars)) args)  tryPP :: PP a -> PP (Maybe a)@@ -851,7 +645,7 @@       pure $ Just a  ppNonDet :: NonDetT IO a -> PP a-ppNonDet = lift . lift . lift+ppNonDet = PP . lift . lift . lift  ppNonDetList :: [a] -> PP a ppNonDetList = ppNonDet . liftNonDetTList@@ -923,7 +717,7 @@       pure (Just ())  ppErrors' :: NonEmpty ParseError -> PP a-ppErrors' = lift . ValidationT . lift . pure . Failure+ppErrors' = PP . lift . ValidationT . lift . pure . Failure  ppErrors :: Maybe SrcLoc -> NonEmpty ParseErrorMessage -> PP a ppErrors mLoc = ppErrors' . NE.map (ParseError mLoc)