mangrove-cli 0.4.0.0 → 0.5.0.0

raw patch · 13 files changed

+885/−420 lines, 13 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +17/−0
• mangrove-cli.cabal +2/−2
• src/Mangrove/ParseTree.hs +45/−25
• src/Mangrove/Render.hs +43/−0
• src/Mangrove/Scheme/Sub.hs +5/−2
• src/Mangrove/Scheme/Unix.hs +151/−132
• src/Mangrove/TextParser.hs +6/−0
• test/Arbitrary.hs +54/−34
• test/General.hs +0/−169
• test/Main.hs +1/−5
• test/Mangrove/ParseTreeSpec.hs +173/−51
• test/Mangrove/UnixSpec.hs +385/−0
• test/TestParsers.hs +3/−0

@@ -8,6 +8,23 @@  ## Unreleased +## 0.5.0.0 - 2026-10-31++### Added++- A `Usage` class for parsers that support usage information+- Unit tests and property tests for help output and usage information++### Changed++- Improve formatting of parser usage information so that bracketing+  expressions works in a more consistent way+- Switch to a single-column layout for option tables in UNIX help+  output+- Moved misc. unit tests from `General` module to `Mangrove.UnixSpec`+- Preserve discovery order of usage modes in help output+- Simplify applicative law tests+ ## 0.4.0.0 - 2026-09-13  ### Added

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           mangrove-cli-version:        0.4.0.0+version:        0.5.0.0 synopsis:       Build CLI argument parsers using Applicative. description:    Please see the README on GitHub at <https://github.com/quytelda/mangrove#readme> category:       CLI, Options, Parsing@@ -61,10 +61,10 @@   main-is: Main.hs   other-modules:       Arbitrary-      General       Mangrove.ParseTreeSpec       Mangrove.StreamSpec       Mangrove.Test.Stream+      Mangrove.UnixSpec       Spec       StructureEq       TestParsers

@@ -27,6 +27,12 @@   , isSum   , isOptional   , isChoice++    -- * Usage Precedences+  , prec_prod+  , prec_sum+  , prec_list+  , prec_optional   ) where  import           Control.Applicative@@ -167,32 +173,46 @@ isChoice (SumNode l r) = not (nullary l) && not (nullary r) isChoice _             = False -instance (Valency s, HasTokens s, forall a. Render (s a)) => Render (ParseTree s r) where-  -- special cases-  render n@(SumNode l _)-    | isOptional n = renderDelimitedIf brackets (not . isOptional) l+-- | Precedence values for different usage separators.+prec_prod, prec_sum, prec_list, prec_optional :: Int+prec_prod = 7+prec_sum = 3+prec_list = 14+prec_optional = 1 -  render (ParseNode parser) = render parser-  render (ProdNode _ l r)+instance (Valency s, HasTokens s, Usage s) => Usage (ParseTree s) where+  usagePrec d (SumNode l (ValueNode _))+    | nullary l = ""+    | otherwise =+      bracketsIf (d /= prec_optional) $ usagePrec prec_optional l+  usagePrec _ EmptyNode = ""+  usagePrec _ (ValueNode _) = ""+  usagePrec d (ParseNode p) =+    usagePrec d p+  usagePrec d (ProdNode _ l r)     | nullary l && nullary r = ""-    | nullary l = _render r-    | nullary r = _render l-    | otherwise = _render l <> render sep <> _render r-    where-      _render = renderDelimitedIf braces isChoice-      sep = delimiter (Proxy @s)-  render (SumNode l r)+    | nullary l = usagePrec d r+    | nullary r = usagePrec d l+    | otherwise =+      bracesIf (d > prec_prod || d == prec_sum)+      $ usagePrec prec_prod l+      <> render (delimiter (Proxy @s))+      <> usagePrec prec_prod r+  usagePrec d (SumNode l r)     | nullary l && nullary r = ""-    | nullary l = _render r-    | nullary r = _render l-    | otherwise = _render l <> "|" <> _render r-    where-      _render = renderDelimitedIf braces isProduct-  render (ManyNode required p) = wrap $ render p <> "..."-    where-      wrap = if required-             then braces-             else brackets+    | nullary l = usagePrec d r+    | nullary r = usagePrec d l+    | otherwise =+      bracesIf (d > prec_sum || d == prec_prod)+      $ usagePrec prec_sum l+      <> "|"+      <> usagePrec prec_sum r+  usagePrec d (ManyNode required p)+    | nullary p = ""+    | not required || isOptional p =+      bracketsIf (d /= prec_optional) $ usagePrec prec_list p <> "..."+    | otherwise =+      bracesIf (d >= prec_list) $ usagePrec prec_list p <> "..." -  -- Constant nodes that don't accept input have no usage.-  render _ = ""+instance (Valency s, HasTokens s, Usage s) => Render (ParseTree s r) where+  render = usage

@@ -20,16 +20,24 @@   , hPutBuilder      -- * Helpers & Combinators+  , munless   , between   , brackets   , braces   , quotes   , renderDelimitedIf+  , wrapIf+  , bracesIf+  , bracketsIf +    -- * Usage+  , Usage(..)+     -- * Re-exports   , Builder   ) where +import           Data.Kind import           Data.Text              (Text) import qualified Data.Text              as T import qualified Data.Text.Lazy         as TL@@ -73,6 +81,10 @@ -------------------------------------------------------------------------------- -- Combinators +-- | Similar to 'Control.Monad.unless', but for monoids.+munless :: Monoid m => Bool -> m -> m+munless condition m = if condition then mempty else m+ -- | @between open close s@ surrounds @s@ with @open@ and @close@ -- (i.e. @open <> s <> close@). between :: Monoid m => m -> m -> m -> m@@ -90,9 +102,40 @@ quotes :: Builder -> Builder quotes = between "\"" "\"" +-- | Combinator to modify an expression using some wrapping function+-- if a condition is 'True'.+wrapIf :: (Builder -> Builder) -> Bool -> Builder -> Builder+wrapIf wrap True  = wrap+wrapIf _    False = id++-- | Optionally wrap an expression with braces+bracesIf :: Bool -> Builder -> Builder+bracesIf = wrapIf braces++-- | Optionally wrap an expression with brackets+bracketsIf :: Bool -> Builder -> Builder+bracketsIf = wrapIf brackets+ -- | @renderDelimitedIf wrap f x@ will render @x@ as a 'Builder'. If -- the condition @f x@ is @True@, the result will be modified using -- the function @wrap@, otherwise the result will be returned -- unmodified. renderDelimitedIf :: Render a => (Builder -> Builder) -> (a -> Bool) -> a -> Builder renderDelimitedIf wrap f x = (if f x then wrap else id) (render x)++--------------------------------------------------------------------------------+-- Usage++-- | A class for parsers that support generation of usage information.+class Usage (p :: Type -> Type) where++  -- | Generate nicely formatted usage information for a parser. This+  -- similar to 'showsPrec'.+  usagePrec :: Int -> p r -> Builder+  usagePrec _ = usage++  -- | Generate nicely formatted usage information for a parser.+  --+  -- Default implementation is equivalent to @usagePrec 0@.+  usage :: p r -> Builder+  usage = usagePrec 0

@@ -98,9 +98,12 @@           empty       _ -> empty +instance Usage SubScheme where+  usagePrec _ (Parameter tp)  = usage tp+  usagePrec _ (Option key tp) = render key <> "=" <> usage tp+ instance Render (SubScheme r) where-  render (Parameter tp)  = render $ parserHint tp-  render (Option key tp) = render key <> "=" <> render (parserHint tp)+  render = usage  instance Render (Token SubScheme) where   render (SubAssoc key value) = render key <> "=" <> render value

@@ -4,7 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase        #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE RankNTypes        #-} {-# LANGUAGE TypeFamilies      #-} {-# LANGUAGE ViewPatterns      #-} @@ -38,8 +38,8 @@ import           Control.Applicative import           Control.Monad import           Control.Monad.Except-import qualified Data.List              as List-import           Data.List.NonEmpty     (NonEmpty)+import           Data.Foldable+import           Data.List.NonEmpty     (NonEmpty (..), nonEmpty) import qualified Data.List.NonEmpty     as NonEmpty import           Data.Map.Strict        (Map) import qualified Data.Map.Strict        as Map@@ -47,7 +47,6 @@ import           Data.String import           Data.Text              (Text) import qualified Data.Text              as T-import qualified Data.Text.Lazy         as TL import qualified Data.Text.Lazy.Builder as TLB import           Data.Version import           Data.Void@@ -79,8 +78,8 @@ -- Thus, you can write @"--flop"@ instead of @LongFlag "flop"@ and -- @"-c"@ instead of @ShortFlag \'c\'@. data Flag-  = LongFlag !Text-  | ShortFlag !Char+  = ShortFlag !Char+  | LongFlag !Text   deriving (Eq, Generic, Ord, Show)  instance IsString Flag where@@ -139,8 +138,8 @@   -> ProgramInfo   -> Text respondHelpRequest cmds tree info = renderText-  $ "Usage:\n"-  <> formatUsages (programName info) usages <> "\n\n"+  $ "Usage(s):\n"+  <> formatUsages (programName info) usages <> "\n"   <> render (programDesc info) <> "\n"   <> renderHelp tree cmds   where@@ -220,7 +219,7 @@       Nothing     -> pure (LongFlag s, Nothing) parseUnixOption (T.stripPrefix "-" >=> T.uncons -> Just (k,v))   | k /= '-' =-    pure (ShortFlag k, if T.null v then Nothing else Just v)+    pure (ShortFlag k, munless (T.null v) $ Just v) parseUnixOption _ = empty  -- | Does this text look like a flag? We check whether it starts with@@ -355,21 +354,36 @@       satiate subtree       >>= resolveLifted +prec_bind :: Int+prec_bind = 12++instance Usage UnixScheme where+  usagePrec _ (Parameter tp) =+    usage tp+  usagePrec _ (RequestOption info _) =+    render $ optHead info+  usagePrec d (Option info subtree)+    | nullary subtree = render flag+    | otherwise =+        bracesIf (d > prec_bind)+        $ render flag+        <> separator+        <> usagePrec prec_prod subtree+    where+      flag = optHead info+      separator = case flag of+        LongFlag _ -> "="+        _          -> ""+  usagePrec d (Command info subtree) =+    bracesIf (d > prec_bind)+    $ render (cmdHead info) <> params+    where+      params =+        munless (nullary subtree)+        $ " " <> usagePrec prec_prod subtree+ instance Render (UnixScheme r) where-  render (Parameter tp) = render $ parserHint tp-  render (Command info subtree) =-    "{" <> render (cmdHead info) <> " " <> render subtree <> "}"-  render (Option info subtree) =-    render flag-    <> if nullary subtree-       then mempty-       else separator <> renderDelimitedIf braces isChoice subtree-    where flag = optHead info-          separator = case flag of-                        LongFlag _ -> "="-                        _          -> ""-  render (RequestOption info _) =-    render (optHead info)+  render = usage  instance Render (Token UnixScheme) where   render (UnixArgument s)                      = render s@@ -378,15 +392,40 @@   render (UnixOption f@(LongFlag _) (Just v))  = render f <> "=" <> render v   render (UnixOption f@(ShortFlag _) (Just v)) = render f <> render v --- | A factored group of subtrees (branches) representing different--- usage modes.+-- | Convenient type alias for Unix-flavored parse trees.+type UnixParser = ParseTree UnixScheme++--------------------------------------------------------------------------------+-- Decomposing Trees++data Branch r+  = ReqBranch (ParseTree UnixScheme Void) -- ^ Request branches+  | CmdBranch (ParseTree UnixScheme r)    -- ^ Command branches+  deriving (Functor, Show)++unwrapBranch :: Branch r -> ParseTree UnixScheme r+unwrapBranch (ReqBranch b) = vacuous b+unwrapBranch (CmdBranch b) = b++-- | Alter the shape of a 'Branch'.+mapBranch+  :: (forall a. ParseTree UnixScheme a -> ParseTree UnixScheme a)+  -> Branch r+  -> Branch r+mapBranch f (ReqBranch b) = ReqBranch $ f b+mapBranch f (CmdBranch b) = CmdBranch $ f b++-- | A factored group of subtrees representing different usage modes. data Usages a = Usages-  [ParseTree UnixScheme Void]      -- ^ Request branches-  (Maybe (ParseTree UnixScheme a)) -- ^ Uncategorized branch-  [ParseTree UnixScheme a]         -- ^ Command branches+  (Maybe (ParseTree UnixScheme a)) -- ^ Trunk+  [Branch a]                       -- ^ Branches --- | Factor a 'ParseTree' into several independant subtrees--- (branches), potentially filtered to specific commands.+usagesToList :: Usages r -> [ParseTree UnixScheme r]+usagesToList (Usages trunk branches) =+  maybeToList trunk <> fmap unwrapBranch branches++-- | Factor a 'ParseTree' into several independant subtrees (a trunk+-- and branches), potentially filtered to specific commands. -- -- Each branch can be thought of as corresponding to one particular -- mode of operation, in that it contains at least one command or@@ -402,20 +441,20 @@   -- If we're currently searching for a specific command, then   -- this request option is irrelevant.   let node = ParseNode (RequestOption info mkRequest)-  in Usages [node | null commands] Nothing []+  in Usages Nothing [ReqBranch node | null commands]  decomposeTree (ParseNode (Command info subtree)) commands   | commandMismatch =     -- We are looking for a specific command and it's not this     -- one, so don't return any trees.-    Usages [] Nothing []+    Usages Nothing []   | otherwise =     -- Either this is the command we're looking for, or we're not     -- looking for a command.-    let Usages req misc cmd = decomposeTree subtree (drop 1 commands)-        req' = ParseNode . Command info <$> req-        cmd' = ParseNode . Command info <$> maybeToList misc <> cmd-    in Usages req' Nothing cmd'+    let Usages trunk branches = decomposeTree subtree (drop 1 commands)+    in Usages Nothing+       $ mapBranch (ParseNode . Command info)+       <$> maybeToList (fmap CmdBranch trunk) <> branches   where     commandMismatch =       case commands of@@ -423,22 +462,20 @@         []            -> False  decomposeTree (SumNode l r) commands =-  let Usages reqLs miscL cmdLs = decomposeTree l commands-      Usages reqRs miscR cmdRs = decomposeTree r commands+  let Usages trunkL branchLs = decomposeTree l commands+      Usages trunkR branchRs = decomposeTree r commands -      -- When both subtrees yield uncategorized branches, then we-      -- want to sum them normally. However, if only one subtree-      -- yields an uncategorized branch, we can just replace sum-      -- with that branch.-      misc = liftA2 SumNode miscL miscR-             <|> miscL-             <|> miscR-  in Usages (reqLs <> reqRs) misc (cmdLs <> cmdRs)+      -- If both subtrees have trunks, we want to sum them normally.+      -- However, if only one subtree yields a trunk, we can replace+      -- the sum with it.+      trunk = liftA2 SumNode trunkL trunkR+             <|> trunkL+             <|> trunkR+  in Usages trunk (branchLs <> branchRs)  decomposeTree (ProdNode f l r) commands =-  let Usages reqLs miscL cmdLs = decomposeTree l commands-      Usages reqRs miscR cmdRs = decomposeTree r commands-      prod = ProdNode f+  let Usages trunkL branchLs = decomposeTree l commands+      Usages trunkR branchRs = decomposeTree r commands        -- Requests prevent any further parsing, so if one of the       -- subtrees yields request branches, the other subtree is@@ -446,24 +483,22 @@       -- branches, then a product node behaves effectively like a       -- sum node because we could never actually trigger both       -- requests.-      reqs = reqRs <> reqLs-      misc = liftA2 prod miscL miscR-      cmds = liftA2 prod (maybeToList miscL) cmdRs <>-             liftA2 prod cmdLs (maybeToList miscR)-  in Usages reqs misc cmds+      graft with _trunk _branches = _branches >>= \case+        ReqBranch b -> pure $ ReqBranch b+        CmdBranch b -> CmdBranch . with b <$> maybeToList _trunk -decomposeTree tree _ = Usages [] (Just tree) []+      prod = ProdNode f+      trunk = liftA2 prod trunkL trunkR+      branches = graft (flip prod) trunkL branchRs <>+                 graft prod        trunkR branchLs+  in Usages trunk branches -formatUsages :: Text -> Usages r -> Builder-formatUsages progName (Usages reqs misc cmds) =-  mconcat-  $ List.intersperse "\n"-  $ map (\t -> TLB.fromText progName <> " " <> render t) usageModes-  where-    usageModes = map vacuous reqs <> maybeToList misc <> cmds+decomposeTree tree _ = Usages (Just tree) [] --- | Convenient type alias for Unix-flavored parse trees.-type UnixParser = ParseTree UnixScheme+formatUsages :: Text -> Usages r -> Builder+formatUsages progName =+  foldMap (\tree -> "  " <> render progName <> " " <> usage tree <> "\n")+  . usagesToList  -------------------------------------------------------------------------------- -- Help@@ -490,41 +525,37 @@     go (ManyNode require p) = ManyNode require (go p)     go node = node -data OptionHelp = OptionHelp-  { colShorts :: !TL.Text -- Column 1-  , colLongs  :: !TL.Text -- Column 2-  , colArg    :: !TL.Text -- Column 3-  , colDesc   :: !TL.Text -- Column 4-  } deriving (Eq, Ord, Show)+-- | Pretty-print a list of flags.+displayFlagList :: NonEmpty Flag -> Builder+displayFlagList =+  fold+  . NonEmpty.intersperse ", "+  . fmap render+  . NonEmpty.sort -makeOptionHelp :: OptionInfo -> ParseTree SubScheme r -> OptionHelp-makeOptionHelp OptionInfo{..} subtree =-  OptionHelp-  { colLongs  = fmtFlagList longs-  , colShorts = fmtFlagList shorts-  , colArg    = if nullary subtree-                then mempty-                else renderLazyText subtree-  , colDesc   = TL.fromStrict optHelp-  }-  where-    isLongFlag LongFlag{} = True-    isLongFlag _          = False-    (longs, shorts) = NonEmpty.partition isLongFlag optFlags-    fmtFlagList = TL.intercalate ", " . fmap renderLazyText+-- | Pretty-print a description of an option with the given+-- t'OptionInfo' and subtree.+displayOption :: OptionInfo -> ParseTree SubScheme r -> Builder+displayOption info subtree =+  let flagList = displayFlagList (optFlags info)+      paramInfo = if nullary subtree+                  then mempty+                  else " " <> render subtree+  in "  " <> flagList <> paramInfo <> "\n" <>+     "         " <> render (optHelp info) <> "\n"  -- | Enumerate descriptive information for all options available in a -- parse tree, indexed by the set of commands under which they exist.-collectOptions :: ParseTree UnixScheme r -> Map [CommandInfo] [OptionHelp]+collectOptions :: ParseTree UnixScheme r -> Map [CommandInfo] [Builder] collectOptions tree = go tree (Map.singleton [] [])   where     go :: ParseTree UnixScheme r-       -> Map [CommandInfo] [OptionHelp]-       -> Map [CommandInfo] [OptionHelp]+       -> Map [CommandInfo] [Builder]+       -> Map [CommandInfo] [Builder]     go (ParseNode (Option info subtree)) =-      Map.adjust (makeOptionHelp info subtree :) []+      Map.adjust (displayOption info subtree :) []     go (ParseNode (RequestOption info _)) =-      Map.adjust (makeOptionHelp info empty :) []+      Map.adjust (displayOption info empty :) []     go (ParseNode (Command info subtree)) =       Map.union $ Map.mapKeys (info :) $ collectOptions subtree     go (ProdNode _ l r) = go r . go l@@ -532,57 +563,45 @@     go (ManyNode _ p)   = go p     go _                = id -renderOptionTable :: [OptionHelp] -> Builder-renderOptionTable xs = foldMap formatRow $ List.sort xs+formatCommandList :: NonEmpty CommandInfo -> Text+formatCommandList cmdList =+  T.intercalate ", "+  $ T.unwords+  <$> qualifiedCmds   where-    maxLengthBy f = maximum $ TL.length . f <$> xs-    col1width = maxLengthBy colShorts-    col2width = maxLengthBy colLongs-    col3width = maxLengthBy colArg--    formatRow OptionHelp{..} =-      TLB.fromLazyText $ TL.intercalate "  "-      [ TL.justifyLeft col1width ' ' colShorts-      , TL.justifyLeft col2width ' ' colLongs-      , TL.justifyLeft col3width ' ' colArg-      , colDesc-      , "\n"-      ]+    currentNames = NonEmpty.toList $ cmdNames $ NonEmpty.last cmdList+    parentsNames = fmap cmdHead $ NonEmpty.init cmdList+    qualifiedCmds = [parentsNames <> [name] | name <- currentNames] -renderHeader :: [CommandInfo] -> Builder-renderHeader [] = mempty-renderHeader cmds@(info : _) =-  fmtCommand cmds-  <> " command"-  <> aliasInfo-  <> ": "-  <> render (cmdHelp info)-  <> "\n"-  where-    fmtCommand = quotes . render . T.unwords . fmap cmdHead . reverse-    aliases = NonEmpty.tail $ cmdNames info-    aliasInfo =-      if null aliases-      then mempty-      else " (alt: " <> render (T.intercalate ", " aliases) <> ")"+renderCmdHeader :: NonEmpty CommandInfo -> Builder+renderCmdHeader infos =+  render (formatCommandList infos) <> "\n"+  <> "  " <> (render . cmdHelp . NonEmpty.last) infos <> "\n\n"  -- | Format an index of commands and options for help output display.-renderTables :: Map [CommandInfo] [OptionHelp] -> Builder-renderTables =-  Map.foldlWithKey-  (\acc cmds desc ->-      acc-      <> "\n"-      <> renderHeader cmds-      <> renderOptionTable desc-  ) mempty+renderTables :: Map [CommandInfo] [Builder] -> Builder+renderTables m =+  case Map.findWithDefault [] [] m of+    [] -> mempty+    gs -> "\nGLOBAL OPTIONS\n\n"+          <> mconcat gs+  <>+  munless (all null (Map.keys m)) "\nSUBCOMMANDS\n"+  <>+  Map.foldrWithKey+  (\cmds bs acc ->+     case nonEmpty cmds of+       Nothing -> acc+       Just cmds' ->+         "\n" <> renderCmdHeader cmds' <> mconcat bs <> acc+  ) mempty m  -- | Select only the options tables which exist under a particular -- command sequence. selectSubtable   :: [Text]-  -> Map [CommandInfo] [OptionHelp]-  -> Map [CommandInfo] [OptionHelp]+  -> Map [CommandInfo] [a]+  -> Map [CommandInfo] [a] selectSubtable cmds =   Map.filterWithKey (\infos _ -> isParentCommand cmds infos) 

@@ -72,6 +72,12 @@   . showString (T.unpack hint)   . showString ">" +instance Usage TextParser where+  usagePrec _ TextParser{parserHint=hint} =+    if T.null hint+    then "ARG"+    else render hint+ -- | A more general function for running t'TextParser's. runTextParser :: MonadError Builder m => TextParser r -> Text -> m r runTextParser tp = liftEither . first TLB.fromText . parserRun tp

@@ -63,52 +63,69 @@   arbitrary = Name <$> genNameText  --------------------------------------------------------------------------------+-- Text Parsers++genTextParser :: Arbitrary a => Gen (TextParser a)+genTextParser = TextParser <$> genNameText <*> arbitrary++instance Arbitrary a => Arbitrary (TextParser a) where+  arbitrary = genTextParser++-------------------------------------------------------------------------------- -- Generic ParseTrees -genParser :: Scheme s => Gen (s Int) -> Gen (ParseTree s Int)+genParser+  :: (Arbitrary a, CoArbitrary a, Scheme s)+  => Gen (s a)+  -> Gen (ParseTree s a) genParser genScheme = sized $ \n -> oneof $   if n <= 0   then [ pure EmptyNode, ValueNode <$> arbitrary ]   else [ pure EmptyNode        , ValueNode <$> arbitrary        , ParseNode <$> genScheme-       , ProdNode <$> arbitrary @(Int -> Int -> Int)+       , ProdNode <$> arbitrary                   <*> genParser genScheme                   <*> genParser genScheme-       , SumNode <$> genParser genScheme <*> genParser genScheme-         -- ManyNode can only give us a `UnixParser [Int]`, so we have-         -- to wrap it in order to make the types match.-       , (fmap . fmap) sum $ ManyNode <$> arbitrary <*> genParser genScheme+       , SumNode <$> genParser genScheme+                 <*> genParser genScheme+         -- `ManyNode` can only give us a `ParseTree s [a]`, so we+         -- have to wrap it in order to make the types match. This+         -- also has the nice side-effect of ensuring we only generate+         -- trees whose structure is preserved under fmap.+       , liftA2 fmap arbitrary+         $ ManyNode <$> arbitrary+                    <*> genParser genScheme        ]  -------------------------------------------------------------------------------- -- SubScheme Parsers  instance Arbitrary (Token SubScheme) where-  arbitrary =-    oneof [ SubAssoc <$> genNameText <*> arbitrary-          , SubArgument <$> arbitrary-          ]+  arbitrary = oneof+    [ SubAssoc <$> genNameText <*> arbitrary+    , SubArgument <$> arbitrary+    ]  instance CoArbitrary (Token SubScheme) -genSubScheme :: Gen (SubScheme Int)-genSubScheme =-  oneof [ pure $ Sub.Parameter defaultParser-        , flip Sub.Option defaultParser <$> arbitrary-        ]+genSubScheme :: Arbitrary a => Gen (SubScheme a)+genSubScheme = oneof+  [ Sub.Parameter <$> arbitrary+  , Sub.Option <$> genNameText <*> arbitrary+  ] -instance Arbitrary (ParseTree SubScheme Int) where+instance (Arbitrary a, CoArbitrary a) => Arbitrary (ParseTree SubScheme a) where   arbitrary = genParser genSubScheme  -------------------------------------------------------------------------------- -- UnixScheme Parsers  instance Arbitrary Flag where-  arbitrary =-    oneof [ LongFlag <$> genNameText-          , ShortFlag <$> genNameChar-          ]+  arbitrary = oneof+    [ LongFlag <$> genNameText+    , ShortFlag <$> genNameChar+    ]  instance CoArbitrary Flag @@ -119,28 +136,31 @@   arbitrary = CommandInfo <$> fmap getNames arbitrary <*> arbitrary  instance Arbitrary (Token UnixScheme) where-  arbitrary =-    oneof [ UnixArgument <$> arbitrary-          , UnixCommand <$> genNameText-          , UnixOption <$> arbitrary <*> arbitrary-          ]+  arbitrary = oneof+    [ UnixArgument <$> arbitrary+    , UnixCommand <$> genNameText+    , UnixOption <$> arbitrary <*> arbitrary+    ]  instance CoArbitrary (Token UnixScheme)  instance Arbitrary UnixRequest where-  arbitrary = elements [HelpRequest [], VersionRequest]+  arbitrary = elements+    [ HelpRequest []+    , VersionRequest+    ]  instance CoArbitrary UnixRequest -genUnixScheme :: Gen (UnixScheme Int)-genUnixScheme =-  oneof [ pure $ Unix.Parameter defaultParser-        , Unix.Option <$> arbitrary <*> arbitrary-        , Unix.Command <$> arbitrary <*> arbitrary-        , Unix.RequestOption <$> arbitrary <*> arbitrary-        ]+genUnixScheme :: (Arbitrary a, CoArbitrary a) => Gen (UnixScheme a)+genUnixScheme = oneof+  [ Unix.Parameter <$> arbitrary+  , Unix.Option <$> arbitrary <*> arbitrary+  , Unix.Command <$> arbitrary <*> arbitrary+  , Unix.RequestOption <$> arbitrary <*> arbitrary+  ] -instance Arbitrary (ParseTree UnixScheme Int) where+instance (Arbitrary a, CoArbitrary a) => Arbitrary (ParseTree UnixScheme a) where   arbitrary = genParser genUnixScheme  --------------------------------------------------------------------------------

@@ -1,169 +0,0 @@-{-# LANGUAGE OverloadedLists   #-}-{-# LANGUAGE OverloadedStrings #-}--module General (spec) where--import           Control.Applicative-import           Test.Hspec--import           Mangrove-import           Mangrove.Render--import           TestParsers--optionSpec :: Spec-optionSpec = do-  it "parses long options" $ do-    runArgumentParser opt_example_unit ["--example"]-      `shouldBe` Success [] ()-  it "parses short options" $ do-    runArgumentParser opt_e_unit ["-e"]-      `shouldBe` Success [] ()--  it "parses options in any order" $ do-    runArgumentParser (opt_e_unit *> opt_f_unit) ["-e", "-f"]-      `shouldBe` Success [] ()-    runArgumentParser (opt_e_unit *> opt_f_unit) ["-f", "-e"]-      `shouldBe` Success [] ()--  describe "switches" $ do-    context "when switch is present" $ do-      it "yields True" $ do-        runArgumentParser opt_example_switch ["--example"]-          `shouldBe` Success [] True-    context "when switch is absent" $ do-      it "yields False" $ do-        runArgumentParser opt_example_switch []-          `shouldBe` Success [] False--  context "when a bound argument is provided" $ do-    context "when an argument is expected" $ do-      it "parses the argument" $ do-        runArgumentParser opt_example_param ["--example=qwer"]-          `shouldBe` Success [] "qwer"-        runArgumentParser opt_e_param ["-eqwer"]-          `shouldBe` Success [] "qwer"-    context "when no argument is expected" $ do-      it "parsing fails" $ do-        runArgumentParser opt_example_unit ["--example=qwer"]-          `shouldBe` Failure "--example=qwer: unrecognized subargument: qwer"-        runArgumentParser opt_e_unit ["-eqwer"]-          `shouldBe` Failure "-eqwer: unrecognized subargument: qwer"--  context "when no argument is expected" $ do-    context "when an argument is available" $ do-      it "doesn't consume the argument" $ do-        runArgumentParser opt_example_unit ["--example", "qwer"]-          `shouldBe` Success ["qwer"] ()--  context "when an argument is required" $ do-    it "renders with parameter hint" $ do-      render opt_example_param `shouldBe` "--example=STRING"-      render opt_e_param `shouldBe` "-eSTRING"--    context "when no argument is provided" $ do-      it "fails to parse" $ do-        runArgumentParser opt_example_param ["--example"]-          `shouldBe` Failure "--example: expected: STRING"-    context "when an argument is provided" $ do-      it "the argument is consumed" $ do-        runArgumentParser opt_example_param ["--example", "qwer"]-          `shouldBe` Success [] "qwer"--  context "when an argument is optional" $ do-    it "renders parameter hint in brackets" $ do-      render opt_example_param_optional `shouldBe` "--example=[STRING]"--    context "when no argument is provided" $ do-      it "yields a default value" $ do-        runArgumentParser opt_example_param_optional ["--example"]-          `shouldBe` Success [] "asdf"-      it "does not consume subsequent options" $ do-        runArgumentParser opt_example_param_optional ["--example", "--option"]-          `shouldBe` Success ["--option"] "asdf"-    context "when an argument is provided" $ do-      it "parses the argument" $ do-        runArgumentParser opt_example_param_optional ["--example", "qwer"]-          `shouldBe` Success [] "qwer"--  describe "compound options" $ do-    context "when the subtree accepts multiple arguments" $ do-      it "splits the input by delimiter" $ do-        runArgumentParser opt_example_pair ["--example", "1,3"]-          `shouldBe` Success [] (1,3)-    context "when the subtree can't accept multiple argument" $ do-      it "doesn't split the input by delimiter" $ do-        runArgumentParser opt_example_param ["--example", "1,3"]-          `shouldBe` Success [] "1,3"-        runArgumentParser opt_example_param_optional ["--example", "1,3"]-          `shouldBe` Success [] "1,3"--    context "when the subtree accepts suboptions" $ do-      it "parses key=value pairs" $ do-        runArgumentParser opt_example_subopt ["--example", "value=asdf"]-          `shouldBe` Success [] "asdf"-        runArgumentParser opt_example_subopt ["--example=value=asdf"]-          `shouldBe` Success [] "asdf"-    context "when the subtree can't accept suboptions" $ do-      it "doesn't parse key=value pairs" $ do-        runArgumentParser opt_example_param ["--example", "value=asdf"]-          `shouldBe` Success [] "value=asdf"-        runArgumentParser opt_example_param ["--example=value=asdf"]-          `shouldBe` Success [] "value=asdf"--  describe "help options" $ do-    let isRequest (Request {}) = True-        isRequest _            = False--    context "when a help option is present" $ do-      it "requests help" $ do-        runArgumentParser (withHelp opt_example_unit) ["--help"]-          `shouldSatisfy` isRequest-      it "works for subcommands" $ do-        runArgumentParser (withHelp cmd_example_tree) ["example", "--help"]-          `shouldSatisfy` isRequest-        runArgumentParser (withHelp cmd_example_tree) ["example", "asdf", "--help"]-          `shouldSatisfy` isRequest--    context "when a help option is absent" $ do-      it "doesn't request help" $ do-        runArgumentParser (withHelp opt_example_unit) ["--example"]-          `shouldBe` Success [] ()-        runArgumentParser (withHelp opt_example_unit) []-          `shouldBe` Failure "expected: --help or --example"-      it "isn't activated by escaped options" $ do-        runArgumentParser (withHelp opt_example_unit) ["--", "--help"]-          `shouldBe` Failure "unexpected --help"--generalSpec :: Spec-generalSpec = do-  context "when \"-\" is given as an argument" $ do-    it "parses the string \"-\"" $ do-      runArgumentParser param_text ["-"]-        `shouldBe` Success [] "-"--  context "when \"--\" is present in the argument list" $ do-    it "treats subsequent arguments as free arguments" $ do-      runArgumentParser param_text ["--", "asdf"]-        `shouldBe` Success [] "asdf"-    it "doesn't treat subsequent arguments as options" $ do-      runArgumentParser (option_asdf <|> param_text) ["--", "--asdf"]-        `shouldBe` Success [] "--asdf"-    it "doesn't treat subsequent arguments as commands" $ do-      runArgumentParser (command_asdf <|> param_text) ["--", "asdf"]-        `shouldBe` Success [] "asdf"--  context "when not enough input is provided" $ do-    it "fails to generate a result" $ do-      runArgumentParser param_text []-        `shouldBe` Failure "expected: STRING"--  context "when not all input can be consumed" $ do-    it "returns unconsumed arguments" $ do-      runArgumentParser param_text ["asdf", "qwer"]-        `shouldBe` Success ["qwer"] "asdf"--spec :: Spec-spec = do-  describe "General functionality" generalSpec-  describe "CLI Options" optionSpec

@@ -3,9 +3,5 @@ import qualified Spec import           Test.Hspec -import qualified General- main :: IO ()-main = hspec $ do-  General.spec-  Spec.spec+main = hspec Spec.spec

@@ -6,12 +6,14 @@  import           Control.Applicative import           Data.Text             (Text)+import qualified Data.Text             as T import           Test.Hspec import           Test.Hspec.QuickCheck import           Test.QuickCheck       hiding (Result (..))  import           Mangrove import           Mangrove.ParseTree+import           Mangrove.Render import           Mangrove.Scheme.Unix import           Mangrove.Valency @@ -41,55 +43,41 @@   :: ParseTree UnixScheme Int   -> ArgList   -> Bool-prop_applicativeIdLaw tree (ArgList args) =-  result1 == result2-  where-    result1 = runArgumentParser (pure id <*> tree) args-    result2 = runArgumentParser tree args+prop_applicativeIdLaw m (ArgList args) =+  runArgumentParser (pure id <*> m) args+  ==+  runArgumentParser m args  prop_applicativeHomLaw   :: Fun Int Int   -> Int   -> ArgList   -> Bool-prop_applicativeHomLaw (Fn f) value (ArgList args) =-  result1 == result2-  where-    tree1 = pure f <*> pure value :: ParseTree UnixScheme Int-    tree2 = pure (f value) :: ParseTree UnixScheme Int-    result1 = runArgumentParser tree1 args-    result2 = runArgumentParser tree2 args+prop_applicativeHomLaw (Fn f) x (ArgList args) =+  runArgumentParser (pure f <*> pure x :: UnixParser Int) args+  ==+  runArgumentParser (pure (f x) :: UnixParser Int) args  prop_applicativeIntLaw-  :: Fun (Int, Int) Int-  -> ParseTree UnixScheme Int+  :: ParseTree UnixScheme (Int -> Int)   -> Int   -> ArgList   -> Bool-prop_applicativeIntLaw (Fn2 f) tree n (ArgList args) =-  result1 == result2-  where-    u = fmap f tree-    result1 = runArgumentParser (u <*> pure n) args-    result2 = runArgumentParser (pure ($ n) <*> u) args+prop_applicativeIntLaw u y (ArgList args) =+  runArgumentParser (u <*> pure y) args+  ==+  runArgumentParser (pure ($ y) <*> u) args  prop_applicativeComLaw-  :: Fun (Int, Int) Int-  -> Fun (Int, Int) Int-  -> ParseTree UnixScheme Int-  -> ParseTree UnixScheme Int+  :: ParseTree UnixScheme (Int -> Int)+  -> ParseTree UnixScheme (Int -> Int)   -> ParseTree UnixScheme Int   -> ArgList   -> Bool-prop_applicativeComLaw (Fn2 f) (Fn2 g) t1 t2 w (ArgList args) =-  result1 == result2-  where-    u = fmap f t1-    v = fmap g t2-    tree1 = pure (.) <*> u <*> v <*> w-    tree2 = u <*> (v <*> w)-    result1 = runArgumentParser tree1 args-    result2 = runArgumentParser tree2 args+prop_applicativeComLaw u v w (ArgList args) =+  runArgumentParser (pure (.) <*> u <*> v <*> w) args+  ==+  runArgumentParser (u <*> (v <*> w)) args  -------------------------------------------------------------------------------- @@ -106,21 +94,6 @@ prop_liftA2AddsValencies l r =   valency (liftA2 (+) l r) == liftA2 (+) (valency l) (valency r) -prop_liftA2CombinesResults-  :: Fun (Int, Int) Int-  -> UnixParser Int-  -> UnixParser Int-  -> ArgList-  -> Bool-prop_liftA2CombinesResults (Fn2 f) l r (ArgList args) =-  case (resultL, resultR, resultA) of-    (Success _ x, Success _ y, Success _ z) -> z == f x y-    _ -> resultA == resultL || resultA == resultR-  where-    resultL = runArgumentParser l args-    resultR = runArgumentParser r args-    resultA = runArgumentParser (liftA2 f l r) args- prop_altMaxesValency   :: UnixParser Int   -> UnixParser Int@@ -150,6 +123,76 @@  -------------------------------------------------------------------------------- +prop_usageNullForNullaryNodes+  :: UnixParser Int+  -> Bool+prop_usageNullForNullaryNodes tree =+  nullary tree == (usage tree == "")++prop_bracketsOptionals+  :: UnixParser Int+  -> Bool+prop_bracketsOptionals tree =+  not (isOptional tree) || (isBracketed . renderText . usage) tree+  where+    isBracketed text = or $ do+      (start, _) <- T.uncons text+      (_, end)   <- T.unsnoc text++      pure $ start == '[' && end == ']'++prop_balancedBrackets+  :: UnixParser Int+  -> Bool+prop_balancedBrackets = testBalance 0 [] [] . renderText . usage+  where+    testBalance :: Int -> [Int] -> [Int] -> Text -> Bool+    testBalance index openBraces openBrackets text =+      case T.uncons text of+        Nothing -> null openBraces && null openBrackets+        Just ('{', text') ->+          testBalance (index + 1) (index : openBraces) openBrackets text'+        Just ('[', text') ->+          testBalance (index + 1) openBraces (index : openBrackets) text'+        Just ('}', text') ->+          case openBraces of+            [] -> False+            (match : openBraces')+              | match <= foldr const (-1) openBrackets -> False+              | otherwise ->+                testBalance (index + 1) openBraces' openBrackets text'+        Just (']', text') ->+          case openBrackets of+            [] -> False+            (match : openBrackets')+              | match <= foldr const (-1) openBraces -> False+              | otherwise ->+                testBalance (index + 1) openBraces openBrackets' text'+        Just (_, text') ->+          testBalance (index + 1) openBraces openBrackets text'++prop_noRedundantBrackets+  :: UnixParser Int+  -> Bool+prop_noRedundantBrackets =+  testBrackets 0 [] Nothing . renderText . usage+  where+    testBrackets :: Int -> [Int] -> Maybe (Int, Int) -> Text -> Bool+    testBrackets index opens lastSub text =+      case (T.uncons text, opens) of+        (Nothing, _) -> True+        (Just (c, text'), openIndex : opens')+          | c == '}' || c == ']' ->+            if lastSub == Just (openIndex+1, index-1)+            then False+            else testBrackets (index + 1) opens' (Just (openIndex, index)) text'+        (Just (c, text'), _)+          | c == '{' || c == '[' ->+            testBrackets (index + 1) (index : opens) lastSub text'+          | otherwise -> testBrackets (index + 1) opens lastSub text'++--------------------------------------------------------------------------------+ spec :: Spec spec = do   describe "Functor Instance" $ do@@ -178,7 +221,7 @@         `shouldBe` Success [] 'a'    describe "liftA2" $ do-    it "combines two values" $ do+    it "combines two pure values" $ do       runArgumentParser (liftA2 (+) (pure 1) (pure 2) :: ParseTree UnixScheme Int) []         `shouldBe` Success [] 3 @@ -186,8 +229,6 @@       runArgumentParser ((+) <$> pure 1 <*> pure 2 :: ParseTree UnixScheme Int) []         `shouldBe` Success [] 3 -    prop "combines results"-      prop_liftA2CombinesResults     prop "adds valencies"       prop_liftA2AddsValencies @@ -280,3 +321,84 @@     it "parses zero instances" $ do       runArgumentParser (optional opt_e_param) ["blah"]         `shouldBe` Success ["blah"] Nothing++  describe "Usage" $ do+    prop "usage is empty iff the tree is nullary"+      prop_usageNullForNullaryNodes++    prop "optional trees are bracketed"+      prop_bracketsOptionals++    prop "bracketing is balanced"+      prop_balancedBrackets++    prop "has no redundant bracketing"+      prop_noRedundantBrackets++    it "separates alternatives with pipes" $ do+      usage (opt_e_param <|> opt_example_param <|> cmd_example_tree)+        `shouldBe` "-eSTRING|--example=STRING|example asdf"++    it "separates series with the scheme delimiter" $ do+      usage ((,,) <$> opt_e_param <*> opt_example_param <*> cmd_example_tree)+        `shouldBe` "-eSTRING --example=STRING example asdf"++    it "brackets products inside sums" $ do+      usage ( (,) <$> opt_e_unit <*> opt_e_unit+              <|>+              (,) <$> opt_f_unit <*> opt_f_unit+            )+        `shouldBe` "{-e -e}|{-f -f}"++    it "brackets sums inside products" $ do+      usage ( (,)+              <$> (opt_e_unit <|> opt_f_unit)+              <*> (opt_example_param <|> opt_e_param)+            )+        `shouldBe` "{-e|-f} {--example=STRING|-eSTRING}"++    it "omits empty nodes from alternative lists" $ do+      usage (empty <|> empty :: UnixParser Int)+        `shouldBe` ""++      usage (empty <|> pure 0 <|> empty :: UnixParser Int)+        `shouldBe` ""++      usage ( empty+              <|> opt_e_param+              <|> empty+              <|> opt_example_param+              <|> cmd_example_tree+              <|> empty+            )+        `shouldBe` "-eSTRING|--example=STRING|example asdf"++    it "omits static nodes from series lists" $ do+      usage ((,) <$> empty <*> pure 0 :: UnixParser (Int, Int))+        `shouldBe` ""++      usage ( (,,,,,)+              <$> empty+              <*> opt_e_param+              <*> pure 'a'+              <*> opt_example_param+              <*> cmd_example_tree+              <*> empty+            )+        `shouldBe` "-eSTRING --example=STRING example asdf"++    it "repeatable inputs are followed by \"...\"" $ do+      usage (some opt_e_unit)+        `shouldBe` "-e..."++      usage opt_example_intList+        `shouldBe` "--example=INT..."++      usage (some opt_example_param)+        `shouldBe` "{--example=STRING}..."++      usage (some $ (,) <$> opt_e_param <*> opt_f_unit)+        `shouldBe` "{-eSTRING -f}..."++      usage (some $ opt_e_unit <|> opt_f_unit)+        `shouldBe` "{-e|-f}..."

@@ -0,0 +1,385 @@+{-# LANGUAGE OverloadedLists   #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications  #-}++module Mangrove.UnixSpec (spec) where++import           Control.Applicative+import           Data.List.NonEmpty  (NonEmpty (..))+import qualified Data.List.NonEmpty  as NonEmpty+import           Data.Text           (Text)+import qualified Data.Text           as T+import           Data.Version+import           Test.Hspec++import           Mangrove+import           Mangrove.Render+import           Mangrove.Scheme+import           Mangrove.TextParser+import           Mangrove.Unix++import           TestParsers++--------------------------------------------------------------------------------+-- Example Interface++prm_username :: UnixParser Text+prm_username = parameter defaultParser { parserHint = "USERNAME" }++data CreateSettings = CreateSettings+  { csUid      :: Maybe Int+  , csUsername :: Text+  } deriving (Eq, Show)++parseCreateSettings :: UnixParser CreateSettings+parseCreateSettings = CreateSettings+  <$> optional opt_uid+  <*> prm_username+  where+    opt_uid =+      option ["--uid", "-u"]+      "Specify a user ID"+      $ subparameter defaultParser++data DeleteSettings = DeleteSettings+  { dsDeleteHome :: Bool+  , dsUsername   :: Text+  } deriving (Eq, Show)++parseDeleteSettings :: UnixParser DeleteSettings+parseDeleteSettings = DeleteSettings+  <$> opt_delHome+  <*> prm_username+  where+    opt_delHome =+      switch ["-d"]+      "Delete the user's home directory"++newtype CfgGetSettings = CfgGetSettings Text+  deriving (Eq, Show)++parseCfgGetSettings :: UnixParser CfgGetSettings+parseCfgGetSettings = CfgGetSettings+  <$> parameter defaultParser++data CfgSetSettings = CfgSetSettings Text Text+  deriving (Eq, Show)++parseCfgSetSettings :: UnixParser CfgSetSettings+parseCfgSetSettings = CfgSetSettings+  <$> parameter defaultParser+  <*> parameter defaultParser++data ConfigMode+  = CfgGet CfgGetSettings+  | CfgSet CfgSetSettings+  deriving (Eq, Show)++parseConfigMode :: UnixParser ConfigMode+parseConfigMode =+  CfgGet <$> cmd_get <|>+  CfgSet <$> cmd_set+  where+    cmd_get =+      command ["get", "read"]+      "Read a config value"+      parseCfgGetSettings+    cmd_set =+      command ["set", "write"]+      "Write a config value"+      parseCfgSetSettings++data Mode+  = Create CreateSettings+  | Delete DeleteSettings+  | Config Text ConfigMode+  deriving (Eq, Show)++cmd_create :: UnixParser Mode+cmd_create =+  command ["create"]+  "Create a new user"+  $ Create <$> parseCreateSettings++parseMode :: UnixParser Mode+parseMode =+  cmd_create <|>+  cmd_delete <|>+  cmd_config+  where+    cmd_delete =+      command ["delete", "rm"]+      "Delete a user"+      $ Delete <$> parseDeleteSettings+    cmd_config =+      command ["config"]+      "Manage configuration settings"+      $ Config <$> prm_username <*> parseConfigMode++data Settings = Settings+  { sVerbose :: Bool -- ^ Show extra output+  , sRoot    :: FilePath -- ^ Filesystem root+  , sMode    :: Mode -- ^ Runtime mode+  } deriving (Eq, Show)++parseSettings :: UnixParser Settings+parseSettings =+  addHelpOptions ["--help", "-h"]+  "Display help and usage information"+  $ Settings <$> opt_verbose+             <*> (opt_root <|> pure "/")+             <*> parseMode+  where+    opt_root =+      option ["--root"]+      "Use an alternative filesystem root"+      $ subparameter parseFilePath+    opt_verbose =+      switch ["-v"]+      "Print debugging output"++programInfo :: ProgramInfo+programInfo = ProgramInfo+  { programName = "manage-users"+  , programDesc = "Manage user accounts"+  , programVersion = makeVersion [1,2,0]+  }++--------------------------------------------------------------------------------+-- Tests++optionSpec :: Spec+optionSpec = do+  it "parses long options" $ do+    runArgumentParser opt_example_unit ["--example"]+      `shouldBe` Success [] ()+  it "parses short options" $ do+    runArgumentParser opt_e_unit ["-e"]+      `shouldBe` Success [] ()++  it "parses options in any order" $ do+    runArgumentParser (opt_e_unit *> opt_f_unit) ["-e", "-f"]+      `shouldBe` Success [] ()+    runArgumentParser (opt_e_unit *> opt_f_unit) ["-f", "-e"]+      `shouldBe` Success [] ()++  describe "switches" $ do+    context "when switch is present" $ do+      it "yields True" $ do+        runArgumentParser opt_example_switch ["--example"]+          `shouldBe` Success [] True+    context "when switch is absent" $ do+      it "yields False" $ do+        runArgumentParser opt_example_switch []+          `shouldBe` Success [] False++  context "when a bound argument is provided" $ do+    context "when an argument is expected" $ do+      it "parses the argument" $ do+        runArgumentParser opt_example_param ["--example=qwer"]+          `shouldBe` Success [] "qwer"+        runArgumentParser opt_e_param ["-eqwer"]+          `shouldBe` Success [] "qwer"+    context "when no argument is expected" $ do+      it "parsing fails" $ do+        runArgumentParser opt_example_unit ["--example=qwer"]+          `shouldBe` Failure "--example=qwer: unrecognized subargument: qwer"+        runArgumentParser opt_e_unit ["-eqwer"]+          `shouldBe` Failure "-eqwer: unrecognized subargument: qwer"++  context "when no argument is expected" $ do+    context "when an argument is available" $ do+      it "doesn't consume the argument" $ do+        runArgumentParser opt_example_unit ["--example", "qwer"]+          `shouldBe` Success ["qwer"] ()++  context "when an argument is required" $ do+    it "renders with parameter hint" $ do+      render opt_example_param `shouldBe` "--example=STRING"+      render opt_e_param `shouldBe` "-eSTRING"++    context "when no argument is provided" $ do+      it "fails to parse" $ do+        runArgumentParser opt_example_param ["--example"]+          `shouldBe` Failure "--example: expected: STRING"+    context "when an argument is provided" $ do+      it "the argument is consumed" $ do+        runArgumentParser opt_example_param ["--example", "qwer"]+          `shouldBe` Success [] "qwer"++  context "when an argument is optional" $ do+    it "renders parameter hint in brackets" $ do+      render opt_example_param_optional `shouldBe` "--example=[STRING]"++    context "when no argument is provided" $ do+      it "yields a default value" $ do+        runArgumentParser opt_example_param_optional ["--example"]+          `shouldBe` Success [] "asdf"+      it "does not consume subsequent options" $ do+        runArgumentParser opt_example_param_optional ["--example", "--option"]+          `shouldBe` Success ["--option"] "asdf"+    context "when an argument is provided" $ do+      it "parses the argument" $ do+        runArgumentParser opt_example_param_optional ["--example", "qwer"]+          `shouldBe` Success [] "qwer"++  describe "compound options" $ do+    context "when the subtree accepts multiple arguments" $ do+      it "splits the input by delimiter" $ do+        runArgumentParser opt_example_pair ["--example", "1,3"]+          `shouldBe` Success [] (1,3)+    context "when the subtree can't accept multiple argument" $ do+      it "doesn't split the input by delimiter" $ do+        runArgumentParser opt_example_param ["--example", "1,3"]+          `shouldBe` Success [] "1,3"+        runArgumentParser opt_example_param_optional ["--example", "1,3"]+          `shouldBe` Success [] "1,3"++    context "when the subtree accepts suboptions" $ do+      it "parses key=value pairs" $ do+        runArgumentParser opt_example_subopt ["--example", "value=asdf"]+          `shouldBe` Success [] "asdf"+        runArgumentParser opt_example_subopt ["--example=value=asdf"]+          `shouldBe` Success [] "asdf"+    context "when the subtree can't accept suboptions" $ do+      it "doesn't parse key=value pairs" $ do+        runArgumentParser opt_example_param ["--example", "value=asdf"]+          `shouldBe` Success [] "value=asdf"+        runArgumentParser opt_example_param ["--example=value=asdf"]+          `shouldBe` Success [] "value=asdf"++  describe "help options" $ do+    let isRequest (Request {}) = True+        isRequest _            = False++    context "when a help option is present" $ do+      it "requests help" $ do+        runArgumentParser (withHelp opt_example_unit) ["--help"]+          `shouldSatisfy` isRequest+      it "works for subcommands" $ do+        runArgumentParser (withHelp cmd_example_tree) ["example", "--help"]+          `shouldSatisfy` isRequest+        runArgumentParser (withHelp cmd_example_tree) ["example", "asdf", "--help"]+          `shouldSatisfy` isRequest++    context "when a help option is absent" $ do+      it "doesn't request help" $ do+        runArgumentParser (withHelp opt_example_unit) ["--example"]+          `shouldBe` Success [] ()+        runArgumentParser (withHelp opt_example_unit) []+          `shouldBe` Failure "expected: --help or --example"+      it "isn't activated by escaped options" $ do+        runArgumentParser (withHelp opt_example_unit) ["--", "--help"]+          `shouldBe` Failure "unexpected --help"++generalSpec :: Spec+generalSpec = do+  context "when \"-\" is given as an argument" $ do+    it "parses the string \"-\"" $ do+      runArgumentParser param_text ["-"]+        `shouldBe` Success [] "-"++  context "when \"--\" is present in the argument list" $ do+    it "treats subsequent arguments as free arguments" $ do+      runArgumentParser param_text ["--", "asdf"]+        `shouldBe` Success [] "asdf"+    it "doesn't treat subsequent arguments as options" $ do+      runArgumentParser (option_asdf <|> param_text) ["--", "--asdf"]+        `shouldBe` Success [] "--asdf"+    it "doesn't treat subsequent arguments as commands" $ do+      runArgumentParser (command_asdf <|> param_text) ["--", "asdf"]+        `shouldBe` Success [] "asdf"++  context "when not enough input is provided" $ do+    it "fails to generate a result" $ do+      runArgumentParser param_text []+        `shouldBe` Failure "expected: STRING"++  context "when not all input can be consumed" $ do+    it "returns unconsumed arguments" $ do+      runArgumentParser param_text ["asdf", "qwer"]+        `shouldBe` Success ["qwer"] "asdf"++spec :: Spec+spec = do+  describe "General" generalSpec+  describe "Options" optionSpec+  describe "Help Output" $ do++    let helpResponse = makeHelpResponse parseSettings programInfo+        usageLines = getUsageLines programInfo helpResponse++    it "displays usage lines for each request option" $ do+      length (filter (T.isSuffixOf "--help") usageLines)+        `shouldBe` 6++    it "displays usage lines for each command" $ do+      length (filter (T.isInfixOf " create ") usageLines)+        `shouldBe` 2+      length (filter (T.isInfixOf " delete ") usageLines)+        `shouldBe` 2+      length (filter (T.isInfixOf " config ") usageLines)+        `shouldBe` 5+      length (filter (T.isInfixOf " get ") usageLines)+        `shouldBe` 2+      length (filter (T.isInfixOf " set ") usageLines)+        `shouldBe` 2++    context "when no global options exist" $ do+      it "has no global options section" $ do+        makeHelpResponse cmd_create programInfo+          `shouldSatisfy` (not . T.isInfixOf "GLOBAL OPTIONS")++    context "when global options exist" $ do+      it "adds a global options section" $ do+        helpResponse `shouldSatisfy` T.isInfixOf "GLOBAL OPTIONS"++    context "when no subcommands exist" $ do+      it "has no subcommands section" $ do+        makeHelpResponse parseCreateSettings programInfo+          `shouldSatisfy` (not . T.isInfixOf "SUBCOMMANDS")++    context "when subcommands exist" $ do+      it "adds a subcommands section" $ do+        helpResponse `shouldSatisfy` T.isInfixOf "SUBCOMMANDS"++      it "adds an option table for each subcommand" $ do+        NonEmpty.head <$> getSubcommandTables helpResponse+          `shouldBe` [ "delete, rm"+                     , "create"+                     , "config set, config write"+                     , "config get, config read"+                     , "config"+                     ]++      it "shows the description for each subcommand" $ do+        helpResponse `shouldSatisfy` T.isInfixOf "Read a config value"+        helpResponse `shouldSatisfy` T.isInfixOf "Write a config value"+        helpResponse `shouldSatisfy` T.isInfixOf "Create a new user"+        helpResponse `shouldSatisfy` T.isInfixOf "Delete a user"+        helpResponse `shouldSatisfy` T.isInfixOf "Manage configuration settings"++--------------------------------------------------------------------------------+-- Helper Functions++makeHelpResponse :: UnixParser a -> ProgramInfo -> Text+makeHelpResponse = respond (HelpRequest [])++getUsageLines :: ProgramInfo -> Text -> [Text]+getUsageLines info =+  fmap (T.drop 2)+  . takeWhile (T.isPrefixOf ("  " <> programName info))+  . drop 1+  . T.lines++getSubcommandTables :: Text -> [NonEmpty Text]+getSubcommandTables help =+  go [] $ drop 2 $ dropWhile (/= "SUBCOMMANDS") $ T.lines help+  where+    isHeaderLine text = not $ T.null text || T.isPrefixOf "  " text++    go :: [NonEmpty Text] -> [Text] -> [NonEmpty Text]+    go results [] = results+    go results (line : _lines) =+      let (body, rest) = break isHeaderLine _lines+      in go ((line :| body) : results) rest

@@ -23,6 +23,9 @@ opt_f_unit :: UnixParser () opt_f_unit = option [ShortFlag 'f'] "" $ pure () +opt_example_intList :: UnixParser [Int]+opt_example_intList = option [LongFlag "example"] "" $ some $ subparameter defaultParser+ opt_example_param :: UnixParser Text opt_example_param = option [LongFlag "example"] "" $ subparameter defaultParser