opt-env-conf 0.5.1.1 → 0.6.0.0

raw patch · 9 files changed

+113/−50 lines, 9 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• opt-env-conf.cabal +1/−1
• src/OptEnvConf.hs +1/−0
• src/OptEnvConf/Completion.hs +1/−1
• src/OptEnvConf/Doc.hs +37/−29
• src/OptEnvConf/Lint.hs +1/−1
• src/OptEnvConf/Nix.hs +1/−1
• src/OptEnvConf/Parser.hs +39/−13
• src/OptEnvConf/Run.hs +22/−4

@@ -1,5 +1,15 @@ # Changelog +## [0.6.0.0] - 2024-10-18++### Added++* `defaultCommand`++### Changed++* `commands` now takes `CommandsBuilder`s.+ ## [0.5.1.1] - 2024-08-08  ### Changed

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           opt-env-conf-version:        0.5.1.1+version:        0.6.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

@@ -36,6 +36,7 @@     -- ** Commands     commands,     command,+    defaultCommand,      -- ** Composing settings with the usual type-classes     optional,

@@ -204,7 +204,7 @@           Just os -> fmap (os ++) <$> go p       ParserAllOrNothing _ p -> go p       ParserCheck _ _ _ p -> go p-      ParserCommands _ cs -> do+      ParserCommands _ _ cs -> do         -- Don't re-use the state accross commands         Just . concat . catMaybes <$> mapM goCommand cs       ParserWithConfig _ p1 p2 -> do

@@ -100,7 +100,7 @@   deriving (Show)  data AnyDocs a-  = AnyDocsCommands [CommandDoc a]+  = AnyDocsCommands !(Maybe String) [CommandDoc a]   | AnyDocsAnd ![AnyDocs a]   | AnyDocsOr ![AnyDocs a]   | AnyDocsSingle !a@@ -121,7 +121,7 @@ mapMaybeDocs' func = go   where     go = \case-      AnyDocsCommands cs -> AnyDocsCommands $ map goCommandDoc cs+      AnyDocsCommands mDefault cs -> AnyDocsCommands mDefault $ map goCommandDoc cs       AnyDocsAnd ds -> AnyDocsAnd $ map go ds       AnyDocsOr ds -> AnyDocsOr $ map go ds       AnyDocsSingle d -> maybe (AnyDocsAnd []) AnyDocsSingle $ func d@@ -132,7 +132,7 @@ simplifyAnyDocs = go   where     go = \case-      AnyDocsCommands cs -> AnyDocsCommands $ map goDoc cs+      AnyDocsCommands mDefault cs -> AnyDocsCommands mDefault $ map goDoc cs       AnyDocsAnd ds -> case concatMap goAnd ds of         [a] -> a         as -> AnyDocsAnd as@@ -142,13 +142,13 @@     goDoc cd = cd {commandDocs = go (commandDocs cd)}      goAnd = \case-      AnyDocsCommands c -> [AnyDocsCommands $ map goDoc c]+      AnyDocsCommands mDefault c -> [AnyDocsCommands mDefault $ map goDoc c]       AnyDocsAnd ds -> concatMap (goAnd . go) ds       AnyDocsOr [] -> []       ds -> [go ds]      goOr = \case-      AnyDocsCommands c -> [AnyDocsCommands $ map goDoc c]+      AnyDocsCommands mDefault c -> [AnyDocsCommands mDefault $ map goDoc c]       AnyDocsOr ds -> concatMap (goOr . go) ds       AnyDocsAnd [] -> []       ds -> [go ds]@@ -170,7 +170,7 @@       ParserSome p -> AnyDocsAnd [go p, go (ParserMany p)] -- TODO: is this right?       ParserAllOrNothing _ p -> go p       ParserCheck _ _ _ p -> go p-      ParserCommands _ cs -> AnyDocsCommands $ map commandParserDocs cs+      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 @@ -385,7 +385,7 @@  nullDocs :: AnyDocs a -> Bool nullDocs = \case-  AnyDocsCommands cs -> all nullCommandDoc cs+  AnyDocsCommands _ cs -> all nullCommandDoc cs   AnyDocsOr [] -> True   AnyDocsOr _ -> False   AnyDocsAnd [] -> True@@ -490,7 +490,7 @@     -- One section each, so we can add empty lines inbetween     go :: AnyDocs (NonEmpty SetDoc) -> [[[Chunk]]]     go = \case-      AnyDocsCommands _ -> []+      AnyDocsCommands _ _ -> []       AnyDocsAnd ds -> concatMap go ds       AnyDocsOr ds -> concatMap go ds       AnyDocsSingle (d :| ds) ->@@ -517,7 +517,7 @@       where         go' :: AnyDocs SetDoc -> AnyDocs (NonEmpty SetDoc)         go' = \case-          AnyDocsCommands _ -> AnyDocsCommands [] -- Don't care about commands here+          AnyDocsCommands _ _ -> AnyDocsCommands Nothing [] -- Don't care about commands here           AnyDocsOr ds -> AnyDocsOr $ goOr' ds           AnyDocsAnd ds -> AnyDocsAnd $ map go' ds           AnyDocsSingle d -> AnyDocsSingle (d :| [])@@ -539,20 +539,22 @@   where     go :: Bool -> AnyDocs SetDoc -> [[Chunk]]     go isTopLevel = \case-      AnyDocsCommands cs -> concatMap goCommand cs+      AnyDocsCommands mDefault cs -> concatMap (goCommand mDefault) 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 {..} =+    goCommand :: Maybe String -> CommandDoc SetDoc -> [[Chunk]]+    goCommand mDefault CommandDoc {..} =       indent $-        [helpChunk commandDocHelp]-          : ["command: ", commandChunk commandDocArgument]-          : go False commandDocs-          ++ [[]]+        let isDefault = mDefault == Just commandDocArgument+            suffix = if isDefault then " (default)" else ""+         in [helpChunk commandDocHelp]+              : ["command: ", commandChunk commandDocArgument, suffix]+              : go False commandDocs+              ++ [[]]      -- Group together settings with the same help (produced by combinators like enableDisableSwitch)     goOr :: Bool -> [AnyDocs SetDoc] -> [[Chunk]]@@ -592,14 +594,16 @@   where     go :: AnyDocs SetDoc -> [[[Chunk]]]     go = \case-      AnyDocsCommands cs -> concatMap goCommand cs+      AnyDocsCommands mDefault cs -> concatMap (goCommand mDefault) cs       AnyDocsAnd ds -> concatMap go ds       AnyDocsOr ds -> concatMap go ds       AnyDocsSingle _ -> [] -    goCommand :: CommandDoc SetDoc -> [[[Chunk]]]-    goCommand CommandDoc {..} =-      [indent [[commandChunk commandDocArgument], [helpChunk commandDocHelp]]]+    goCommand :: Maybe String -> CommandDoc SetDoc -> [[[Chunk]]]+    goCommand mDefault CommandDoc {..} =+      let isDefault = mDefault == Just commandDocArgument+          suffix = if isDefault then " (default)" else ""+       in [indent [[commandChunk commandDocArgument, suffix], [helpChunk commandDocHelp]]]  parserOptDocs :: Parser a -> AnyDocs (Maybe OptDoc) parserOptDocs = docsToOptDocs . parserDocs@@ -639,7 +643,9 @@       Maybe [Chunk]     go b =       \case-        AnyDocsCommands _ -> Just ["COMMAND"]+        AnyDocsCommands mDefault _ -> case mDefault of+          Nothing -> Just ["COMMAND"]+          Just _ -> Just ["[COMMAND]"]         AnyDocsAnd ds ->           case mapMaybe (go False) (withoutNothings ds) of             [] -> Nothing@@ -682,12 +688,14 @@   where     go :: AnyDocs OptDoc -> [[Chunk]]     go = \case-      AnyDocsCommands cs ->+      AnyDocsCommands mDefault cs ->         concatMap           ( \CommandDoc {..} ->-              indent $-                unwordsChunks [[commandChunk commandDocArgument], [helpChunk commandDocHelp]]-                  : indent (go commandDocs)+              let isDefault = mDefault == Just commandDocArgument+                  suffix = if isDefault then " (default)" else ""+               in indent $+                    unwordsChunks [[commandChunk commandDocArgument, suffix], [helpChunk commandDocHelp]]+                      : indent (go commandDocs)           )           cs       AnyDocsAnd ds -> case goTable (AnyDocsAnd ds) of@@ -700,7 +708,7 @@      goTable :: AnyDocs OptDoc -> Maybe [[[Chunk]]]     goTable = \case-      AnyDocsCommands _ -> Nothing+      AnyDocsCommands _ _ -> Nothing       AnyDocsAnd ds -> concat <$> mapM goTable ds       AnyDocsOr ds -> concat <$> mapM goTable ds       AnyDocsSingle od -> Just [renderOptDocLong od]@@ -746,7 +754,7 @@   where     go :: AnyDocs EnvDoc -> [[[Chunk]]]     go = \case-      AnyDocsCommands cs -> concatMap (go . commandDocs) cs+      AnyDocsCommands _ cs -> concatMap (go . commandDocs) cs       AnyDocsAnd ds -> concatMap go ds       AnyDocsOr ds -> concatMap go ds       AnyDocsSingle ed -> [indent $ renderEnvDoc ed]@@ -784,7 +792,7 @@  docsToCommandDocs :: AnyDocs (Maybe SetDoc) -> [CommandDoc (Maybe SetDoc)] docsToCommandDocs = \case-  AnyDocsCommands cs -> cs+  AnyDocsCommands _ cs -> cs   AnyDocsAnd ds -> concatMap docsToCommandDocs ds   AnyDocsOr ds -> concatMap docsToCommandDocs ds   AnyDocsSingle _ -> []@@ -795,7 +803,7 @@   where     go :: AnyDocs ConfDoc -> [[Chunk]]     go = \case-      AnyDocsCommands cs -> concatMap (go . commandDocs) cs+      AnyDocsCommands _ cs -> concatMap (go . commandDocs) cs       AnyDocsAnd ds -> concatMap go ds       AnyDocsOr ds -> concatMap go ds       AnyDocsSingle ed -> indent (renderConfDoc ed)

@@ -268,7 +268,7 @@         pure c       ParserAllOrNothing _ p -> go p       ParserCheck _ _ _ p -> go p-      ParserCommands mLoc ls -> do+      ParserCommands mLoc _ ls -> do         if null ls           then validationTFailure $ LintError mLoc LintErrorNoCommands           else and <$> traverse (go . commandParser) ls -- TODO is this right?

@@ -40,7 +40,7 @@       ParserSome p -> go p       ParserAllOrNothing _ p -> go p       ParserCheck _ _ _ p -> go p-      ParserCommands _ cs -> M.unionsWith combineOption $ map goCommand cs+      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

@@ -27,6 +27,7 @@     allOrNothing,     commands,     command,+    defaultCommand,     subArgs,     subArgs_,     subEnv,@@ -56,6 +57,7 @@     Parser (..),     HasParser (..),     Command (..),+    CommandsBuilder (..),     Metavar,     Help,     showParserABit,@@ -103,6 +105,10 @@ import Path.IO import Text.Show +data CommandsBuilder a+  = CommandsBuilderCommand !(Command a)+  | CommandsBuilderDefault !String+ data Command a = Command   { commandSrcLoc :: !(Maybe SrcLoc),     commandArg :: !String,@@ -187,6 +193,8 @@   -- Commands   ParserCommands ::     !(Maybe SrcLoc) ->+    -- Default command+    !(Maybe String) ->     ![Command a] ->     Parser a   -- | Load a configuration value and use it for the continuing parser@@ -210,7 +218,7 @@     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-    ParserCommands mLoc cs -> ParserCommands mLoc $ map (fmap f) cs+    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@@ -239,7 +247,7 @@           ParserSome p -> isEmpty p           ParserAllOrNothing _ p -> isEmpty p           ParserCheck _ _ _ p -> isEmpty p-          ParserCommands _ cs -> null cs+          ParserCommands _ _ cs -> null cs           ParserWithConfig _ pc ps -> isEmpty pc && isEmpty ps           ParserSetting _ _ -> False      in case (isEmpty p1, isEmpty p2) of@@ -262,10 +270,10 @@                   --          p                   --         / \                   -- p1 ++ p3   p4-                  (ParserCommands _ _, ParserAlt p3' p4') ->+                  (ParserCommands _ _ _, ParserAlt p3' p4') ->                     go (go p1' p3') p4'-                  (ParserCommands mLoc1 cs1, ParserCommands mLoc2 cs2) ->-                    ParserCommands (mLoc1 <|> mLoc2) (cs1 ++ cs2)+                  (ParserCommands mLoc1 mDefault1 cs1, ParserCommands mLoc2 mDefault2 cs2) ->+                    ParserCommands (mLoc1 <|> mLoc2) (mDefault1 <|> mDefault2) (cs1 ++ cs2)                   _ -> ParserAlt p1' p2'              in go p1 p2   many = ParserMany@@ -323,11 +331,13 @@             . showsPrec 11 forgivable             . showString " _ "             . go 11 p-      ParserCommands mLoc cs ->+      ParserCommands mLoc mDefault cs ->         showParen (d > 10) $           showString "Commands "             . showsPrec 11 mLoc             . showString " "+            . showsPrec 11 mDefault+            . showString " "             . showListWith               showCommandABit               cs@@ -604,9 +614,19 @@ -- | Declare multiple commands -- -- Use 'command' to define a 'Command'.-commands :: (HasCallStack) => [Command a] -> Parser a-commands = ParserCommands mLoc+commands :: (HasCallStack) => [CommandsBuilder a] -> Parser a+commands cbs =+  let (mDefault, cs) = go cbs+   in ParserCommands mLoc mDefault cs   where+    go :: [CommandsBuilder a] -> (Maybe String, [Command a])+    go = \case+      [] -> (Nothing, [])+      (b : bs) ->+        let (mDefault, cs) = go bs+         in case b of+              CommandsBuilderCommand c -> (mDefault, c : cs)+              CommandsBuilderDefault d -> (mDefault <|> Just d, cs)     mLoc = snd <$> listToMaybe (getCallStack callStack)  -- | Declare a single command with a name, documentation and parser@@ -618,11 +638,17 @@   String ->   -- | Parser   Parser a ->-  Command a-command = Command mLoc+  CommandsBuilder a+command n docs parser = CommandsBuilderCommand $ Command mLoc n docs parser   where     mLoc = snd <$> listToMaybe (getCallStack callStack) +defaultCommand ::+  -- | Name+  String ->+  CommandsBuilder a+defaultCommand = CommandsBuilderDefault+ -- | Load a configuration value and use it for the given parser withConfig :: (HasCallStack) => Parser (Maybe JSON.Object) -> Parser a -> Parser a withConfig = ParserWithConfig mLoc@@ -956,7 +982,7 @@       ParserSome p -> ParserSome (go p)       ParserAllOrNothing _ p -> ParserAllOrNothing Nothing (go p)       ParserCheck _ forgivable f p -> ParserCheck Nothing forgivable f (go p)-      ParserCommands _ cs -> ParserCommands Nothing $ map commandEraseSrcLocs cs+      ParserCommands _ mDefault cs -> ParserCommands Nothing mDefault $ map commandEraseSrcLocs cs       ParserWithConfig _ p1 p2 -> ParserWithConfig Nothing (go p1) (go p2)       ParserSetting _ s -> ParserSetting Nothing s @@ -993,7 +1019,7 @@       ParserSome p -> ParserSome <$> go p       ParserAllOrNothing mLoc p -> ParserAllOrNothing mLoc <$> go p       ParserCheck mLoc forgivable f p -> ParserCheck mLoc forgivable f <$> go p-      ParserCommands mLoc cs -> ParserCommands mLoc <$> traverse (commandTraverseSetting func) cs+      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 @@ -1022,7 +1048,7 @@       ParserSome p -> go p       ParserAllOrNothing _ p -> go p -- TODO is this right?       ParserCheck _ _ _ p -> go p-      ParserCommands _ cs -> S.unions $ map (go . commandParser) cs+      ParserCommands _ _ cs -> S.unions $ map (go . commandParser) cs       ParserWithConfig _ p1 p2 -> S.union (go p1) (go p2)       -- The nothing part shouldn't happen but I don't know when it doesn't       ParserSetting mLoc _ -> maybe S.empty (S.singleton . hashSrcLoc) mLoc

@@ -449,20 +449,37 @@               Right b -> do                 debug ["succeeded"]                 pure b-      ParserCommands mLoc cs -> do+      ParserCommands mLoc mDefault cs -> do         debug [syntaxChunk "Commands", ": ", mSrcLocChunk mLoc]+        forM_ mDefault $ \d -> debug ["default:", chunk $ T.pack $ show d]         ppIndent $ do+          stateBefore <- get           mS <- ppArg           let docsForErrors = map (void . commandParserDocs) cs+          let mDefaultCommand = do+                d <- mDefault+                find ((== d) . commandArg) cs           case mS of             Nothing -> do               debug ["No argument found for choosing a command."]-              ppError mLoc $ ParseErrorMissingCommand docsForErrors+              case mDefaultCommand of+                Nothing -> ppError mLoc $ ParseErrorMissingCommand docsForErrors+                Just dc -> do+                  debug ["Choosing default command: ", commandChunk (commandArg dc)]+                  go $ commandParser dc             Just s -> do               case find ((== s) . commandArg) cs of                 Nothing -> do                   debug ["Argument found, but no matching command: ", chunk $ T.pack $ show s]-                  ppError mLoc $ ParseErrorUnrecognisedCommand s docsForErrors+                  case mDefaultCommand of+                    Nothing -> ppError mLoc $ ParseErrorUnrecognisedCommand s docsForErrors+                    Just dc -> do+                      debug ["Choosing default command instead: ", commandChunk (commandArg dc)]+                      -- Put the state back to before we parsed 'ppArg' above+                      -- Maintainer note: We could try to un-parse this arg+                      -- somehow but that sounds more complicated to me.+                      put stateBefore+                      go $ commandParser dc                 Just c -> do                   debug ["Set command to ", commandChunk (commandArg c)]                   go $ commandParser c@@ -792,8 +809,9 @@             ParserSetting mLoc _ -> do               debug [syntaxChunk "Setting", ": ", mSrcLocChunk mLoc]               pure Nothing-            ParserCommands mLoc cs -> do+            ParserCommands mLoc mDefault cs -> do               debug [syntaxChunk "Commands", ": ", mSrcLocChunk mLoc]+              forM_ mDefault $ \d -> debug ["default:", chunk $ T.pack $ show d]               ppIndent $ do                 mS <- ppArg                 case mS of