diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/mangrove-cli.cabal b/mangrove-cli.cabal --- a/mangrove-cli.cabal +++ b/mangrove-cli.cabal @@ -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 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 diff --git a/src/Mangrove/ParseTree.hs b/src/Mangrove/ParseTree.hs --- a/src/Mangrove/ParseTree.hs +++ b/src/Mangrove/ParseTree.hs @@ -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 diff --git a/src/Mangrove/Render.hs b/src/Mangrove/Render.hs --- a/src/Mangrove/Render.hs +++ b/src/Mangrove/Render.hs @@ -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 diff --git a/src/Mangrove/Scheme/Sub.hs b/src/Mangrove/Scheme/Sub.hs --- a/src/Mangrove/Scheme/Sub.hs +++ b/src/Mangrove/Scheme/Sub.hs @@ -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 diff --git a/src/Mangrove/Scheme/Unix.hs b/src/Mangrove/Scheme/Unix.hs --- a/src/Mangrove/Scheme/Unix.hs +++ b/src/Mangrove/Scheme/Unix.hs @@ -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) diff --git a/src/Mangrove/TextParser.hs b/src/Mangrove/TextParser.hs --- a/src/Mangrove/TextParser.hs +++ b/src/Mangrove/TextParser.hs @@ -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 diff --git a/test/Arbitrary.hs b/test/Arbitrary.hs --- a/test/Arbitrary.hs +++ b/test/Arbitrary.hs @@ -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 -------------------------------------------------------------------------------- diff --git a/test/General.hs b/test/General.hs deleted file mode 100644 --- a/test/General.hs +++ /dev/null @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 diff --git a/test/Mangrove/ParseTreeSpec.hs b/test/Mangrove/ParseTreeSpec.hs --- a/test/Mangrove/ParseTreeSpec.hs +++ b/test/Mangrove/ParseTreeSpec.hs @@ -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}..." diff --git a/test/Mangrove/UnixSpec.hs b/test/Mangrove/UnixSpec.hs new file mode 100644 --- /dev/null +++ b/test/Mangrove/UnixSpec.hs @@ -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 diff --git a/test/TestParsers.hs b/test/TestParsers.hs --- a/test/TestParsers.hs +++ b/test/TestParsers.hs @@ -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