mangrove-cli 0.3.0.0 → 0.4.0.0

raw patch · 24 files changed

+1841/−1049 lines, 24 filesdep +QuickCheckdep +quickcheck-instancesdep +randomPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, quickcheck-instances, random

API changes (from Hackage documentation)

Files

• CHANGELOG.md +24/−0
• mangrove-cli.cabal +17/−5
• src/Mangrove.hs +10/−186
• src/Mangrove/ParseTree.hs +198/−0
• src/Mangrove/Parser.hs +118/−459
• src/Mangrove/Render.hs +98/−0
• src/Mangrove/Resolve.hs +2/−1
• src/Mangrove/Scheme.hs +58/−0
• src/Mangrove/Scheme/Common.hs +25/−0
• src/Mangrove/Scheme/Sub.hs +32/−7
• src/Mangrove/Scheme/Unix.hs +108/−49
• src/Mangrove/Stream.hs +230/−0
• src/Mangrove/Text.hs +0/−107
• src/Mangrove/TextParser.hs +28/−2
• src/Mangrove/Token.hs +32/−0
• src/Mangrove/Unix.hs +16/−5
• test/Arbitrary.hs +164/−0
• test/General.hs +41/−49
• test/Mangrove/ParseTreeSpec.hs +282/−0
• test/Mangrove/ParserSpec.hs +0/−179
• test/Mangrove/StreamSpec.hs +187/−0
• test/Mangrove/Test/Stream.hs +113/−0
• test/StructureEq.hs +57/−0
• test/TestParsers.hs +1/−0

@@ -8,6 +8,30 @@  ## Unreleased +## 0.4.0.0 - 2026-09-13++### Added++- Show instances for data structures related to parser trees+- A TextParser for paths (FilePath)+- 'Request' type family associated with Scheme class+- Property based tests using QuickCheck++### Changed++- Split Mangrove.Parser module back into several modules (ParseTree,+  Scheme, Stream, Token)+- Move the contents of Mangrove module to Mangrove.Parser, then+  re-export them from the Mangrove module+- Parameterize the StreamParser monad by request type+- Drop phantom type parameter from ProgramInfo++### Removed++- usageInfo method of Scheme class+- HelpContinuation family+- HelpHandler type alias+ ## 0.3.0.0 - 2026-08-27  ### Added

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           mangrove-cli-version:        0.3.0.0+version:        0.4.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@@ -17,7 +17,7 @@ license:        BSD-3-Clause license-file:   LICENSE build-type:     Simple-extra-source-files:+extra-doc-files:     README.md     CHANGELOG.md @@ -29,11 +29,16 @@   exposed-modules:       Mangrove       Mangrove.Parser+      Mangrove.ParseTree+      Mangrove.Render       Mangrove.Resolve+      Mangrove.Scheme+      Mangrove.Scheme.Common       Mangrove.Scheme.Sub       Mangrove.Scheme.Unix-      Mangrove.Text+      Mangrove.Stream       Mangrove.TextParser+      Mangrove.Token       Mangrove.Unix       Mangrove.Valency   other-modules:@@ -55,9 +60,13 @@   type: exitcode-stdio-1.0   main-is: Main.hs   other-modules:+      Arbitrary       General-      Mangrove.ParserSpec+      Mangrove.ParseTreeSpec+      Mangrove.StreamSpec+      Mangrove.Test.Stream       Spec+      StructureEq       TestParsers       Paths_mangrove_cli   autogen-modules:@@ -68,11 +77,14 @@   build-tool-depends:       hspec-discover:hspec-discover >=2.8.5 && <3   build-depends:-      base >=4.7 && <5+      QuickCheck >=2.14.2 && <2.18+    , base >=4.7 && <5     , containers >=0.6.4 && <0.9     , hspec >=2.8.5 && <3     , mangrove-cli     , mtl >=2.2.2 && <2.4+    , quickcheck-instances >=0.3.28 && <0.5+    , random >=1.2.1.1 && <1.3     , text >=1.2.5 && <2.2     , transformers >=0.5.6 && <0.7   default-language: Haskell2010

@@ -1,200 +1,24 @@-{-# LANGUAGE DataKinds          #-}-{-# LANGUAGE FlexibleContexts   #-}-{-# LANGUAGE GADTs              #-}-{-# LANGUAGE OverloadedStrings  #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeOperators      #-}- {-| Module      : Mangrove Copyright   : (c) Quytelda Kahja, 2026 License     : BSD-3-Clause -This module contains types and functions necessary for running-argument parsers.+This module exports the full API required for running any generic+parser. For constructing parsers, you'll need to import the building+blocks for the specific kind of parser you are building. For example,+"Mangrove.Unix" contains the tools for building UNIX-style parsers. -} module Mangrove-  ( -- * Standard Interface-    parseArguments+  ( module Mangrove.Parser -    -- * Types-  , ProgramInfo(..)+  -- * Re-exported Types   , ParseTree   , Scheme-  , Result(..)-  , SupportsResponse+  , ProgramInfo(..)   , StreamState-  , RequestType(..)-  , RequestHandler-  , ReqContinuation(..)--    -- * Pure Interface-    -- ** Helpful Parsers-  , runHelpfulParser-  , runHelpfulParser'-  , runHelpfulParser_--    -- ** Silent Parsers-  , runSilentParser-  , runSilentParser'--    -- ** General Parsers (CPS)-  , runArgumentParser-  , runArgumentParser'   ) where -import           Data.Text           (Text)-import qualified Data.Text           as T-import qualified Data.Text.IO        as TIO-import           System.Environment-import           System.Exit-import           System.IO- import           Mangrove.Parser-import           Mangrove.Resolve-import           Mangrove.Text---- | The results of a parsing operation.------ Only parsing schemes that support generating responses can use the--- 'Response' constructor.-data Result s r where-  -- | A successful parsing operation yields a list of leftover-  -- arguments and a result value.-  Success :: ![Text] -> !r -> Result s r-  -- | A failed parsing operation yields an error message.-  Failure :: !Text -> Result s r-  -- | A request for information yields a human-readable response (for-  -- parsers that support it).-  Response :: SupportsResponse s => !Text -> Result s r--deriving instance Show r => Show (Result s r)-deriving instance Eq r => Eq (Result s r)---- | Create a default initial t'StreamState' from a list of arguments.-argsToState :: [Text] -> StreamState s-argsToState args = StreamState args [] False---- | Attempt to parse a value of type @r@ from a list of arguments,--- where the parser @ParseTree s r@ doesn't support requests.-runSilentParser-  :: (Scheme s, RequestSupport s ~ 'False)-  => ParseTree s r -- ^ Argument parser-  -> [Text] -- ^ Input arguments-  -> Result s r-runSilentParser tree = runSilentParser' tree . argsToState---- | A more general form of 'runSilentParser' that accepts a custom--- stream starting state.-runSilentParser'-  :: (Scheme s, RequestSupport s ~ 'False)-  => ParseTree s r -- ^ Argument parser-  -> StreamState s -- ^ Initial stream state-  -> Result s r-runSilentParser' tree state =-  runArgumentParser' tree state Success Failure NoRequests---- | Attempt to parse a value of type @r@ from a list of arguments,--- where the parser @ParseTree s r@ supports requests.-runHelpfulParser-  :: SupportsResponse s-  => ProgramInfo s -- ^ Program metadata-  -> ParseTree s r -- ^ Argument parser-  -> [Text] -- ^ Input arguments-  -> Result s r-runHelpfulParser info tree = runHelpfulParser' info tree . argsToState---- | A more general form of 'runHelpfulParser' that accepts a custom--- stream starting state.-runHelpfulParser'-  :: SupportsResponse s-  => ProgramInfo s -- ^ Program metadata-  -> ParseTree s r -- ^ Argument parser-  -> StreamState s -- ^ Initial stream state-  -> Result s r-runHelpfulParser' info tree state =-  runArgumentParser' tree state Success Failure (OnRequest _onRequest)-  where-    _onRequest state' HelpRequest =-      Response $ makeHelpInfo tree (streamContext state') info-    _onRequest _ VersionRequest =-      Response $ makeVersionInfo info---- | A variant of 'runHelpfulParser' that treats requests as failures.------ This is useful if you know that no requests will ever be made.-runHelpfulParser_-  :: SupportsResponse s-  => ParseTree s r -- ^ Argument parser-  -> [Text] -- ^ Input arguments-  -> Result s r-runHelpfulParser_ tree args =-  runArgumentParser' tree (argsToState args) Success Failure (OnRequest _onRequest)-  where-    _onRequest state' _ = Failure $-      formatError (streamContext state') "help requested"---- | Parse the command line arguments passed to the program, then--- invoke the program's entrypoint with the results of the parsing. If--- parsing fails, we instead display an error to stderr and exit.--- Alternatively, if information was requested, we abandon parsing and--- print the relevant response to stdout, then exit without indicating--- an error.-parseArguments-  :: SupportsResponse s-  => ProgramInfo s -- ^ Program metadata-  -> ParseTree s r -- ^ Argument parser-  -> (r -> IO a) -- ^ Program Entrypoint-  -> IO a-parseArguments info tree action = do-  args <- map T.pack <$> getArgs-  case runHelpfulParser info tree args of-    Success [] result -> action result-    Success (token:_) _ -> do-      hPutBuilder stderr $ "unexpected " <> render token <> "\n"-      exitFailure-    Failure err -> do-      TIO.hPutStrLn stderr err-      exitFailure-    Response output -> do-      TIO.putStr output-      exitSuccess---- | Satiate a 'ParseTree' with all the input it can consume, then--- attempt to evaluate it.-runArgumentParser-  :: Scheme s-  => ParseTree s r -- ^ Argument parser-  -> [Text] -- ^ Input arguments-  -> ([Text] -> r -> a) -- ^ Success handler-  -> (Text -> a) -- ^ Failure handler-  -> RequestHandler s a -- ^ Request handler-  -> a-runArgumentParser tree = runArgumentParser' tree . argsToState---- | A more general form of 'runArgumentParser' that accepts a custom--- stream starting state.-runArgumentParser'-  :: Scheme s-  => ParseTree s r -- ^ Argument parser-  -> StreamState s -- ^ Initial stream state-  -> ([Text] -> r -> a) -- ^ Success handler-  -> (Text -> a) -- ^ Failure handler-  -> RequestHandler s a -- ^ Request handler-  -> a-runArgumentParser' tree state cok cerr hhelp =-  runStreamParser (satiate tree) handler state-  where-    _onFailure state' = cerr . formatError (streamContext state')-    _onSuccess state' tree' =-      case (streamContent state', resolve tree') of-        (leftovers, Value result) -> cok leftovers result-        ([], EmptyError)          -> _onFailure state' "empty"-        ([], ExpectedError es)    -> _onFailure state' $ renderExpectedError es-        (token:_, _)              -> _onFailure state' $ "unexpected " <> render token-    handler = StreamHandler-      { onSuccess = _onSuccess-      , onFailure = _onFailure-      , onEmpty = flip _onFailure "empty"-      , onRequest = hhelp-      }+import           Mangrove.ParseTree+import           Mangrove.Scheme+import           Mangrove.Stream

@@ -0,0 +1,198 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}++{-|+Module      : Mangrove.ParseTree+Copyright   : (c) Quytelda Kahja, 2026+License     : BSD-3-Clause++A 'ParseTree' is a tree-shaped parser that "filter-feeds" on a stream+of arguments, collecting inputs at the leaves and feeding the results+up the tree for processing. 'ParseTree's are parameterized by the+parser scheme that determines the kind of inputs it accepts.+-}++module Mangrove.ParseTree+  ( -- * Parse Trees+    ParseTree(..)+  , isProduct+  , isSum+  , isOptional+  , isChoice+  ) where++import           Control.Applicative+import           Data.Kind+import           Data.Proxy++import           Mangrove.Render+import           Mangrove.Resolve+import           Mangrove.Token+import           Mangrove.Valency++-- | `ParseTree scheme r` is an expression tree composed of parsers+-- from scheme @scheme@ which evaluates to a value of type @r@ when+-- supplied with the proper input.+data ParseTree (scheme :: Type -> Type) (r :: Type) where+  -- | Terminal node with no value (abstracts 'empty')+  EmptyNode :: ParseTree scheme r+  -- | A terminal node with a resolved value (abstracts 'pure')+  ValueNode :: !r -> ParseTree scheme r+  -- | A parser awaiting input+  ParseNode :: scheme r -> ParseTree scheme r+  -- | Abstracts 'liftA2' and by extension '(<*>)'+  ProdNode :: !(u -> v -> r) -> ParseTree scheme u -> ParseTree scheme v -> ParseTree scheme r+  -- | Abstracts '(<|>)'+  SumNode :: ParseTree scheme r -> ParseTree scheme r -> ParseTree scheme r+  -- | Abstracts 'many' (@MaybeNode False@) and 'some' (@MaybeNode True@)+  ManyNode :: !Bool -> ParseTree scheme r -> ParseTree scheme [r]++instance (forall a. Show (s a)) => Show (ParseTree s r) where+  showsPrec _ EmptyNode = showString "EmptyNode"+  showsPrec p (ValueNode _) =+    showParen (p >= 10)+    $ showString "ValueNode _"+  showsPrec p (ParseNode s) =+    showParen (p >= 10)+    $ showString "ParseNode "+    . showsPrec 11 s+  showsPrec p (ProdNode _ l r) =+    showParen (p >= 10)+    $ showString "ProdNode _ "+    . showsPrec 11 l+    . showString " "+    . showsPrec 11 r+  showsPrec p (SumNode l r) =+    showParen (p >= 10)+    $ showString "SumNode "+    . showsPrec 11 l+    . showString " "+    . showsPrec 11 r+  showsPrec p (ManyNode b t) =+    showParen (p >= 10)+    $ showString "ManyNode "+    . showsPrec 11 b+    . showString " "+    . showsPrec 11 t++instance Functor p => Functor (ParseTree p) where+  fmap _ EmptyNode          = EmptyNode+  fmap f (ValueNode value)  = ValueNode $ f value+  fmap f (ParseNode parser) = ParseNode $ fmap f parser+  fmap f (ProdNode g l r)   = ProdNode (\u v -> f $ g u v) l r+  fmap f (SumNode l r)      = SumNode (fmap f l) (fmap f r)+  fmap f node               = ProdNode ($) (pure f) node+  -- This takes advantage of the fact that f <$> x = pure f <*> x.++instance Functor p => Applicative (ParseTree p) where+  pure = ValueNode+  liftA2 = ProdNode++instance Functor p => Alternative (ParseTree p) where+  empty = EmptyNode+  (<|>) = SumNode+  many = ManyNode False+  some = ManyNode True++instance Valency s => Valency (ParseTree s) where+  valency EmptyNode         = Just 0+  valency (ValueNode _)     = Just 0+  valency (ParseNode p)     = valency p+  valency (ProdNode _ l r)  = (+) <$> valency l <*> valency r+  valency (SumNode l r)     = max <$> valency l <*> valency r+  valency (ManyNode _ tree) =+    case valency tree of+      Just n | n <= 0 -> Just 0+      _               -> Nothing -- i.e. infinity+  -- In the above case of 'ManyNode _ p', a ManyNode can accept an+  -- arbitrary number of parameters, so the maximum valency is either+  -- infinite or zero depending on whether the valency of 'p' is zero.++  -- Since ParseTrees themselves don't accept inputs, we can provide a+  -- slightly more efficient implementation of nullary.+  nullary EmptyNode         = True+  nullary (ValueNode _)     = True+  nullary (ParseNode p)     = nullary p+  nullary (ProdNode _ l r)  = nullary l && nullary r+  nullary (SumNode l r)     = nullary l && nullary r+  nullary (ManyNode _ tree) = nullary tree++instance Resolve s => Resolve (ParseTree s) where+  resolve EmptyNode          = EmptyError+  resolve (ValueNode value)  = pure value+  resolve (ParseNode parser) = resolve parser+  resolve (ProdNode f l r)   = f <$> resolve l <*> resolve r+  resolve (SumNode l r)      = resolve l <|> resolve r+  resolve (ManyNode False _) = pure []+  resolve (ManyNode True  p) = pure <$> resolve p+  -- NOTE: If a ManyNode contains a resolvable node, one might expect+  -- the result to be an infinite list (e.g. `resolve $ many+  -- (ValueNode 1)` to give `Right [1,1,1,1,..]`) or for the+  -- computation to diverge (as is the case for `many (Just 1)`).+  -- However, by only attempting at most resolutions of the subtree,+  -- we will get either zero or one results. For example, `resolve $+  -- many (ValueNode 1)` will give `Right []`.+  --+  -- Whether this is the best possible way to handle the situation is+  -- unclear. This avoids infinite loops, but might not be the+  -- expected behavior in some unforseen use-case.++-- | Is this a 'ProdNode'?+isProduct :: ParseTree s r -> Bool+isProduct (ProdNode {}) = True+isProduct _             = False++-- | Is this a 'SumNode'?+isSum :: ParseTree s r -> Bool+isSum (SumNode {}) = True+isSum _            = False++-- | Does this subtree accept optional input?+isOptional :: Valency s => ParseTree s r -> Bool+isOptional (SumNode l (ValueNode _)) = not $ nullary l+isOptional (ManyNode False p)        = not $ nullary p+isOptional _                         = False++-- | Is this a 'SumNode' a choice between two different (non-empty)+-- inputs?+isChoice :: Valency s => ParseTree s r -> Bool+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++  render (ParseNode parser) = render parser+  render (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 && 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++  -- Constant nodes that don't accept input have no usage.+  render _ = ""

@@ -1,483 +1,60 @@-{-# LANGUAGE DataKinds                 #-}-{-# LANGUAGE DeriveFunctor             #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE GADTs                     #-}-{-# LANGUAGE MultiParamTypeClasses     #-}-{-# LANGUAGE OverloadedStrings         #-}-{-# LANGUAGE PolymorphicComponents     #-}-{-# LANGUAGE ScopedTypeVariables       #-}-{-# LANGUAGE StandaloneDeriving        #-}-{-# LANGUAGE TypeApplications          #-}-{-# LANGUAGE TypeFamilies              #-}-{-# LANGUAGE TypeOperators             #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DeriveFunctor         #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE TypeFamilies          #-}  {-| Module      : Mangrove.Parser Copyright   : (c) Quytelda Kahja, 2026 License     : BSD-3-Clause -This module contains the data types and type classes that make up a-generic argument parser, as well as a stream parsing monad in which-parsing takes place.--A 'ParseTree' is a tree-shaped parser that "filter-feeds" on a stream-of arguments, collecting inputs at the leaves and feeding the results-up the tree for processing. 'ParseTree's are parameterized by the-parser scheme that determines the kind of inputs it accepts.+This module contains types and functions necessary for running+argument parsers. These functions are generic across different parsing+schemes. -A "scheme" is a system of parsers and tokens. It determines the method-by which argument strings are separated. It parses a sequence of-arguments into tokens and values.+Most clients won't import this module directly, since its contents are+re-exported by the "Mangrove" module alongside other helpful symbols. -} module Mangrove.Parser-  ( -- * Parse Trees-    ParseTree(..)-  , isProduct-  , isSum-  , isOptional-  , isChoice--    -- ** Feeding Trees-  , satiate--    -- * Parsing Schemes-  , Scheme(..)-  , ProgramInfo(..)-  , SupportsResponse(..)--    -- * Stream Parser-  , StreamParser(..)-  , StreamHandler(..)-  , StreamState(..)-  , RequestHandler-  , ReqContinuation(..)--    -- ** Requests-  , RequestType(..)-  , request--    -- ** Escaping-  , setEscaped-  , getEscaped+  ( -- * Standard Interface+    parseArguments -    -- ** Context-  , getContext-  , setContext-  , withContext-  , formatError+    -- * Pure Interface+  , Result(..)+  , runArgumentParser+  , runArgumentParser' -    -- ** Streaming-  , popMaybe-  , peekMaybe-  , pop-  , peek-  , push-  , pop_+    -- * Feeding Parser Trees+  , satiate   ) where  import           Control.Applicative-import           Control.Monad.Except-import           Data.Kind-import qualified Data.List              as List-import           Data.Proxy-import           Data.Text              (Text)-import qualified Data.Text.Lazy         as TL-import qualified Data.Text.Lazy.Builder as TLB-import           Data.Version+import           Data.Text           (Text)+import qualified Data.Text           as T+import qualified Data.Text.IO        as TIO+import           System.Environment+import           System.Exit+import           System.IO +import           Mangrove.ParseTree+import           Mangrove.Render import           Mangrove.Resolve-import           Mangrove.Text-import           Mangrove.Valency------------------------------------------------------------------------------------- Parse Trees---- | `ParseTree scheme r` is an expression tree composed of parsers--- from scheme @scheme@ which evaluates to a value of type @r@ when--- supplied with the proper input.-data ParseTree (scheme :: Type -> Type) (r :: Type) where-  -- | Terminal node with no value (abstracts 'empty')-  EmptyNode :: ParseTree scheme r-  -- | A terminal node with a resolved value (abstracts 'pure')-  ValueNode :: !r -> ParseTree scheme r-  -- | A parser awaiting input-  ParseNode :: scheme r -> ParseTree scheme r-  -- | Abstracts 'liftA2' and by extension '(<*>)'-  ProdNode :: !(u -> v -> r) -> ParseTree scheme u -> ParseTree scheme v -> ParseTree scheme r-  -- | Abstracts '(<|>)'-  SumNode :: ParseTree scheme r -> ParseTree scheme r -> ParseTree scheme r-  -- | Abstracts 'many' (@MaybeNode False@) and 'some' (@MaybeNode True@)-  ManyNode :: !Bool -> ParseTree scheme r -> ParseTree scheme [r]--instance Functor p => Functor (ParseTree p) where-  fmap _ EmptyNode          = EmptyNode-  fmap f (ValueNode value)  = ValueNode $ f value-  fmap f (ParseNode parser) = ParseNode $ fmap f parser-  fmap f (ProdNode g l r)   = ProdNode (\u v -> f $ g u v) l r-  fmap f (SumNode l r)      = SumNode (fmap f l) (fmap f r)-  fmap f node               = ProdNode ($) (pure f) node-  -- This takes advantage of the fact that f <$> x = pure f <*> x.--instance Functor p => Applicative (ParseTree p) where-  pure = ValueNode-  liftA2 = ProdNode--instance Functor p => Alternative (ParseTree p) where-  empty = EmptyNode-  (<|>) = SumNode-  many = ManyNode False-  some = ManyNode True--instance Valency s => Valency (ParseTree s) where-  valency EmptyNode         = Just 0-  valency (ValueNode _)     = Just 0-  valency (ParseNode p)     = valency p-  valency (ProdNode _ l r)  = (+) <$> valency l <*> valency r-  valency (SumNode l r)     = max <$> valency l <*> valency r-  valency (ManyNode _ tree) =-    case valency tree of-      Just n | n <= 0 -> Just 0-      _               -> Nothing -- i.e. infinity-  -- In the above case of 'ManyNode _ p', a ManyNode can accept an-  -- arbitrary number of parameters, so the maximum valency is either-  -- infinite or zero depending on whether the valency of 'p' is zero.--  -- Since ParseTrees themselves don't accept inputs, we can provide a-  -- slightly more efficient implementation of nullary.-  nullary EmptyNode         = True-  nullary (ValueNode _)     = True-  nullary (ParseNode p)     = nullary p-  nullary (ProdNode _ l r)  = nullary l && nullary r-  nullary (SumNode l r)     = nullary l && nullary r-  nullary (ManyNode _ tree) = nullary tree--instance Resolve s => Resolve (ParseTree s) where-  resolve EmptyNode          = EmptyError-  resolve (ValueNode value)  = pure value-  resolve (ParseNode parser) = resolve parser-  resolve (ProdNode f l r)   = f <$> resolve l <*> resolve r-  resolve (SumNode l r)      = resolve l <|> resolve r-  resolve (ManyNode False _) = pure []-  resolve (ManyNode True  p) = pure <$> resolve p-  -- NOTE: If a ManyNode contains a resolvable node, one might expect-  -- the result to be an infinite list (e.g. `resolve $ many-  -- (ValueNode 1)` to give `Right [1,1,1,1,..]`) or for the-  -- computation to diverge (as is the case for `many (Just 1)`).-  -- However, by only attempting at most resolutions of the subtree,-  -- we will get either zero or one results. For example, `resolve $-  -- many (ValueNode 1)` will give `Right []`.-  ---  -- Whether this is the best possible way to handle the situation is-  -- unclear. This avoids infinite loops, but might not be the-  -- expected behavior in some unforseen use-case.---- | Is this a 'ProdNode'?-isProduct :: ParseTree s r -> Bool-isProduct (ProdNode {}) = True-isProduct _             = False---- | Is this a 'SumNode'?-isSum :: ParseTree s r -> Bool-isSum (SumNode {}) = True-isSum _            = False---- | Does this subtree accept optional input?-isOptional :: Valency s => ParseTree s r -> Bool-isOptional (SumNode l (ValueNode _)) = not $ nullary l-isOptional (ManyNode False p)        = not $ nullary p-isOptional _                         = False---- | Is this a 'SumNode' a choice between two different (non-empty)--- inputs?-isChoice :: Valency s => ParseTree s r -> Bool-isChoice (SumNode l r) = not (nullary l) && not (nullary r)-isChoice _             = False--instance (Valency s, Scheme s) => Render (ParseTree s r) where-  -- special cases-  render n@(SumNode l _)-    | isOptional n = renderDelimitedIf brackets (not . isOptional) l--  render (ParseNode parser) = usageInfo parser-  render (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 && 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--  -- Constant nodes that don't accept input have no usage.-  render _ = ""------------------------------------------------------------------------------------- Parsing Schemes---- | A scheme is a system of parsers and tokens. It parses a sequence--- of arguments into tokens and values.-class (Functor s, Resolve s, Eq (Token s), Render (Token s), Show (Token s)) => Scheme (s :: Type -> Type) where-  -- | A token represents a particular interpretation of an argument-  -- string under this parsing scheme.-  data Token s--  -- | This type indicates whether a parsing scheme accepts requests-  -- for information.-  ---  -- When @RequestSupport scheme@ is @True@, a 'SupportsResponse'-  -- instance should be provided for @scheme@.-  type RequestSupport s :: Bool-  type RequestSupport s = 'False--  -- | 'delimiter' is the character that separates argument strings in-  -- combined string representation. For example, arguments in the CLI-  -- command @ls -a -l /var@ are separated by spaces.-  delimiter :: Proxy s -> Char--  -- | Parse special control arguments that don't represent tokens in-  -- the scheme, but control aspects of how parsing proceeds (e.g.-  -- escaping).-  parseSpecials :: StreamParser s ()-  parseSpecials = pure ()--  -- | 'activate' tries to run a parser on the current input. If the-  -- parser doesn't apply, it consumes nothing and returns empty. If-  -- it does apply, it consumes the relevant input and returns a-  -- result.-  activate :: s r -> StreamParser s r--  -- | Render human-readable usage information for a particular-  -- parser.-  usageInfo :: s r -> Builder---- | Program metadata for displaying help output.-data ProgramInfo (s :: Type -> Type) = ProgramInfo-  { programName    :: !Text -- ^ The program name-  , programVersion :: !Version -- ^ The program version-  , programDesc    :: !Text -- ^ A description of the program-  } deriving (Show)---- | A class for schemes that support human-readable responses to--- requests for help or version information.-class (Scheme s, RequestSupport s ~ 'True) => SupportsResponse s where-  makeVersionInfo :: ProgramInfo s -> Text-  makeHelpInfo :: ParseTree s r -> [Token s] -> ProgramInfo s -> Text------------------------------------------------------------------------------------- Stream Parser---- | The current state of a stream parser.------ The content of a stream is just a list of 'Text' values. The--- context stack is a list of tokens currently being processed; when a--- token is recognized, it gets added to front of the list while the--- token is being parsed into a usable value. When this parsing--- completes, the token is popped from the front of the list.------ A streams can also enable "escaped" mode by setting 'streamEscaped'--- to 'True'. What this actually does is parser-dependant, but usually--- it restricts how subsequent arguments can be interpreted. For--- example, in the Unix scheme, escaping forces all subsequent--- arguments to be interpreted as positional arguments, even if they--- would normally be interpreted as options or commands.-data StreamState s = StreamState-  { streamContent :: ![Text]    -- ^ A sequence of 'Text' values-  , streamContext :: ![Token s] -- ^ A stack representing current parsing context-  , streamEscaped :: !Bool      -- ^ Escaped mode-  }--deriving instance Scheme s => Show (StreamState s)-deriving instance Scheme s => Eq (StreamState s)---- | What information is being requested?-data RequestType-  = VersionRequest -- ^ A request for version information-  | HelpRequest -- ^ A request for help and usage information-  deriving (Eq, Show)---- | A handler for when information is requested.------ This will hold a continuation function for helpful parsing--- schemes, or a placeholder value for silent schemes.-data family ReqContinuation (cap :: Bool) (s :: Type -> Type) r--data instance ReqContinuation 'False s r-  = NoRequests-  deriving (Functor)--newtype instance ReqContinuation 'True s r-  = OnRequest (StreamState s -> RequestType -> r)-  deriving (Functor)---- | A handler for when information is requested.------ This will hold a continuation function for helpful parsing--- schemes, or a placeholder value for silent schemes.-type RequestHandler s r = ReqContinuation (RequestSupport s) s r---- | A collection of continuations to be called for each situation a--- stream parser might encounter.-data StreamHandler s a r = StreamHandler-  { onSuccess :: StreamState s -> a -> r -- ^ Success Continuation-  , onEmpty   :: StreamState s -> r -- ^ Empty continuation-  , onFailure :: StreamState s -> Builder -> r -- ^ Failure Continuation-  , onRequest :: RequestHandler s r -- ^ Request Continuation-  }---- | The amazing stream parsing monad! This monad tracks the stream--- state and context. It short-circuits when exceptions or requests--- are raised.-newtype StreamParser s a = StreamParser-  { runStreamParser-    :: forall r. StreamHandler s a r-    -> StreamState s-    -> r-  }--instance Functor (StreamParser s) where-  fmap f parser = StreamParser $ \handler ->-    runStreamParser parser handler { onSuccess = \s -> onSuccess handler s . f }--instance Applicative (StreamParser s) where-  pure a = StreamParser $ \handler state -> onSuccess handler state a-  mf <*> ma = StreamParser $ \handler ->-    runStreamParser mf-    handler { onSuccess = \s f -> runStreamParser ma handler { onSuccess = \s' -> onSuccess handler s' . f } s }--instance Alternative (StreamParser s) where-  empty = StreamParser $ \handler -> onEmpty handler-  l <|> r = StreamParser $ \handler ->-    runStreamParser l handler { onEmpty = runStreamParser r handler }--instance Monad (StreamParser s) where-  return = pure-  ma >>= f = StreamParser $ \handler ->-    runStreamParser ma handler { onSuccess = \s a -> runStreamParser (f a) handler s }--instance MonadError Builder (StreamParser s) where-  throwError err = StreamParser $ \handler state -> onFailure handler state err-  catchError ma recover = StreamParser $ \handler state ->-    runStreamParser ma-    handler { onFailure = \_ err -> runStreamParser (recover err) handler state }-    state---- | Enable or disable escaped parsing. What this actually does is--- parser-dependant, but usually it restricts how subsequent arguments--- can be interpreted. For example, in the Unix scheme, escaping--- forces all subsequent arguments to be interpreted as positional--- arguments, even if they would normally be interpreted as options or--- commands.-setEscaped :: Bool -> StreamParser s ()-setEscaped b = StreamParser $ \handler state ->-  onSuccess handler state { streamEscaped = b } ()---- | Check whether escaped parsing is enabled.-getEscaped :: StreamParser s Bool-getEscaped = StreamParser $ \handler state ->-  onSuccess handler state (streamEscaped state)---- | Signal that information is requested. Short-circuits any further--- operations.-request :: RequestSupport s ~ 'True => RequestType -> StreamParser s a-request requestType = StreamParser $ \handler state ->-  case onRequest handler of-    OnRequest h -> h state requestType---- | Get a list representing the current context stack.-getContext :: StreamParser s [Token s]-getContext = StreamParser $ \handler state ->-  onSuccess handler state (streamContext state)---- | Replace the context stack.-setContext :: [Token s] -> StreamParser s ()-setContext contexts = StreamParser $ \handler state ->-  onSuccess handler state { streamContext = contexts } ()---- | Push the provided token onto the context stack, then perform some--- computation. Afterwards, the stack is restored to its prior state.-withContext :: Token s -> StreamParser s a -> StreamParser s a-withContext context action = do-  oldContext <- getContext-  setContext $ context : oldContext-  action <* setContext oldContext---- | Format an error message with context information.-formatError :: Render tok => [tok] -> Builder -> Text-formatError contexts err =-  TL.toStrict-  $ TLB.toLazyText-  $ mconcat-  $ List.intersperse ": "-  $ reverse-  $ err : map render contexts-------------------------------------------------------------------------------------- | Remove and return the first token in the stream.-popMaybe :: StreamParser s (Maybe Text)-popMaybe = StreamParser $ \handler state ->-  case streamContent state of-    (t:ts') -> onSuccess handler state { streamContent = ts' } (Just t)-    _       -> onSuccess handler state Nothing---- | View the first token in the stream without consuming it.-peekMaybe :: StreamParser s (Maybe Text)-peekMaybe = StreamParser $ \handler state ->-  case streamContent state of-    (t:_) -> onSuccess handler state (Just t)-    _     -> onSuccess handler state Nothing---- | Remove and return the first token in the stream. Evaluates to--- 'empty' if there are no tokens in the stream.-pop :: StreamParser s Text-pop = StreamParser $ \handler state ->-  case streamContent state of-    (t:ts') -> onSuccess handler state { streamContent = ts' } t-    _       -> onEmpty handler state---- | View the first token in the stream without consuming it.--- Evaluates to 'empty' if there are no tokens in the stream.-peek :: StreamParser s Text-peek = StreamParser $ \handler state ->-  case streamContent state of-    (t:_) -> onSuccess handler state t-    _     -> onEmpty handler state---- | Prepend a token to the front of the stream.-push :: Text -> StreamParser s ()-push t = StreamParser $ \handler state ->-  onSuccess handler-  state { streamContent = t : streamContent state }-  ()---- | Discard the first token in the stream. Nothing happens if there--- are no tokens in the stream.-pop_ :: StreamParser s ()-pop_ = StreamParser $ \handler state ->-  onSuccess handler-  state { streamContent = drop 1 $ streamContent state }-  ()+import           Mangrove.Scheme+import           Mangrove.Stream+import           Mangrove.Token  --------------------------------------------------------------------------------+-- Feeding ParseTrees  -- | 'feed' traverses the tree until it activates a parser that -- consumes input. When a subtree successfully consumes input, it is -- replaced with an updated subtree and the traversal ceases.-feed :: Scheme s => ParseTree s r -> StreamParser s (ParseTree s r)+feed :: Scheme s => ParseTree s r -> StreamParser (Request s) (Token s) (ParseTree s r) feed EmptyNode = empty feed (ValueNode _) = empty feed (ParseNode parser) = ValueNode <$> activate parser@@ -493,10 +70,92 @@ -- | Repeatedly traverse the tree, each time activating the first -- parser that can consume available input, until no more input can be -- consumed.-satiate :: Scheme s => ParseTree s r -> StreamParser s (ParseTree s r)+satiate :: Scheme s => ParseTree s r -> StreamParser (Request s) (Token s) (ParseTree s r) satiate tree = do   parseSpecials   result <- optional $ feed tree   case result of     Just tree' -> satiate tree'     Nothing    -> pure tree++--------------------------------------------------------------------------------+-- Running Parsers++-- | Create a default initial t'StreamState' from a list of arguments.+argsToState :: [Text] -> StreamState s+argsToState args = StreamState args [] False++-- | The result of an argument parsing operation.+data Result req a+  = Success ![Text] !a+  | Failure !Text+  | Request !req+  deriving (Eq, Functor, Show)++-- | Resolve the output of a parsing operation and sink it into a+-- 'Result'.+sinkResult+  :: Scheme s+  => StreamHandler (Request s) (Token s) (ParseTree s r) (Result (Request s) r)+sinkResult = StreamHandler+  { onSuccess = _onSuccess+  , onEmpty   = _onEmpty+  , onFailure = _onFailure+  , onRequest = _onRequest+  }+  where+    _onFailure state' = Failure . formatError (streamContext state')+    _onEmpty = flip _onFailure "empty"+    _onSuccess state' tree' =+      case (streamContent state', resolve tree') of+        (leftovers, Value result) -> Success leftovers result+        ([], EmptyError)          -> _onFailure state' "empty"+        ([], ExpectedError es)    -> _onFailure state' $ renderExpectedError es+        (token:_, _)              -> _onFailure state' $ "unexpected " <> render token+    _onRequest _ = Request++-- | A more general form of 'runArgumentParser' that accepts a custom+-- stream starting state.+runArgumentParser'+  :: Scheme s+  => ParseTree s r+  -> StreamState (Token s)+  -> Result (Request s) r+runArgumentParser' tree =+  runStreamParser (satiate tree) sinkResult++-- | Satiate a 'ParseTree' with all the input it can consume, then+-- attempt to evaluate it. Empty results are treated as failures.+runArgumentParser+  :: Scheme s+  => ParseTree s r+  -> [Text]+  -> Result (Request s) r+runArgumentParser tree =+  runArgumentParser' tree . argsToState++-- | Parse the command line arguments passed to the program, then+-- invoke the program's entrypoint with the results of the parsing. If+-- parsing fails, we instead display an error to stderr and exit.+-- Alternatively, if information was requested, we abandon parsing and+-- print the response to stdout, then exit without indicating an+-- error.+parseArguments+  :: Scheme s+  => ProgramInfo -- ^ Program metadata+  -> ParseTree s r -- ^ Argument parser+  -> (r -> IO a) -- ^ Program entrypoint+  -> IO a+parseArguments info tree action = do+  args <- map T.pack <$> getArgs+  case runArgumentParser tree args of+    Success [] result -> action result+    Success (token:_) _ -> do+      hPutBuilder stderr $ "unexpected " <> render token <> "\n"+      exitFailure+    Failure err -> do+      TIO.hPutStrLn stderr err+      exitFailure+    Request req -> do+      TIO.putStr $ respond req tree info+      exitSuccess

@@ -0,0 +1,98 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs             #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies      #-}++{-|+Module      : Mangrove.Render+Copyright   : (c) Quytelda Kahja, 2026+License     : BSD-3-Clause++Facilities for textual representation of data structures.+-}+module Mangrove.Render+  ( -- * Text Rendering+    Render(..)+  , renderLazyText+  , renderText+  , putBuilder+  , hPutBuilder++    -- * Helpers & Combinators+  , between+  , brackets+  , braces+  , quotes+  , renderDelimitedIf++    -- * Re-exports+  , Builder+  ) where++import           Data.Text              (Text)+import qualified Data.Text              as T+import qualified Data.Text.Lazy         as TL+import           Data.Text.Lazy.Builder (Builder)+import qualified Data.Text.Lazy.Builder as TLB+import qualified Data.Text.Lazy.IO      as TLIO+import           System.IO++-- | A class for things that can be rendered to a text 'Builder'.+class Render a where+  render :: a -> Builder++instance Render Builder where+  render = id++instance Render T.Text where+  render = TLB.fromText++instance Render Char where+  render = TLB.singleton++instance Render String where+  render = TLB.fromString++-- | Convert renderable data directly to lazy 'TL.Text'.+renderLazyText :: Render a => a -> TL.Text+renderLazyText = TLB.toLazyText . render++-- | Convert renderable data directly to strict 'T.Text'.+renderText :: Render a => a -> Text+renderText = TL.toStrict . TLB.toLazyText . render++-- | Write the contents of a 'Builder' to standard output.+putBuilder :: Builder -> IO ()+putBuilder = TLIO.putStr . TLB.toLazyText++-- | Write the contents of a 'Builder' to some IO handle.+hPutBuilder :: Handle -> Builder -> IO ()+hPutBuilder handle = TLIO.hPutStr handle . TLB.toLazyText++--------------------------------------------------------------------------------+-- Combinators++-- | @between open close s@ surrounds @s@ with @open@ and @close@+-- (i.e. @open <> s <> close@).+between :: Monoid m => m -> m -> m -> m+between open close s = open <> s <> close++-- | Surround a string with square brackets.+brackets :: Builder -> Builder+brackets = between "[" "]"++-- | Surround a string with curly braces.+braces :: Builder -> Builder+braces = between "{" "}"++-- | Surround a string with double quotes.+quotes :: Builder -> Builder+quotes = between "\"" "\""++-- | @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)

@@ -21,7 +21,8 @@ import           Control.Applicative import           Control.Monad.Except import qualified Data.List            as List-import           Mangrove.Text++import           Mangrove.Render  -- | A monad for resolving parsers and expression trees. --

@@ -0,0 +1,58 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies      #-}++{-|+Module      : Mangrove.Scheme+Copyright   : (c) Quytelda Kahja, 2026+License     : BSD-3-Clause++A "scheme" is a set of parsers with an associated token type. The+scheme also defines the way the parser handles requests.+-}++module Mangrove.Scheme+  ( Scheme(..)+  , ProgramInfo(..)+  ) where++import           Data.Kind+import           Data.Text          (Text)+import           Data.Version++import           Mangrove.ParseTree+import           Mangrove.Resolve+import           Mangrove.Stream+import           Mangrove.Token++-- | Program metadata for displaying help output.+data ProgramInfo = ProgramInfo+  { programName    :: !Text -- ^ The program name+  , programDesc    :: !Text -- ^ A description of the program+  , programVersion :: !Version -- ^ The program version+  } deriving (Show)++-- | A scheme is a system of parsers and tokens. It parses a sequence+-- of arguments into tokens and values.+class (Functor s, HasTokens s, Resolve s) => Scheme (s :: Type -> Type) where+  -- | What type of requests does this scheme support? This should be+  -- 'Data.Void.Void' if requests are unsupported.+  type Request s++  -- | Generate a response to a request. If requests are unsupported+  -- for this scheme, the implementation of the function should be+  -- 'Data.Void.absurd'.+  respond :: Request s -> ParseTree s r -> ProgramInfo -> Text++  -- | Parse special control arguments that don't represent tokens in+  -- the scheme, but control aspects of how parsing proceeds (e.g.+  -- escaping).+  parseSpecials :: StreamParser (Request s) (Token s) ()+  parseSpecials = pure ()++  -- | 'activate' tries to run a parser on the current input. If the+  -- parser doesn't apply, it consumes nothing and returns empty. If+  -- it does apply, it consumes the relevant input and returns a+  -- result.+  activate :: s r -> StreamParser (Request s) (Token s) r

@@ -0,0 +1,25 @@+{-# LANGUAGE ViewPatterns #-}++{-|+Module      : Mangrove.Scheme.Common+Copyright   : (c) Quytelda Kahja, 2026+License     : BSD-3-Clause++This module is for utilities used by more than one parsing scheme.+-}++module Mangrove.Scheme.Common+  ( keyEqualsValue+  ) where++import           Data.Text (Text)+import qualified Data.Text as T++-- | Parse a 'Text' of the form "key=value" into ("key", "value"). If+-- the delimiter ('=') does not appear in the string, the result is+-- 'Nothing'.+keyEqualsValue :: Text -> Maybe (Text, Text)+keyEqualsValue s =+  case T.break (== '=') s of+    (key, T.uncons -> Just (_, value)) -> Just (key, value)+    _                                  -> Nothing

@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveFunctor     #-}+{-# LANGUAGE DeriveGeneric     #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies      #-}@@ -22,12 +23,18 @@   ) where  import           Control.Applicative-import           Data.Text           (Text)+import           Data.Text              (Text)+import           Data.Void+import           GHC.Generics -import           Mangrove.Parser+import           Mangrove.ParseTree+import           Mangrove.Render import           Mangrove.Resolve-import           Mangrove.Text+import           Mangrove.Scheme+import           Mangrove.Scheme.Common+import           Mangrove.Stream import           Mangrove.TextParser+import           Mangrove.Token import           Mangrove.Valency  -- | Parsers for subarguments of an option (e.g. @--option key=value@).@@ -36,6 +43,18 @@   | Option !Text (TextParser r) -- ^ Suboptions have the form "KEY=VALUE"   deriving (Functor) +instance Show (SubScheme r) where+  showsPrec p (Parameter tp) =+    showParen (p >= 10)+    $ showString "Parameter "+    . showsTextParser tp+  showsPrec p (Option key tp) =+    showParen (p >= 10)+    $ showString "Option "+    . shows key+    . showString " "+    . showsTextParser tp+ instance Valency SubScheme where   valency _ = Just 1 @@ -45,14 +64,19 @@   resolve (Option key (TextParser hint _)) =     ExpectedError [render key <> "=" <> render hint] -instance Scheme SubScheme where+instance HasTokens SubScheme where   data Token SubScheme     = SubAssoc Text Text -- ^ A "KEY=VALUE" argument     | SubArgument Text -- ^ A standard freeform argument-    deriving (Eq, Show)+    deriving (Eq, Generic, Show)    delimiter _ = ',' +instance Scheme SubScheme where+  type Request SubScheme = Void++  respond = absurd+   activate parser = do     next <- peek     escaped <- getEscaped@@ -74,8 +98,9 @@           empty       _ -> empty -  usageInfo (Parameter tp)  = render $ parserHint tp-  usageInfo (Option key tp) = render key <> "=" <> render (parserHint tp)+instance Render (SubScheme r) where+  render (Parameter tp)  = render $ parserHint tp+  render (Option key tp) = render key <> "=" <> render (parserHint tp)  instance Render (Token SubScheme) where   render (SubAssoc key value) = render key <> "=" <> render value

@@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds         #-} {-# LANGUAGE DeriveFunctor     #-}+{-# LANGUAGE DeriveGeneric     #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase        #-} {-# LANGUAGE OverloadedStrings #-}@@ -21,9 +22,13 @@   , CommandInfo(..)      -- * Unix Scheme+  , UnixParser   , UnixScheme(..)   , Token(..)-  , UnixParser+  , UnixRequest(..)+  , UnixRequest'+  , helpRequest+  , versionRequest      -- * Help   , addHelpOptions@@ -46,14 +51,19 @@ import qualified Data.Text.Lazy.Builder as TLB import           Data.Version import           Data.Void+import           GHC.Generics -import           Mangrove import           Mangrove.Parser+import           Mangrove.ParseTree+import           Mangrove.Render import           Mangrove.Resolve+import           Mangrove.Scheme+import           Mangrove.Scheme.Common import           Mangrove.Scheme.Sub    (SubScheme) import qualified Mangrove.Scheme.Sub    as Sub-import           Mangrove.Text+import           Mangrove.Stream import           Mangrove.TextParser+import           Mangrove.Token import           Mangrove.Valency  --------------------------------------------------------------------------------@@ -71,7 +81,7 @@ data Flag   = LongFlag !Text   | ShortFlag !Char-  deriving (Eq, Ord, Show)+  deriving (Eq, Generic, Ord, Show)  instance IsString Flag where   fromString ('-':'-':name)@@ -105,6 +115,49 @@ cmdHead :: CommandInfo -> Text cmdHead = NonEmpty.head . cmdNames +-- | Requests supported by UNIX-style parsers.+data UnixRequest+  = VersionRequest -- ^ A request for version information+  | HelpRequest [Text] -- ^ A request for help and usage information+  deriving (Eq, Generic, Show)++-- | Context-aware requests+type UnixRequest' = [Token UnixScheme] -> UnixRequest++-- | A request for help information within the current command context+helpRequest :: UnixRequest'+helpRequest context = HelpRequest [cmd | UnixCommand cmd <- context]++-- | A request for version information+versionRequest :: UnixRequest'+versionRequest _ = VersionRequest++-- | Generate a response to a help request.+respondHelpRequest+  :: [Text]+  -> ParseTree UnixScheme r+  -> ProgramInfo+  -> Text+respondHelpRequest cmds tree info = renderText+  $ "Usage:\n"+  <> formatUsages (programName info) usages <> "\n\n"+  <> render (programDesc info) <> "\n"+  <> renderHelp tree cmds+  where+    usages = decomposeTree tree cmds++-- | Generate a response to a version request.+respondVersionRequest+  :: ProgramInfo+  -> Text+respondVersionRequest info = renderText+  $ render (programName info)+  <> " version "+  <> renderVersion (programVersion info)+  <> "\n"+  where+    renderVersion = TLB.fromString . showVersion+ -- | A parsing scheme for Unix-style command line syntax. data UnixScheme r   -- | A freeform positional parameter@@ -114,9 +167,32 @@   -- | A named option that might support suboptions   | Option !OptionInfo (ParseTree SubScheme r)   -- | A special option that raises a request for information-  | RequestOption !OptionInfo !RequestType+  | RequestOption !OptionInfo !UnixRequest'   deriving (Functor) +instance Show (UnixScheme r) where+  showsPrec p (Parameter tp) =+    showParen (p >= 10)+    $ showString "Parameter "+    . showsTextParser tp+  showsPrec p (Option info subtree) =+    showParen (p >= 10)+    $ showString "Option "+    . showsPrec 11 info+    . showString " "+    . showsPrec 11 subtree+  showsPrec p (Command info subtree) =+    showParen (p >= 10)+    $ showString "Command "+    . showsPrec 11 info+    . showString " "+    . showsPrec 11 subtree+  showsPrec p (RequestOption info _) =+    showParen (p >= 10)+    $ showString "RequestOption "+    . showsPrec 11 info+    . showString " _"+ instance Valency UnixScheme where   valency (Parameter _)       = Just 1   valency (Command _ subtree) = fmap (+1) (valency subtree)@@ -153,7 +229,7 @@ isMarked "-" = False isMarked s   = "-" `T.isPrefixOf` s -instance Scheme UnixScheme where+instance HasTokens UnixScheme where   data Token UnixScheme     -- | A freeform positional argument that is not an option or command     = UnixArgument Text@@ -161,12 +237,16 @@     | UnixCommand Text     -- | A named option with optional bound argument     | UnixOption Flag (Maybe Text)-    deriving (Eq, Show)--  type RequestSupport UnixScheme = 'True+    deriving (Eq, Generic, Show)    delimiter _ = ' ' +instance Scheme UnixScheme where+  type Request UnixScheme = UnixRequest++  respond (HelpRequest cmds) tree info = respondHelpRequest cmds tree info+  respond VersionRequest _ info        = respondVersionRequest info+   parseSpecials = do     peekMaybe >>= \case       Just "--" -> pop_ *> setEscaped True@@ -214,10 +294,9 @@           , streamEscaped = not $ Sub.hasSubOptions subtree           }         parseSubargs args =-          runArgumentParser' subtree (initState args)-          (curry pure)-          (throwError . render)-          NoRequests+          case runArgumentParser' subtree (initState args) of+            Success leftover result -> pure (leftover, result)+            Failure err             -> throwError $ render err      withContext (UnixOption flag mbound) $ do       -- If a bound argument (e.g. --floop=blah) is provided, we@@ -252,7 +331,7 @@           (_, result) <- parseSubargs []           pure result -  activate (RequestOption info requestType) = do+  activate (RequestOption info mkRequest) = do     -- Arguments should never be interpreted as options when escaped.     getEscaped >>= guard . not @@ -261,7 +340,7 @@     pop_      withContext (UnixOption flag mbound) $-      request requestType+      getContext >>= request . mkRequest    activate (Command info subtree) = do     -- Arguments should never be interpreted as commands when escaped.@@ -276,10 +355,11 @@       satiate subtree       >>= resolveLifted -  usageInfo (Parameter tp) = render $ parserHint tp-  usageInfo (Command info subtree) =+instance Render (UnixScheme r) where+  render (Parameter tp) = render $ parserHint tp+  render (Command info subtree) =     "{" <> render (cmdHead info) <> " " <> render subtree <> "}"-  usageInfo (Option info subtree) =+  render (Option info subtree) =     render flag     <> if nullary subtree        then mempty@@ -288,7 +368,7 @@           separator = case flag of                         LongFlag _ -> "="                         _          -> ""-  usageInfo (RequestOption info _) =+  render (RequestOption info _) =     render (optHead info)  instance Render (Token UnixScheme) where@@ -318,11 +398,11 @@ -- > decomposeTree tree [] -- No filtering -- > decomposeTree tree ["stash", "list"] -- Select "stash list" command decomposeTree :: ParseTree UnixScheme r -> [Text] -> Usages r-decomposeTree (ParseNode (RequestOption info requestType)) commands =+decomposeTree (ParseNode (RequestOption info mkRequest)) commands =   -- If we're currently searching for a specific command, then   -- this request option is irrelevant.-  let node = ParseNode (RequestOption info requestType)-  in Usages (if null commands then [node] else []) Nothing []+  let node = ParseNode (RequestOption info mkRequest)+  in Usages [node | null commands] Nothing []  decomposeTree (ParseNode (Command info subtree)) commands   | commandMismatch =@@ -339,7 +419,7 @@   where     commandMismatch =       case commands of-        (command : _) -> not $ command `elem` cmdNames info+        (command : _) -> command `notElem` cmdNames info         []            -> False  decomposeTree (SumNode l r) commands =@@ -382,24 +462,6 @@   where     usageModes = map vacuous reqs <> maybeToList misc <> cmds -instance SupportsResponse UnixScheme where-  makeVersionInfo info = renderText-    $ render (programName info)-    <> " version "-    <> renderVersion (programVersion info)-    <> "\n"-    where-      renderVersion = TLB.fromString . showVersion--  makeHelpInfo tree context info = renderText-    $ "Usage:\n"-    <> formatUsages (programName info) usages <> "\n\n"-    <> render (programDesc info) <> "\n"-    <> renderHelp tree context-    where-      commandContext = [cmd | UnixCommand cmd <- context]-      usages = decomposeTree tree commandContext- -- | Convenient type alias for Unix-flavored parse trees. type UnixParser = ParseTree UnixScheme @@ -416,7 +478,7 @@ addHelpOptions flags desc tree = ParseNode helpOption <|> go tree   where     helpOption :: UnixScheme a-    helpOption = RequestOption (OptionInfo flags desc) HelpRequest+    helpOption = RequestOption (OptionInfo flags desc) helpRequest      go :: ParseTree UnixScheme a -> ParseTree UnixScheme a     go (ParseNode (Command info subtree)) =@@ -497,8 +559,7 @@   <> render (cmdHelp info)   <> "\n"   where-    quote m = "\"" <> m <> "\""-    fmtCommand = quote . render . T.unwords . fmap cmdHead . reverse+    fmtCommand = quotes . render . T.unwords . fmap cmdHead . reverse     aliases = NonEmpty.tail $ cmdNames info     aliasInfo =       if null aliases@@ -533,11 +594,9 @@ -- that exist underneath the current command context. renderHelp   :: ParseTree UnixScheme r-  -> [Token UnixScheme] -- ^ Context Stack+  -> [Text] -- ^ Command Context   -> Builder-renderHelp tree contexts =+renderHelp tree cmds =   renderTables-  $ selectSubtable commandContext+  $ selectSubtable cmds   $ collectOptions tree-  where-    commandContext = reverse [s | UnixCommand s <- contexts]

@@ -0,0 +1,230 @@+{-# LANGUAGE DeriveFunctor             #-}+{-# LANGUAGE DeriveGeneric             #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE PolymorphicComponents     #-}+{-# LANGUAGE TypeFamilies              #-}++{-|+Module      : Mangrove.Stream+Copyright   : (c) Quytelda Kahja, 2026+License     : BSD-3-Clause++Provides a basic stream-parsing monad for parsing argument sequences+with error handling and context management.+-}++module Mangrove.Stream+  ( -- * Stream Parser+    StreamParser(..)+  , StreamHandler(..)+  , StreamState(..)+  , failure+  , request++    -- ** Escaping+  , setEscaped+  , getEscaped++    -- ** Context+  , getContext+  , setContext+  , withContext+  , formatError++    -- ** Streaming+  , popMaybe+  , peekMaybe+  , pop+  , peek+  , push+  , pop_+  , getContent+) where++import           Control.Applicative+import           Control.Monad.Except+import qualified Data.List              as List+import           Data.Text              (Text)+import qualified Data.Text.Lazy         as TL+import qualified Data.Text.Lazy.Builder as TLB+import           GHC.Generics++import           Mangrove.Render++-- | The current state of a stream parser.+--+-- The content of a stream is just a list of 'Text' values. The+-- context stack is a list of tokens currently being processed; when a+-- token is recognized, it gets added to front of the list while the+-- token is being parsed into a usable value. When this parsing+-- completes, the token is popped from the front of the list.+--+-- A streams can also enable "escaped" mode by setting 'streamEscaped'+-- to 'True'. What this actually does is parser-dependant, but usually+-- it restricts how subsequent arguments can be interpreted. For+-- example, in the Unix scheme, escaping forces all subsequent+-- arguments to be interpreted as positional arguments, even if they+-- would normally be interpreted as options or commands.+data StreamState tok = StreamState+  { streamContent :: ![Text] -- ^ A sequence of 'Text' values+  , streamContext :: ![tok] -- ^ A stack representing current parsing context+  , streamEscaped :: !Bool -- ^ Escaped mode+  } deriving (Eq, Generic, Show)++-- | A collection of continuations to be called for each situation a+-- stream parser might encounter.+data StreamHandler req tok a r = StreamHandler+  { onSuccess :: StreamState tok -> a -> r -- ^ Success Continuation+  , onEmpty   :: StreamState tok -> r -- ^ Empty continuation+  , onFailure :: StreamState tok -> Builder -> r -- ^ Failure Continuation+  , onRequest :: StreamState tok -> req -> r -- ^ Request Continuation+  } deriving (Functor)++-- | The amazing stream parsing monad! This monad tracks the stream+-- state and context. It short-circuits when exceptions or requests+-- are raised.+newtype StreamParser req tok a = StreamParser+  { runStreamParser+    :: forall r. StreamHandler req tok a r+    -> StreamState tok+    -> r+  }++instance Functor (StreamParser req tok) where+  fmap f parser = StreamParser $ \handler ->+    runStreamParser parser handler { onSuccess = \s -> onSuccess handler s . f }++instance Applicative (StreamParser req tok) where+  pure a = StreamParser $ \handler state -> onSuccess handler state a+  mf <*> ma = StreamParser $ \handler ->+    runStreamParser mf+    handler { onSuccess = \s f -> runStreamParser ma handler { onSuccess = \s' -> onSuccess handler s' . f } s }++instance Alternative (StreamParser req tok) where+  empty = StreamParser $ \handler -> onEmpty handler+  l <|> r = StreamParser $ \handler ->+    runStreamParser l handler { onEmpty = runStreamParser r handler }++instance Monad (StreamParser req tok) where+  return = pure+  ma >>= f = StreamParser $ \handler ->+    runStreamParser ma handler { onSuccess = \s a -> runStreamParser (f a) handler s }++-- | Exit parsing with an error message because something has gone+-- wrong.+failure :: Builder -> StreamParser req tok a+failure err = StreamParser $ \handler state ->+  onFailure handler state err++instance MonadError Builder (StreamParser req tok) where+  throwError = failure+  catchError ma recover = StreamParser $ \handler state ->+    runStreamParser ma+    handler { onFailure = \_ err -> runStreamParser (recover err) handler state }+    state++-- | Enable or disable escaped parsing. What this actually does is+-- parser-dependant, but usually it restricts how subsequent arguments+-- can be interpreted. For example, in the Unix scheme, escaping+-- forces all subsequent arguments to be interpreted as positional+-- arguments, even if they would normally be interpreted as options or+-- commands.+setEscaped :: Bool -> StreamParser req tok ()+setEscaped b = StreamParser $ \handler state ->+  onSuccess handler state { streamEscaped = b } ()++-- | Check whether escaped parsing is enabled.+getEscaped :: StreamParser req tok Bool+getEscaped = StreamParser $ \handler state ->+  onSuccess handler state (streamEscaped state)++-- | Signal that information is requested. Short-circuits any further+-- operations.+request :: req -> StreamParser req tok a+request requestType = StreamParser $ \handler state ->+  onRequest handler state requestType++-- | Get a list representing the current context stack.+getContext :: StreamParser req tok [tok]+getContext = StreamParser $ \handler state ->+  onSuccess handler state (streamContext state)++-- | Replace the context stack.+setContext :: [tok] -> StreamParser req tok ()+setContext contexts = StreamParser $ \handler state ->+  onSuccess handler state { streamContext = contexts } ()++-- | Push the provided token onto the context stack, then perform some+-- computation. Afterwards, the stack is restored to its prior state.+withContext :: tok -> StreamParser req tok a -> StreamParser req tok a+withContext context action = do+  oldContext <- getContext+  setContext $ context : oldContext+  action <* setContext oldContext++-- | Format an error message with context information.+formatError :: Render tok => [tok] -> Builder -> Text+formatError contexts err =+  TL.toStrict+  $ TLB.toLazyText+  $ mconcat+  $ List.intersperse ": "+  $ reverse+  $ err : map render contexts++--------------------------------------------------------------------------------++-- | Retrieve the full list of unconsumed input. This doesn't consume+-- anything or alter the state.+getContent :: StreamParser req tok [Text]+getContent = StreamParser $ \handler state ->+  onSuccess handler state $ streamContent state++-- | Remove and return the first token in the stream.+popMaybe :: StreamParser req tok (Maybe Text)+popMaybe = StreamParser $ \handler state ->+  case streamContent state of+    (t:ts') -> onSuccess handler state { streamContent = ts' } (Just t)+    _       -> onSuccess handler state Nothing++-- | View the first token in the stream without consuming it.+peekMaybe :: StreamParser req tok (Maybe Text)+peekMaybe = StreamParser $ \handler state ->+  case streamContent state of+    (t:_) -> onSuccess handler state (Just t)+    _     -> onSuccess handler state Nothing++-- | Remove and return the first token in the stream. Evaluates to+-- 'empty' if there are no tokens in the stream.+pop :: StreamParser req tok Text+pop = StreamParser $ \handler state ->+  case streamContent state of+    (t:ts') -> onSuccess handler state { streamContent = ts' } t+    _       -> onEmpty handler state++-- | View the first token in the stream without consuming it.+-- Evaluates to 'empty' if there are no tokens in the stream.+peek :: StreamParser req tok Text+peek = StreamParser $ \handler state ->+  case streamContent state of+    (t:_) -> onSuccess handler state t+    _     -> onEmpty handler state++-- | Prepend a token to the front of the stream.+push :: Text -> StreamParser req tok ()+push t = StreamParser $ \handler state ->+  onSuccess handler+  state { streamContent = t : streamContent state }+  ()++-- | Discard the first token in the stream. Nothing happens if there+-- are no tokens in the stream.+pop_ :: StreamParser req tok ()+pop_ = StreamParser $ \handler state ->+  onSuccess handler+  state { streamContent = drop 1 $ streamContent state }+  ()

@@ -1,107 +0,0 @@-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs             #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies      #-}-{-# LANGUAGE ViewPatterns      #-}--{-|-Module      : Mangrove.Text-Copyright   : (c) Quytelda Kahja, 2026-License     : BSD-3-Clause--Utilities for dealing with various types of text.--}-module Mangrove.Text-  ( -- * Text Rendering-    Render(..)-  , renderLazyText-  , renderText-  , putBuilder-  , hPutBuilder--    -- * Helpers & Combinators-  , between-  , brackets-  , braces-  , renderDelimitedIf-  , keyEqualsValue--    -- * Re-exports-  , Builder-  ) where--import           Data.Text              (Text)-import qualified Data.Text              as T-import qualified Data.Text.Lazy         as TL-import           Data.Text.Lazy.Builder (Builder)-import qualified Data.Text.Lazy.Builder as TLB-import qualified Data.Text.Lazy.IO      as TLIO-import           System.IO---- | A class for things that can be rendered to a text 'Builder'.-class Render a where-  render :: a -> Builder--instance Render Builder where-  render = id--instance Render T.Text where-  render = TLB.fromText--instance Render Char where-  render = TLB.singleton--instance Render String where-  render = TLB.fromString---- | Convert renderable data directly to lazy 'TL.Text'.-renderLazyText :: Render a => a -> TL.Text-renderLazyText = TLB.toLazyText . render---- | Convert renderable data directly to strict 'T.Text'.-renderText :: Render a => a -> Text-renderText = TL.toStrict . TLB.toLazyText . render---- | Write the contents of a 'Builder' to standard output.-putBuilder :: Builder -> IO ()-putBuilder = TLIO.putStr . TLB.toLazyText---- | Write the contents of a 'Builder' to some IO handle.-hPutBuilder :: Handle -> Builder -> IO ()-hPutBuilder handle = TLIO.hPutStr handle . TLB.toLazyText------------------------------------------------------------------------------------- Combinators---- | @between open close s@ surrounds @s@ with @open@ and @close@--- (i.e. @open <> s <> close@).-between :: Monoid m => m -> m -> m -> m-between open close s = open <> s <> close---- | Surround a string with square brackets.-brackets :: Builder -> Builder-brackets = between "[" "]"---- | Surround a string with curly braces.-braces :: Builder -> Builder-braces = between "{" "}"---- | @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)------------------------------------------------------------------------------------- Utility Functions---- | Parse a 'Text' of the form "key=value" into ("key", "value"). If--- the delimiter ('=') does not appear in the string, the result is--- 'Nothing'.-keyEqualsValue :: Text -> Maybe (Text, Text)-keyEqualsValue s =-  case T.break (== '=') s of-    (key, T.uncons -> Just (_, value)) -> Just (key, value)-    _                                  -> Nothing

@@ -31,6 +31,8 @@   , parseLazyText   , parseLazyTextBuilder   , parseString+  , parseFilePath+  , showsTextParser      -- * Automatic Parser Selection   , DefaultParser(..)@@ -44,7 +46,7 @@ import qualified Data.Text.Lazy.Builder as TLB import qualified Data.Text.Read         as TR -import           Mangrove.Text+import           Mangrove.Render  -- | A @TextParser@ is the most basic client-defined parsing unit. It -- parses textual data that is not otherwise part of the parsing@@ -55,6 +57,21 @@   , parserRun  :: Text -> Either Text r -- ^ An actual parsing function   } deriving (Functor) +instance Show (TextParser r) where+  showsPrec p parser = showParen (p >= 11)+    $ showString "TextParser "+    . showString "{ parserHint = " . shows (parserHint parser)+    . showString ", parserRun = _"+    . showString "}"++-- | A nicer way to show t'TextParser's is to use the parser's hint,+-- surrounded by angle brackets, e.g. @<INT>@.+showsTextParser :: TextParser a -> ShowS+showsTextParser TextParser{parserHint = hint} =+  showString "<"+  . showString (T.unpack hint)+  . showString ">"+ -- | 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@@ -152,7 +169,7 @@ instance DefaultParser Double where   defaultParser = parseDouble --- | Parse a strict 'Text' value.+-- | Parse a strict 'T.Text' value. -- -- Since the input is already strict 'Text', this parser simply returns it for free. parseText :: TextParser Text@@ -164,6 +181,7 @@ instance DefaultParser Text where   defaultParser = parseText +-- | Parse a lazy 'TL.Text' value. parseLazyText :: TextParser TL.Text parseLazyText = TextParser   { parserHint = "STRING"@@ -173,6 +191,7 @@ instance DefaultParser TL.Text where   defaultParser = parseLazyText +-- | Parse a lazy text 'TLB.Builder'. parseLazyTextBuilder :: TextParser TLB.Builder parseLazyTextBuilder = TextParser   { parserHint = "STRING"@@ -191,3 +210,10 @@  instance DefaultParser String where   defaultParser = parseString++-- | Parser for 'FilePath's.+--+-- This is the same as 'parseString' but with a more specialized+-- parser hint.+parseFilePath :: TextParser FilePath+parseFilePath = parseString { parserHint = "PATH" }

@@ -0,0 +1,32 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies     #-}++{-|+Module      : Mangrove.Token+Copyright   : (c) Quytelda Kahja, 2026+License     : BSD-3-Clause++Parsing schemes convert arguments into some form of token. This module+defines the requirements for a scheme's associated token type.+-}++module Mangrove.Token+  ( HasTokens(..)+  ) where++import           Data.Kind+import           Data.Proxy++import           Mangrove.Render++-- | Parsing schemes convert arguments into some form of token. This+-- class defines the associated token type for a particular scheme.+class (Eq (Token s), Show (Token s), Render (Token s)) => HasTokens (s :: Type -> Type) where+  -- | A token represents a particular interpretation of an argument+  -- string.+  data Token s++  -- | 'delimiter' is the character that separates argument strings in+  -- combined string representation. For example, arguments in the CLI+  -- command @ls -a -l /var@ are separated by spaces.+  delimiter :: Proxy s -> Char

@@ -5,8 +5,13 @@ Copyright   : (c) Quytelda Kahja, 2026 License     : BSD-3-Clause -An API for defining, constructing, and running Unix-style command line-parsers.+This module contains the building blocks for creating UNIX-style+command line parsers. Parsers are intended to be combined using the+standard combinators in "Control.Applicative".++The functions for running parsers live in the "Mangrove.Parser" module+and are re-exported by the "Mangrove" module alongside other useful+symbols. -}  module Mangrove.Unix@@ -18,6 +23,8 @@   , Flag(..)   , TextParser(..)   , DefaultParser(..)+  , UnixRequest(..)+  , UnixRequest'      -- * Tree-building Combinators   , parameter@@ -29,15 +36,19 @@   , subparameter   , suboption -  -- ** Help Options+    -- ** Help Options   , addHelpOptions++    -- * Requests+  , helpRequest+  , versionRequest   ) where  import           Control.Applicative import           Data.List.NonEmpty   (NonEmpty) import           Data.Text            (Text) -import           Mangrove.Parser+import           Mangrove.ParseTree import           Mangrove.Scheme.Sub  (SubParser, SubScheme) import qualified Mangrove.Scheme.Sub  as Sub import           Mangrove.Scheme.Unix@@ -81,7 +92,7 @@ requestOption   :: NonEmpty Flag   -> Text-  -> RequestType+  -> UnixRequest'   -> UnixParser a requestOption flags help = ParseNode . RequestOption (OptionInfo flags help) 

@@ -0,0 +1,164 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE DataKinds          #-}+{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications   #-}++module Arbitrary+  ( ArgList(..)+  , Name(..)+  ) where++import           Data.Char+import           Data.Text                 (Text)+import qualified Data.Text                 as T+import           System.Random+import           Test.QuickCheck           hiding (Result (..))+import           Test.QuickCheck.Gen       (Gen (..))+import           Test.QuickCheck.Instances ()++import           Mangrove+import           Mangrove.ParseTree+import           Mangrove.Render+import qualified Mangrove.Scheme.Sub       as Sub+import           Mangrove.Scheme.Unix+import qualified Mangrove.Scheme.Unix      as Unix+import           Mangrove.Stream+import           Mangrove.TextParser+import           Mangrove.Unix++--------------------------------------------------------------------------------+-- Arbitrary Name Generator++randomNameChar :: RandomGen g => g -> (Char, g)+randomNameChar gen = (chr (n + offset), gen')+  where+    (n, gen') = uniformR (0, 62) gen+    offset+      | n >= 0  && n < 10 = 48+      | n >= 10 && n < 36 = 55+      | n >= 36 && n < 62 = 61+      -- The only remaining case is n == 62.+      | otherwise = 33++randomNameText :: RandomGen g => g -> Int -> Text+randomNameText gen n = T.unfoldrN n (Just . randomNameChar) gen++genNameChar :: Gen Char+genNameChar = MkGen $ const . fst . randomNameChar++genNameText :: Gen Text+genNameText = MkGen randomNameText `suchThat` (not . T.null)++-- | newtype wrapper for 'Text' that holds results from 'genNameText'+newtype Name = Name { getName :: Text }+  deriving (Eq, Show)++getNames :: Functor f => f Name -> f Text+getNames = fmap getName++instance Arbitrary Name where+  arbitrary = Name <$> genNameText++--------------------------------------------------------------------------------+-- Generic ParseTrees++genParser :: Scheme s => Gen (s Int) -> Gen (ParseTree s Int)+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)+                  <*> 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+       ]++--------------------------------------------------------------------------------+-- SubScheme Parsers++instance Arbitrary (Token SubScheme) where+  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+        ]++instance Arbitrary (ParseTree SubScheme Int) where+  arbitrary = genParser genSubScheme++--------------------------------------------------------------------------------+-- UnixScheme Parsers++instance Arbitrary Flag where+  arbitrary =+    oneof [ LongFlag <$> genNameText+          , ShortFlag <$> genNameChar+          ]++instance CoArbitrary Flag++instance Arbitrary Unix.OptionInfo where+  arbitrary = OptionInfo <$> arbitrary <*> arbitrary++instance Arbitrary Unix.CommandInfo where+  arbitrary = CommandInfo <$> fmap getNames arbitrary <*> arbitrary++instance Arbitrary (Token UnixScheme) where+  arbitrary =+    oneof [ UnixArgument <$> arbitrary+          , UnixCommand <$> genNameText+          , UnixOption <$> arbitrary <*> arbitrary+          ]++instance CoArbitrary (Token UnixScheme)++instance Arbitrary UnixRequest where+  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+        ]++instance Arbitrary (ParseTree UnixScheme Int) where+  arbitrary = genParser genUnixScheme++--------------------------------------------------------------------------------+-- StreamParsers++genUnixArgument :: Gen Text+genUnixArgument = renderText <$> arbitrary @(Token UnixScheme)++genUnixArgs :: Gen [Text]+genUnixArgs = sized $ \n -> vectorOf n genUnixArgument++newtype ArgList = ArgList { getArgs :: [Text] }+  deriving (Show)++instance Arbitrary ArgList where+  arbitrary = ArgList <$> genUnixArgs++instance Arbitrary (StreamState (Token UnixScheme)) where+  arbitrary = StreamState <$> genUnixArgs <*> arbitrary <*> arbitrary++instance CoArbitrary (StreamState (Token UnixScheme))

@@ -4,58 +4,56 @@ module General (spec) where  import           Control.Applicative--import           Data.Version import           Test.Hspec  import           Mangrove-import           Mangrove.Text+import           Mangrove.Render  import           TestParsers  optionSpec :: Spec optionSpec = do   it "parses long options" $ do-    runHelpfulParser_ opt_example_unit ["--example"]+    runArgumentParser opt_example_unit ["--example"]       `shouldBe` Success [] ()   it "parses short options" $ do-    runHelpfulParser_ opt_e_unit ["-e"]+    runArgumentParser opt_e_unit ["-e"]       `shouldBe` Success [] ()    it "parses options in any order" $ do-    runHelpfulParser_ (opt_e_unit *> opt_f_unit) ["-e", "-f"]+    runArgumentParser (opt_e_unit *> opt_f_unit) ["-e", "-f"]       `shouldBe` Success [] ()-    runHelpfulParser_ (opt_e_unit *> opt_f_unit) ["-f", "-e"]+    runArgumentParser (opt_e_unit *> opt_f_unit) ["-f", "-e"]       `shouldBe` Success [] ()    describe "switches" $ do     context "when switch is present" $ do       it "yields True" $ do-        runHelpfulParser_ opt_example_switch ["--example"]+        runArgumentParser opt_example_switch ["--example"]           `shouldBe` Success [] True     context "when switch is absent" $ do       it "yields False" $ do-        runHelpfulParser_ opt_example_switch []+        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-        runHelpfulParser_ opt_example_param ["--example=qwer"]+        runArgumentParser opt_example_param ["--example=qwer"]           `shouldBe` Success [] "qwer"-        runHelpfulParser_ opt_e_param ["-eqwer"]+        runArgumentParser opt_e_param ["-eqwer"]           `shouldBe` Success [] "qwer"     context "when no argument is expected" $ do       it "parsing fails" $ do-        runHelpfulParser_ opt_example_unit ["--example=qwer"]+        runArgumentParser opt_example_unit ["--example=qwer"]           `shouldBe` Failure "--example=qwer: unrecognized subargument: qwer"-        runHelpfulParser_ opt_e_unit ["-eqwer"]+        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-        runHelpfulParser_ opt_example_unit ["--example", "qwer"]+        runArgumentParser opt_example_unit ["--example", "qwer"]           `shouldBe` Success ["qwer"] ()    context "when an argument is required" $ do@@ -65,11 +63,11 @@      context "when no argument is provided" $ do       it "fails to parse" $ do-        runHelpfulParser_ opt_example_param ["--example"]+        runArgumentParser opt_example_param ["--example"]           `shouldBe` Failure "--example: expected: STRING"     context "when an argument is provided" $ do       it "the argument is consumed" $ do-        runHelpfulParser_ opt_example_param ["--example", "qwer"]+        runArgumentParser opt_example_param ["--example", "qwer"]           `shouldBe` Success [] "qwer"    context "when an argument is optional" $ do@@ -78,97 +76,91 @@      context "when no argument is provided" $ do       it "yields a default value" $ do-        runHelpfulParser_ opt_example_param_optional ["--example"]+        runArgumentParser opt_example_param_optional ["--example"]           `shouldBe` Success [] "asdf"       it "does not consume subsequent options" $ do-        runHelpfulParser_ opt_example_param_optional ["--example", "--option"]+        runArgumentParser opt_example_param_optional ["--example", "--option"]           `shouldBe` Success ["--option"] "asdf"     context "when an argument is provided" $ do       it "parses the argument" $ do-        runHelpfulParser_ opt_example_param_optional ["--example", "qwer"]+        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-        runHelpfulParser_ opt_example_pair ["--example", "1,3"]+        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-        runHelpfulParser_ opt_example_param ["--example", "1,3"]+        runArgumentParser opt_example_param ["--example", "1,3"]           `shouldBe` Success [] "1,3"-        runHelpfulParser_ opt_example_param_optional ["--example", "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-        runHelpfulParser_ opt_example_subopt ["--example", "value=asdf"]+        runArgumentParser opt_example_subopt ["--example", "value=asdf"]           `shouldBe` Success [] "asdf"-        runHelpfulParser_ opt_example_subopt ["--example=value=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-        runHelpfulParser_ opt_example_param ["--example", "value=asdf"]+        runArgumentParser opt_example_param ["--example", "value=asdf"]           `shouldBe` Success [] "value=asdf"-        runHelpfulParser_ opt_example_param ["--example=value=asdf"]+        runArgumentParser opt_example_param ["--example=value=asdf"]           `shouldBe` Success [] "value=asdf"    describe "help options" $ do-    let progInfo = ProgramInfo-          { programName = "example"-          , programVersion = makeVersion [1,0]-          , programDesc = "description"-          } :: ProgramInfo s--        isResponse (Response {}) = True-        isResponse _             = False+    let isRequest (Request {}) = True+        isRequest _            = False      context "when a help option is present" $ do       it "requests help" $ do-        runHelpfulParser progInfo (withHelp opt_example_unit) ["--help"]-          `shouldSatisfy` isResponse+        runArgumentParser (withHelp opt_example_unit) ["--help"]+          `shouldSatisfy` isRequest       it "works for subcommands" $ do-        runHelpfulParser progInfo (withHelp cmd_example_tree) ["example", "--help"]-          `shouldSatisfy` isResponse-        runHelpfulParser progInfo (withHelp cmd_example_tree) ["example", "asdf", "--help"]-          `shouldSatisfy` isResponse+        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-        runHelpfulParser_ (withHelp opt_example_unit) ["--example"]+        runArgumentParser (withHelp opt_example_unit) ["--example"]           `shouldBe` Success [] ()-        runHelpfulParser_ (withHelp opt_example_unit) []+        runArgumentParser (withHelp opt_example_unit) []           `shouldBe` Failure "expected: --help or --example"       it "isn't activated by escaped options" $ do-        runHelpfulParser_ (withHelp opt_example_unit) ["--", "--help"]+        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-      runHelpfulParser_ param_text ["-"]+      runArgumentParser param_text ["-"]         `shouldBe` Success [] "-"    context "when \"--\" is present in the argument list" $ do     it "treats subsequent arguments as free arguments" $ do-      runHelpfulParser_ param_text ["--", "asdf"]+      runArgumentParser param_text ["--", "asdf"]         `shouldBe` Success [] "asdf"     it "doesn't treat subsequent arguments as options" $ do-      runHelpfulParser_ (option_asdf <|> param_text) ["--", "--asdf"]+      runArgumentParser (option_asdf <|> param_text) ["--", "--asdf"]         `shouldBe` Success [] "--asdf"     it "doesn't treat subsequent arguments as commands" $ do-      runHelpfulParser_ (command_asdf <|> param_text) ["--", "asdf"]+      runArgumentParser (command_asdf <|> param_text) ["--", "asdf"]         `shouldBe` Success [] "asdf"    context "when not enough input is provided" $ do     it "fails to generate a result" $ do-      runHelpfulParser_ param_text []+      runArgumentParser param_text []         `shouldBe` Failure "expected: STRING"    context "when not all input can be consumed" $ do     it "returns unconsumed arguments" $ do-      runHelpfulParser_ param_text ["asdf", "qwer"]+      runArgumentParser param_text ["asdf", "qwer"]         `shouldBe` Success ["qwer"] "asdf"  spec :: Spec

@@ -0,0 +1,282 @@+{-# LANGUAGE OverloadedLists   #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications  #-}++module Mangrove.ParseTreeSpec (spec) where++import           Control.Applicative+import           Data.Text             (Text)+import           Test.Hspec+import           Test.Hspec.QuickCheck+import           Test.QuickCheck       hiding (Result (..))++import           Mangrove+import           Mangrove.ParseTree+import           Mangrove.Scheme.Unix+import           Mangrove.Valency++import           Arbitrary+import           StructureEq+import           TestParsers++--------------------------------------------------------------------------------+-- Functor Laws++prop_fmapIdLaw :: UnixParser Int -> Bool+prop_fmapIdLaw tree = structEq tree (fmap id tree)++prop_fmapComLaw :: UnixParser Int -> Bool+prop_fmapComLaw tree =+  fmap (inc . dbl) tree+  `structEq`+  (fmap inc . fmap dbl) tree+  where+    inc = (1+)+    dbl = (2*)++--------------------------------------------------------------------------------+-- Applicative Laws++prop_applicativeIdLaw+  :: ParseTree UnixScheme Int+  -> ArgList+  -> Bool+prop_applicativeIdLaw tree (ArgList args) =+  result1 == result2+  where+    result1 = runArgumentParser (pure id <*> tree) args+    result2 = runArgumentParser tree 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_applicativeIntLaw+  :: Fun (Int, Int) Int+  -> ParseTree UnixScheme 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_applicativeComLaw+  :: Fun (Int, Int) Int+  -> Fun (Int, Int) Int+  -> ParseTree UnixScheme Int+  -> ParseTree UnixScheme 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_valencyPositive+  :: UnixParser Int+  -> Bool+prop_valencyPositive p =+  all (>= 0) (valency p)++prop_liftA2AddsValencies+  :: UnixParser Int+  -> UnixParser Int+  -> Bool+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+  -> Bool+prop_altMaxesValency l r =+  valency (l <|> r) == liftA2 (max) (valency l) (valency r)++prop_altPicksOne+  :: ParseTree UnixScheme Int+  -> ParseTree UnixScheme Int+  -> ArgList+  -> Bool+prop_altPicksOne l r (ArgList args) =+  resultSum == resultL || resultSum == resultR+  where+    resultL = runArgumentParser l args+    resultR = runArgumentParser r args+    resultSum = runArgumentParser (l <|> r) args++prop_altEmptyIdentity+  :: (ParseTree UnixScheme Int -> ParseTree UnixScheme Int)+  -> ParseTree UnixScheme Int+  -> ArgList+  -> Bool+prop_altEmptyIdentity append tree (ArgList args) =+  runArgumentParser tree args == runArgumentParser (append tree) args++--------------------------------------------------------------------------------++spec :: Spec+spec = do+  describe "Functor Instance" $ do+    prop "satisfies identity law"+      prop_fmapIdLaw+    prop "satisfies composition law"+      prop_fmapComLaw++  describe "Applicative Instance" $ do+    prop "satisfies identity law"+      prop_applicativeIdLaw+    prop "satisfies homomorphism law"+      prop_applicativeHomLaw+    prop "satisfies interchange law"+      prop_applicativeIntLaw+    prop "satisfies composition law"+      prop_applicativeComLaw++  describe "Valency Instance" $ do+    prop "valency is always positive"+      prop_valencyPositive++  describe "pure" $ do+    it "resolves to the given value" $ do+      runArgumentParser (ValueNode 'a' :: ParseTree UnixScheme Char) []+        `shouldBe` Success [] 'a'++  describe "liftA2" $ do+    it "combines two values" $ do+      runArgumentParser (liftA2 (+) (pure 1) (pure 2) :: ParseTree UnixScheme Int) []+        `shouldBe` Success [] 3++      -- should be equivalent+      runArgumentParser ((+) <$> pure 1 <*> pure 2 :: ParseTree UnixScheme Int) []+        `shouldBe` Success [] 3++    prop "combines results"+      prop_liftA2CombinesResults+    prop "adds valencies"+      prop_liftA2AddsValencies++  describe "empty" $ do+    it "doesn't resolve to any value" $ do+      runArgumentParser (empty :: ParseTree UnixScheme Char) []+        `shouldBe` Failure "empty"++    it "has valency zero" $ do+      valency (empty :: ParseTree UnixScheme Char)+        `shouldBe` Just 0++  describe "(<|>)" $ do+    prop "valency equals the max valency between its children"+      prop_altMaxesValency+    prop "yields the left or the right result"+      prop_altPicksOne+    prop "empty is left identity" $+      prop_altEmptyIdentity (empty <|>)+    prop "empty is right identity" $+      prop_altEmptyIdentity (<|> empty)++    context "when the left child is resolvable" $ do+      it "resolves as the left child" $ do+        runArgumentParser (pure "asdf" <|> opt_e_param) []+          `shouldBe` Success [] "asdf"++        -- When the right child is also resolvable, it should be+        -- ignored.+        runArgumentParser (pure "asdf" <|> pure "qwer" :: ParseTree UnixScheme Text) []+          `shouldBe` Success [] "asdf"++    context "when the left child is unresolvable" $ do+      it "resolves as the right child" $ do+        runArgumentParser (opt_e_param <|> pure "asdf") []+          `shouldBe` Success [] "asdf"++    context "when one child is triggered" $ do+      it "prunes the other child" $ do+        runArgumentParser (opt_e_unit <|> opt_f_unit) ["-e", "-f"]+          `shouldBe` Success ["-f"] ()+        runArgumentParser (opt_e_unit <|> opt_f_unit) ["-f", "-e"]+          `shouldBe` Success ["-e"] ()++  describe "many" $ do+    it "parses multiple instances" $ do+      runArgumentParser (many opt_e_param) ["-e", "asdf", "-e", "qwer", "-e", "zxcv"]+        `shouldBe` Success [] ["asdf", "qwer", "zxcv"]+    it "parses zero instances" $ do+      runArgumentParser (many opt_e_param) ["blah"]+        `shouldBe` Success ["blah"] []++    it "handles compound trees" $ do+      let tree = (opt_f_unit *> opt_e_param) <|> opt_example_param+      runArgumentParser (many tree) ["-f", "-e", "asdf", "--example", "qwer"]+        `shouldBe` Success [] ["asdf", "qwer"]++    it "doesn't swallow arguments" $ do+      runArgumentParser (many $ opt_f_unit *> opt_e_param) ["-f", "-e", "asdf", "-f"]+        `shouldBe` Failure "expected: -e"+        -- Some attempts at implementing many/some resulted in+        -- arguments being silently swallowed if they were consumed by+        -- a parser inside a ManyNode which didn't receive enough+        -- input to resolve. In some cases this didn't occur until the+        -- second instance of the subtree was triggered. The expected+        -- behavior in this case is to fail with a message about what+        -- input was missing.++  describe "some" $ do+    it "parses multiple instances" $ do+      runArgumentParser (some opt_e_param) ["-e", "asdf", "-e", "qwer", "-e", "zxcv"]+        `shouldBe` Success [] ["asdf", "qwer", "zxcv"]+    it "requires at least one instance" $ do+      runArgumentParser (some opt_e_param) ["blah"]+        `shouldBe` Failure "unexpected blah"++    it "handles compound trees" $ do+      let tree = (opt_f_unit *> opt_e_param) <|> opt_example_param+      runArgumentParser (some tree) ["-f", "-e", "asdf", "--example", "qwer"]+        `shouldBe` Success [] ["asdf", "qwer"]++    it "doesn't swallow arguments" $ do+      runArgumentParser (some $ opt_f_unit *> opt_e_param) ["-f", "-e", "asdf", "-f"]+        `shouldBe` Failure "expected: -e"++  describe "optional" $ do+    it "parses exactly one instance" $ do+      runArgumentParser (optional opt_e_param) ["-e", "asdf", "-e", "qwer", "-e", "zxcv"]+        `shouldBe` Success [ "-e", "qwer", "-e", "zxcv"] (Just "asdf")+    it "parses zero instances" $ do+      runArgumentParser (optional opt_e_param) ["blah"]+        `shouldBe` Success ["blah"] Nothing

@@ -1,179 +0,0 @@-{-# LANGUAGE OverloadedLists   #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeApplications  #-}--module Mangrove.ParserSpec (spec) where--import           Control.Applicative-import           Data.Text               (Text)-import           Data.Text.Lazy.Builder-import           Test.Hspec--import           Mangrove-import           Mangrove.Parser-import           Mangrove.Scheme.Unix--import           TestParsers--spec :: Spec-spec = do-  spec_ParseTree-  spec_StreamParser--spec_ParseTree :: Spec-spec_ParseTree = do-  describe "pure" $ do-    it "resolves to the given value" $ do-      runHelpfulParser_ (ValueNode 'a' :: ParseTree UnixScheme Char) []-        `shouldBe` Success [] 'a'--  describe "liftA2" $ do-    it "combines two values" $ do-      runHelpfulParser_ (liftA2 (+) (pure 1) (pure 2) :: ParseTree UnixScheme Int) []-        `shouldBe` Success [] 3--      -- should be equivalent-      runHelpfulParser_ ((+) <$> pure 1 <*> pure 2 :: ParseTree UnixScheme Int) []-        `shouldBe` Success [] 3--  describe "empty" $ do-    it "doesn't resolve to any value" $ do-      runHelpfulParser_ (empty :: ParseTree UnixScheme Char) []-        `shouldBe` Failure "empty"--  describe "(<|>)" $ do-    context "when the left child is resolvable" $ do-      it "resolves as the left child" $ do-        runHelpfulParser_ (pure "asdf" <|> opt_e_param) []-          `shouldBe` Success [] "asdf"--        -- When the right child is also resolvable, it should be-        -- ignored.-        runHelpfulParser_ (pure "asdf" <|> pure "qwer" :: ParseTree UnixScheme Text) []-          `shouldBe` Success [] "asdf"--    context "when the left child is unresolvable" $ do-      it "resolves as the right child" $ do-        runHelpfulParser_ (opt_e_param <|> pure "asdf") []-          `shouldBe` Success [] "asdf"--    context "when one child is triggered" $ do-      it "prunes the other child" $ do-        runHelpfulParser_ (opt_e_unit <|> opt_f_unit) ["-e", "-f"]-          `shouldBe` Success ["-f"] ()-        runHelpfulParser_ (opt_e_unit <|> opt_f_unit) ["-f", "-e"]-          `shouldBe` Success ["-e"] ()--  describe "many" $ do-    it "parses multiple instances" $ do-      runHelpfulParser_ (many opt_e_param) ["-e", "asdf", "-e", "qwer", "-e", "zxcv"]-        `shouldBe` Success [] ["asdf", "qwer", "zxcv"]-    it "parses zero instances" $ do-      runHelpfulParser_ (many opt_e_param) ["blah"]-        `shouldBe` Success ["blah"] []--    it "handles compound trees" $ do-      let tree = (opt_f_unit *> opt_e_param) <|> opt_example_param-      runHelpfulParser_ (many tree) ["-f", "-e", "asdf", "--example", "qwer"]-        `shouldBe` Success [] ["asdf", "qwer"]--    it "doesn't swallow arguments" $ do-      runHelpfulParser_ (many $ opt_f_unit *> opt_e_param) ["-f", "-e", "asdf", "-f"]-        `shouldBe` Failure "expected: -e"-        -- Some attempts at implementing many/some resulted in-        -- arguments being silently swallowed if they were consumed by-        -- a parser inside a ManyNode which didn't receive enough-        -- input to resolve. In some cases this didn't occur until the-        -- second instance of the subtree was triggered. The expected-        -- behavior in this case is to fail with a message about what-        -- input was missing.--  describe "some" $ do-    it "parses multiple instances" $ do-      runHelpfulParser_ (some opt_e_param) ["-e", "asdf", "-e", "qwer", "-e", "zxcv"]-        `shouldBe` Success [] ["asdf", "qwer", "zxcv"]-    it "requires at least one instance" $ do-      runHelpfulParser_ (some opt_e_param) ["blah"]-        `shouldBe` Failure "unexpected blah"--    it "handles compound trees" $ do-      let tree = (opt_f_unit *> opt_e_param) <|> opt_example_param-      runHelpfulParser_ (some tree) ["-f", "-e", "asdf", "--example", "qwer"]-        `shouldBe` Success [] ["asdf", "qwer"]--    it "doesn't swallow arguments" $ do-      runHelpfulParser_ (some $ opt_f_unit *> opt_e_param) ["-f", "-e", "asdf", "-f"]-        `shouldBe` Failure "expected: -e"--  describe "optional" $ do-    it "parses exactly one instance" $ do-      runHelpfulParser_ (optional opt_e_param) ["-e", "asdf", "-e", "qwer", "-e", "zxcv"]-        `shouldBe` Success [ "-e", "qwer", "-e", "zxcv"] (Just "asdf")-    it "parses zero instances" $ do-      runHelpfulParser_ (optional opt_e_param) ["blah"]-        `shouldBe` Success ["blah"] Nothing------------------------------------------------------------------------------------- Stream Parser Monad--data StreamResult r-  = SSuccess r-  | SEmpty-  | SFailure Builder-  | SRequest RequestType-  deriving (Eq, Show)---- | Sink the results of a 'StreamParser' into a data type for easier inspection.-runStreamParser'-  :: SupportsResponse s-  => StreamParser s r-  -> StreamState s-  -> (StreamState s, StreamResult r)-runStreamParser' parser state =-  runStreamParser parser handler state-  where-    handler = StreamHandler-      { onSuccess = \s result -> (s, SSuccess result)-      , onEmpty = \s -> (s, SEmpty)-      , onFailure = \s err -> (s, SFailure err)-      , onRequest = OnRequest $ \s t -> (s, SRequest t)-      }--initState_empty :: StreamState s-initState_empty = StreamState [] [] False--initState_singleton :: StreamState s-initState_singleton = StreamState ["asdf"] [] False--spec_StreamParser :: Spec-spec_StreamParser = do-  describe "peek" $ do-    context "when the stream is empty" $ do-      let (finalState, result) = runStreamParser' peek (initState_empty @UnixScheme)-      it "returns empty" $ do-        result `shouldBe` SEmpty-      it "preserves the state" $ do-        initState_empty `shouldBe` finalState--    context "when the stream is not empty" $ do-      let (finalState, result) = runStreamParser' peek (initState_singleton @UnixScheme)-      it "gets the first item" $ do-        result `shouldBe` SSuccess "asdf"-      it "preserves the state" $ do-        initState_singleton `shouldBe` finalState--  describe "pop" $ do-    context "when the stream is empty" $ do-      let (finalState, result) = runStreamParser' pop (initState_empty @UnixScheme)-      it "returns empty" $ do-        result `shouldBe` SEmpty-      it "preserves the state" $ do-        initState_empty `shouldBe` finalState--    context "when the stream is not empty" $ do-      let (finalState, result) = runStreamParser' pop (initState_singleton @UnixScheme)-      it "gets the first item without replacement" $ do-        result `shouldBe` SSuccess "asdf"-        streamContent finalState `shouldBe` drop 1 (streamContent initState_singleton)-      it "preserves the context" $ do-        streamContext initState_singleton `shouldBe` streamContext finalState

@@ -0,0 +1,187 @@+{-# LANGUAGE OverloadedLists   #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications  #-}++module Mangrove.StreamSpec (spec) where++import           Data.Maybe+import           Data.Text                 (Text)+import           Test.Hspec+import           Test.Hspec.QuickCheck+import           Test.QuickCheck           hiding (Result (..))+import           Test.QuickCheck.Instances ()++import           Mangrove+import           Mangrove.Scheme.Unix+import           Mangrove.Stream+import           Mangrove.Test.Stream++--------------------------------------------------------------------------------+-- Functor Laws++prop_functorIdLaw+  :: SP_Unix Int+  -> StreamState (Token UnixScheme)+  -> Bool+prop_functorIdLaw (SP_Unix m) state =+  runSPU (fmap id m) state == runSPU m state++prop_functorComLaw+  :: Fun Int Int+  -> Fun Int Int+  -> SP_Unix Int+  -> StreamState (Token UnixScheme)+  -> Bool+prop_functorComLaw (Fn f) (Fn g) (SP_Unix m) state =+  runSPU (fmap (f . g) m) state == runSPU ((fmap f . fmap g) m) state++--------------------------------------------------------------------------------+-- Applicative Laws++prop_applicativeIdLaw+  :: SP_Unix Int+  -> StreamState (Token UnixScheme)+  -> Bool+prop_applicativeIdLaw (SP_Unix m) state =+  runSPU (pure id <*> m) state == runSPU m state++prop_applicativeHomLaw+  :: Fun Int Int+  -> Int+  -> StreamState (Token UnixScheme)+  -> Bool+prop_applicativeHomLaw (Fn f) x state =+  runSPU (pure f <*> pure x) state == runSPU (pure (f x)) state++prop_applicativeIntLaw+  :: SP_Unix (Int -> Int)+  -> Int+  -> StreamState (Token UnixScheme)+  -> Bool+prop_applicativeIntLaw (SP_Unix u) y state =+  runSPU (u <*> pure y) state == runSPU (pure ($ y) <*> u) state++prop_applicativeComLaw+  :: SP_Unix (Int -> Int)+  -> SP_Unix (Int -> Int)+  -> SP_Unix Int+  -> StreamState (Token UnixScheme)+  -> Bool+prop_applicativeComLaw (SP_Unix u) (SP_Unix v) (SP_Unix w) state =+  runSPU (pure (.) <*> u <*> v <*> w) state+  == runSPU (u <*> (v <*> w)) state++--------------------------------------------------------------------------------+-- Monad Laws++prop_monadLeftId+  :: Int+  -> Fun Int (SP_Unix Int)+  -> StreamState (Token UnixScheme)+  -> Bool+prop_monadLeftId a fn state =+  runSPU (f a) state == runSPU (return a >>= f) state+  where+    f = getSPU . applyFun fn++prop_monadRightId+  :: SP_Unix Int+  -> StreamState (Token UnixScheme)+  -> Bool+prop_monadRightId (SP_Unix m) state =+  runSPU m state == runSPU (m >>= return) state++prop_monadAssoc+  :: SP_Unix Int+  -> Fun Int (SP_Unix Int)+  -> Fun Int (SP_Unix Int)+  -> StreamState (Token UnixScheme)+  -> Bool+prop_monadAssoc (SP_Unix m) fn1 fn2 state =+  runSPU ((m >>= f) >>= g) state == runSPU (m >>= (\x -> f x >>= g)) state+  where+    f = getSPU . applyFun fn1+    g = getSPU . applyFun fn2++--------------------------------------------------------------------------------++prop_peek_preservesState+  :: StreamState (Token UnixScheme)+  -> Bool+prop_peek_preservesState state =+  case runSPU peek state of+    (_, state') -> state == state'++prop_pop_preservesContext+  :: StreamState (Token UnixScheme)+  -> Bool+prop_pop_preservesContext state =+  case runSPU pop state of+    (_, state') -> streamContext state == streamContext state'++prop_pop_preservesEscaped+  :: StreamState (Token UnixScheme)+  -> Bool+prop_pop_preservesEscaped state =+  case runSPU pop state of+    (_, state') -> streamEscaped state == streamEscaped state'++prop_yieldsValueOrEmpty+  :: SP_Unix_T Text+  -> StreamState (Token UnixScheme)+  -> Bool+prop_yieldsValueOrEmpty action state =+  case runSPU action state of+    (SPSuccess a, _) -> listToMaybe (streamContent state) == Just a+    (SPEmpty, _)     -> null $ streamContent state+    _                -> False++prop_consumesValue+  :: SP_Unix_T a+  -> StreamState (Token UnixScheme)+  -> Bool+prop_consumesValue action state =+  case runSPU action state of+    (_, state') -> streamContent state' == drop 1 (streamContent state)++spec :: Spec+spec = do+  describe "Functor instance" $ do+    prop "satisfies identity law"+      prop_functorIdLaw+    prop "satisfies composition law"+      prop_functorComLaw++  describe "Applicative instance" $ do+    prop "satisfies identity law"+      prop_applicativeIdLaw+    prop "satisfies homomorphism law"+      prop_applicativeHomLaw+    prop "satisfies interchange law"+      prop_applicativeIntLaw+    prop "satisfies composition law"+      prop_applicativeComLaw++  describe "Monad instance" $ do+    prop "satisfies left identity law"+      prop_monadLeftId+    prop "satisfies right identity law"+      prop_monadRightId+    prop "satisfies associativity law"+      prop_monadAssoc++  describe "peek" $ do+    prop "preserves the stream state"+      prop_peek_preservesState+    prop "yields first value or empty" $+      prop_yieldsValueOrEmpty peek++  describe "pop" $ do+    prop "consumes values" $+      prop_consumesValue pop+    prop "yields first value or empty" $+      prop_yieldsValueOrEmpty pop+    prop "preserves escaped setting" $+      prop_pop_preservesEscaped+    prop "preserves the stream state"+      prop_pop_preservesContext

@@ -0,0 +1,113 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}++module Mangrove.Test.Stream+  ( -- * Unix Stream Parser+    SP_Unix_T++    -- * Stream Proxy+  , StreamProxy(..)+  , SPState+  , SPResult(..)+  , toStreamParser+  , fromStreamParser++    -- * Unix Stream Parser Wrapper+  , SP_Unix(..)+  , runSPU+  ) where++import           Control.Monad+import           Data.Text                 (Text)+import qualified Data.Text.Lazy            as TL+import qualified Data.Text.Lazy.Builder    as TLB+import           GHC.Generics+import           Test.QuickCheck           hiding (Result (..))+import           Test.QuickCheck.Instances ()++import           Mangrove.Scheme+import           Mangrove.Stream+import           Mangrove.Token+import           Mangrove.Unix++import           Arbitrary                 ()++type SPState = StreamState (Token UnixScheme)++data SPResult a+  = SPSuccess a+  | SPEmpty+  | SPFailure Text+  | SPRequest UnixRequest+  deriving (Eq, Show, Functor, Generic)++instance Arbitrary a => Arbitrary (SPResult a) where+  arbitrary = oneof+    [ SPSuccess <$> arbitrary+    , pure SPEmpty+    , SPFailure <$> arbitrary+    , SPRequest <$> arbitrary+    ]++newtype StreamProxy a = SP { runSP :: SPState -> (SPResult a, SPState) }+  deriving (Functor, Generic)++genSP :: Arbitrary a => Gen (StreamProxy a)+genSP = SP <$> arbitrary++instance Applicative StreamProxy where+  pure a = SP $ \state -> (SPSuccess a, state)+  (<*>) = ap++instance Monad StreamProxy where+  return = pure+  ma >>= f = SP $ \state ->+    let (result, state') = runSP ma state+    in case result of+         SPSuccess a       -> runSP (f a) state'+         SPEmpty           -> (SPEmpty, state')+         SPFailure err     -> (SPFailure err, state')+         SPRequest reqType -> (SPRequest reqType, state')++toStreamParser :: StreamProxy a -> SP_Unix_T a+toStreamParser prox = StreamParser $ \handler state ->+  let (result, state') = runSP prox state+  in case result of+       SPSuccess a       -> onSuccess handler state' a+       SPEmpty           -> onEmpty handler state'+       SPFailure err     -> onFailure handler state' (TLB.fromText err)+       SPRequest reqType -> onRequest handler state' reqType++sinkResult :: StreamHandler (Request UnixScheme) (Token UnixScheme) a (SPResult a, SPState)+sinkResult = StreamHandler+  { onSuccess = \state' a -> (SPSuccess a, state')+  , onEmpty = \state' -> (SPEmpty, state')+  , onFailure = \state' err -> (SPFailure (TL.toStrict $ TLB.toLazyText err), state')+  , onRequest = \state' req -> (SPRequest req, state')+  }++type SP_Unix_T a = StreamParser (Request UnixScheme) (Token UnixScheme) a++fromStreamParser :: SP_Unix_T a -> StreamProxy a+fromStreamParser parser = SP $ runStreamParser parser sinkResult++genStreamParser :: Arbitrary a => Gen (SP_Unix_T a)+genStreamParser = toStreamParser <$> genSP++newtype SP_Unix a = SP_Unix+  { getSPU :: SP_Unix_T a }++instance Show (SP_Unix a) where+  show _ = "(*)"++instance Arbitrary a => Arbitrary (SP_Unix a) where+  arbitrary = SP_Unix <$> genStreamParser++--------------------------------------------------------------------------------+-- Stream Helper++runSPU+  :: SP_Unix_T a+  -> StreamState (Token UnixScheme)+  -> (SPResult a, StreamState (Token UnixScheme))+runSPU parser = runStreamParser parser sinkResult

@@ -0,0 +1,57 @@+{-# LANGUAGE GADTs #-}++module StructureEq+  ( StructureEq(..)+  ) where++import           Mangrove+import           Mangrove.ParseTree+import qualified Mangrove.Scheme.Sub  as Sub+import           Mangrove.Scheme.Unix+import qualified Mangrove.Scheme.Unix as Unix+import           Mangrove.TextParser+import           Mangrove.Unix++-- | Things that can be compared for structural equality.+class StructureEq s where+  structEq :: s a -> s b -> Bool++instance StructureEq TextParser where+  structEq tp1 tp2 = parserHint tp1 == parserHint tp2++instance StructureEq SubScheme where+  structEq (Sub.Parameter p1) (Sub.Parameter p2) =+    structEq p1 p2+  structEq (Sub.Option key1 p1) (Sub.Option key2 p2) =+    key1 == key2 && structEq p1 p2+  structEq _ _ =+    False++instance StructureEq UnixScheme where+  structEq (Unix.Parameter p1) (Unix.Parameter p2) =+    structEq p1 p2+  structEq (Unix.Option info1 subtree1) (Unix.Option info2 subtree2) =+    info1 == info2 && structEq subtree1 subtree2+  structEq (Unix.Command info1 subtree1) (Unix.Command info2 subtree2) =+    info1 == info2 && structEq subtree1 subtree2+  structEq (Unix.RequestOption info1 _) (Unix.RequestOption info2 _) =+    info1 == info2+  structEq _ _ =+    False++instance StructureEq s => StructureEq (ParseTree s) where+  structEq EmptyNode EmptyNode =+    True+  structEq (ValueNode _) (ValueNode _) =+    True+  structEq (ParseNode p1) (ParseNode p2) =+    structEq p1 p2+  structEq (ProdNode _ l1 r1) (ProdNode _ l2 r2) =+    structEq l1 l2 && structEq r1 r2+  structEq (SumNode l1 r1) (SumNode l2 r2) =+    structEq l1 l2 && structEq r1 r2+  structEq (ManyNode b1 p1) (ManyNode b2 p2) =+    b1 == b2 && structEq p1 p2+  structEq _ _ =+    False+

@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wno-missing-export-lists #-} {-# LANGUAGE OverloadedLists   #-} {-# LANGUAGE OverloadedStrings #-}