mangrove-cli (empty) → 0.1.0.0
raw patch · 20 files changed
+2797/−0 lines, 20 filesdep +basedep +containersdep +hspecsetup-changed
Dependencies added: base, containers, hspec, mangrove-cli, mtl, text, transformers
Files
- CHANGELOG.md +22/−0
- LICENSE +26/−0
- README.md +461/−0
- Setup.hs +2/−0
- mangrove-cli.cabal +77/−0
- src/Mangrove.hs +206/−0
- src/Mangrove/Parser.hs +520/−0
- src/Mangrove/Resolve.hs +76/−0
- src/Mangrove/Scheme/Sub.hs +100/−0
- src/Mangrove/Scheme/Unix.hs +456/−0
- src/Mangrove/Separable.hs +67/−0
- src/Mangrove/Text.hs +107/−0
- src/Mangrove/TextParser.hs +118/−0
- src/Mangrove/Unix.hs +89/−0
- src/Mangrove/Valency.hs +43/−0
- test/General.hs +171/−0
- test/Main.hs +11/−0
- test/Mangrove/ParserSpec.hs +179/−0
- test/Spec.hs +1/−0
- test/TestParsers.hs +65/−0
+ CHANGELOG.md view
@@ -0,0 +1,22 @@+# Changelog for `mangrove`++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to the+[Haskell Package Versioning Policy](https://pvp.haskell.org/).++## Unreleased++## 0.1.0.0 - 2026-08-12++### Added++- Types and data structures for building argument parsers+- Combinators for constructing parsers+- Typeclass for parsing schemes (Scheme)+- A UNIX-style parsing scheme with a subargument parsing scheme+- A stream parsing monad (StreamParser)+- Support for generating help information+- A basic test suite with 53 unit tests+- An API for running parsers and collecting the results
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright 2025 Quytelda Kahja++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,461 @@+# Mangrove++[](https://github.com/quytelda/mangrove/actions/workflows/unit-tests.yml)++Mangrove is a library for building command line argument parsers using+Haskell's `Applicative` interface. It provides parsers for UNIX-style+command line syntax, including positional parameters, named options,+and commands, as well as complex subparameters and suboptions (e.g.+`--mount src=/webroot,dst=/var/www,rw`). It is also extensible, so you+can define alternative command line syntaxes.++## Building++This project uses `stack` as its primary build system (though building+with `cabal` should also work). As usual, you can build the library+by running `stack build` and you can install it with `stack install`.+Use `stack haddock` to build the API documentation.++## Test Suite++Mangrove has a test suite using HSpec. Run `stack test` to build and+run the tests. The `main` branch should always pass all tests, so if+something fails, please make an issue!++## Project Roadmap++This project is currently under active development. Goals currently on+the horizon include:++- Stabilize the client-facing API+- Simplify the code structure+- Improve test suite coverage+- Profiling & optimization++Once these are addressed, a 1.0.0 release will be appropriate.++# Tutorial++## A Metaphor++Imagine the roots of a plant branching out like a tree as they+descend. Eventually, they dip into a stream. The roots collect water+and nutrients from the flowing stream. These resources travel back up+the structure toward the plant, combining along the way.++This is kind of like how the Mangrove library works. We build a+tree-shaped parser from simple applicative combinators, then feed it a+sequence of CLI arguments. Simple parsers stationed at the bottom of+the tree consume these arguments and produce values which are then+passed back up the tree and combined with the results of other parsers+until a final result is reached.++## Example++__NOTE__: See the full example file in `doc/MkUser.hs`.++Suppose we are writing a simple program that creates new user+accounts - we'll call it "mkuser". The goal will be to provide a+command line interface with the following syntax:++```+mkuser [--uid=INT] [--system] [--groups={GROUP...}] USERNAME+```++First, let's create a new record that captures the program's runtime+configuration.++```haskell+data Settings = Settings+ { userId :: Maybe Int -- ^ An optional target user ID+ , userSystem :: Bool -- ^ Is this a system user?+ , userGroups :: [Text] -- ^ Groups the new user will be in+ , userName :: Text -- ^ Username for the new user+ } deriving (Show)+```++Let's also pretend that our program's logic lives inside a function+`run :: Settings -> IO ()`. We pass it the settings we want, and it+runs the program accordingly. However, since this is just an example+program, we won't actually create any user accounts; instead we'll+just have the program print its settings to `stdout`.++```haskell+run :: Settings -> IO ()+run = print+```++Now we need to construct a parser that reads a list of arguments and+yields a `Settings`. Our parser will have the type `UnixParser+Settings`.++__NOTE__: This example uses the language extensions `OverloadedLists`+and `OverloadedStrings` since we need to write lots of `NonEmpty` list+and `Text` literals.++__NOTE__: `UnixParser` is just a convenient type synonym for+`ParseTree UnixScheme`. This tells us that we will build a `ParseTree`+by combining parsers from the UNIX scheme.++## Positional Parameters++A "positional parameter" is a positional input that accepts the first+non-flag argument it encounters. In Mangrove, positional parameters+are usually just referred to as "parameters" since other kinds of+parameters have their own names. Consider an example program called+`substring` whose command line syntax is `substring START END STRING`.+`START`, `END`, and `STRING` would be parameters. If we invoke+`substring 1 3 "example"`, we know that `START` is `1`, `END` is `3`,+and `STRING` is `"example"` because of the order in which they appear.++Our program will have just one parameter: a username. Here is how we+define a parser for it:++```haskell+prm_name :: UnixParser Text+prm_name = parameter defaultParser+```++The `parameter` function creates a parameter parser out of a+`TextParser`.++### TextParsers++A `TextParser r` is just a wrapper around a function that parses+`Text` into a value of type `r`. It also contains a "hint" string used+for displaying usage information.++Many common data types have a reasonable default `TextParser`+implementation. Types that are instances of the `DefaultParser` class+implement `defaultParser :: DefaultParser a => TextParser a`, letting+us automatically select the correct parser based on the required type.++In the example above, `Text` has a very simple `DefaultParser`+instance that just returns its input unchanged.++## Options++An "option" is a construct representing a named input. Options begin+with a flag followed by an optional subargument string.++A "flag" is special symbol that signals the beginning of a particular+option. Per UNIX tradition there are long flags (e.g. `--foo`) and+short flags (e.g `-f`).++To prevent ambiguity, sometimes an equals sign is used to separate a+long flag from its subargument string (instead of a space). For+example, `--uid=1000` is an option that begins with the `--uid` flag+and is followed by the subargument string `1000`. Similarly, an+option's short flag can be directly concatenated with its argument,+e.g. `-u 1000` can be written `-u1000`.++Let's define a parser for the `--uid` option:++```haskell+opt_uid :: UnixParser Int+opt_uid = option ["--uid", "-u"]+ "Specify a user ID"+ $ subparameter defaultParser+```++The `option` function creates a parser for CLI options. It takes three+arguments:++1. A `NonEmpty` list of `Flag`s that trigger the option, in this case+ "--uid" and "-u". `Flag` is an instance of `IsString`, so we can+ just write the string representation instead of `LongFlag "uid"`+ and `ShortFlag 'u'`.+2. A human readable description. This will be displayed when help+ output is triggered.+3. A subparser tree (`SubParser r`) that will parse any subparameters or+ suboptions. In this case, we declare a single subparameter (an+ integer).++The `subparameter` function behaves just like `parameter` from+earlier, except it creates a `SubParser` instead of a `UnixParser`. We+also use `defaultParser` to automatically select an appropriate+`TextParser` for `Int`.++__NOTE__: `SubParser` is a type synonym for `ParseTree SubScheme`.+That means we build a `SubParser` by combining `SubScheme` parsers.+`SubScheme` provides parsers for handling subarguments to options.++You might notice that our `Settings` record requires a `Maybe Int`,+not an `Int`. However, since `UnixParser` is an instance of+`Alternative`, we can use `optional` from `Control.Applicative`.+`optional opt_uid :: UnixParser (Maybe Int)` describes an option that+is not required and might be absent (which should give us `Nothing`).++### Switches++The `--system` option is simpler because because it doesn't accept any+subarguments - it is either present (`True`) or absent (`False`). This+special type of option is a "switch", and we can use the `switch`+function to create a parser:++```haskell+opt_system :: UnixParser Bool+opt_system = switch ["--system", "-s"] "Create a system user"++-- If we defined this without 'switch' it would look like this:+-- opt_system = option ["--system", "-s"]+-- "Create a system user"+-- (pure True)+-- <|> pure False++```++### Options with Multiple Subparameters++Let's deal with the `--groups` option. This option is a bit different+from the `--uid` option because we want the user to be able to specify+a list of groups for the new user to join. Thus, we want to create an+option that accepts one or more subarguments.++Thankfully, `SubParser` is also an `Alternative` instance. We can use+`some` (from `Control.Applicative`) to convert a `SubParser r` into a+`SubParser [r]` that will expect to parse one or more `r` values.++```haskell+opt_groups :: UnixParser [Text]+opt_groups =+ option ["--groups", "-g"]+ "Specify what groups the user is part of"+ $ some $ subparameter defaultParser+```++Mangrove recognizes that the subparser `some $ subparameter+defaultParser :: SubParser [Text]` can consume multiple subarguments,+so it splits those subarguments apart by comma. This allows us to pass+a list of group names like so: `--groups=wheel,audio,input`, and the+parser will yield `["wheel","audio","input"]`.++By using `some` instead of the similar function `many`, we have+created a subparser that will fail if no subarguments are provided+(e.g. `mkuser alice --groups`).++What if the `--groups` option isn't present at all? We still need a+`[Text]` value for our `Settings` record. In that case, an empty list+makes sense. Just like with our `--uid` option, we use `Alternative`+to define what happens if our parser never finds applicable input.++```+opt_groups <|> pure [] :: UnixParser [Text]+```++__NOTE__: There is an important distinction between a parser that+never finds relevant input and a parser that fails. In an expression+like `opt_groups <|> pure []`, if `opt_groups` never finds relevant+input, the alternative provides a default value. However, if+`opt_groups` *does* find applicable input, but parsing it fails, an+error will be thrown instead.++More generally, if `p` and `q` are parsers, then `p <|> q` is a parser+that yields the result from whichever parser finds applicable input+first. If neither parser finds input, we first try resolving `p` and+then `q` with no input and yield the first result we get. If neither+succeeds, we throw an error.++## Applicative++We are now ready to construct our `Settings` parser using `<$>` and+`<*>`:++```haskell+parseSettings :: UnixParser Settings+parseSettings =+ Settings+ <$> optional opt_uid+ <*> opt_system+ <*> (opt_groups <|> pure [])+ <*> prm_name+```++Now we can inspect the automatically generated usage information for+our parser in GHCi using `render` from `Mangrove.Text`:++```+ghci> render parseSettings+"[--uid=INT] [--system] [--groups={STRING...}] STRING"+```++This output indicates that our parser accepts (but does not require) a+`--uid` option with an integer subargument, a `--system` option, and a+`--groups` option with a list of string subarguments. Finally, it+requires a single parameter, which is a string. We'll see how to+improve those type hints later.++## Program Metadata++The last thing we need to define before running our parser is a+structure with some metadata about the program:++```haskell+programInfo :: ProgramInfo+programInfo = ProgramInfo+ { programName = "mkuser" -- The name of the program+ , programDesc = "Create user accounts" -- A short description of the program+ }+```++This information is used to display nice, human-readable help and+usage information, which will is discussed in more detail in the [Help+Options](#help-options) section.++## Running the Parser++The `parseArguments` function will run our parser with the arguments+passed to our program by the operating system.++```haskell+main :: IO ()+main = parseArguments programInfo parseSettings run+```++`parseArguments` takes three arguments: the program metadata (for help+output), a `UnixParser r`, and a function of type `r -> IO a`. When+the parser completes successfully, this function will be called with+the result. Otherwise, `parseArguments` will print error messages or+help information as appropriate, and then exit.++If you want to run an argument parser without using `IO`, or you want+to pass your own argument list, check out `runHelpfulParser` from+`Mangrove`.++Now we have a complete program we can build and run to show the+argument parser in action!++```+$ ghc -o mkuser MkUser.hs+[1 of 2] Compiling Main ( MkUser.hs, MkUser.o )+[2 of 2] Linking mkuser++$ ./mkuser --system --groups audio,input bilbo+Settings {userId = Nothing, userSystem = True, userGroups = ["audio","input"], userName = "bilbo"}++$ ./mkuser --badinput+unexpected --badinput++$ ./mkuser --system+expected: STRING++$ ./mkuser --uid=InvalidNumber bilbo+--uid=InvalidNumber: InvalidNumber: input does not start with a digit+```++## Help Options++Currently, our CLI interface is missing something important: an option+for displaying help and usage information. Let's create a new+`Settings` parser that recognizes `--help` as a request for help+information.++```haskell+parseSettings' :: UnixParser Settings+parseSettings' = addHelpOptions ["--help"]+ "Display help and usage information"+ parseSettings++main :: IO ()+main = parseArguments programInfo parseSettings' run+```++Now if we invoke our program with the `--help` option, it will display+a nice summary of how to use it:++```+./mkuser --help+Usage:+mkuser [--uid=INT] [--system] [--groups={STRING...}] STRING+mkuser --help++Create user accounts++ --help Display help and usage information+-g --groups {STRING...} Specify what groups the user is part of+-s --system Create a system user+-u --uid INT Specify a user ID+```++__NOTE__: If an interface defines any commands (see below),+`addHelpOptions` will add a help option at the root of the parse tree+as well as the root of every command subtree. This is so that you can+invoke `myprogram --help` to get general help or `myprogram+somecommand --help` to get help information specifically for+`somecommand`.++## Hints++Type hints are displayed as placeholders for parameters in help and+usage information. They are a hint to the user about what kind of+information is expected by that input. For example, `--uid=INT`+indicates the `--uid` option expects an integer as a subargument.+Hints stored inside the `parserHint` field of a `TextParser`.++Our program uses the generic hints defined in the `DefaultParser`+instances for `Int` and `Text`. These defaults are often reasonable,+but we can also tailor hints more specifically for our use case. All+we need to do is alter the value of `parserHint` for the relevant+`TextParser`.++```+opt_groups :: UnixParser [Text]+opt_groups =+ option ["--groups", "-g"]+ "Specify what groups the user is part of"+ $ some $ subparameter defaultParser {parserHint = "GROUP"}++prm_name :: UnixParser Text+prm_name = parameter defaultParser {parserHint = "USERNAME"}+```++Now our help output looks like this:++```+$ ./mkuser --help+Usage:+mkuser [--uid=INT] [--system] [--groups={GROUP...}] USERNAME+mkuser --help++Create user accounts++ --help Display help and usage information+-g --groups {GROUP...} Specify what groups the user is part of+-s --system Create a system user+-u --uid INT Specify a user ID+```++## Commands++A "command" is a special argument changes the context of a parser.+When a command is encountered, the parser begins using the parse tree+associated with that command as a new context until it completes.+Commands are usually used as a way to invoke different modes of+functionality for a single program. For example, `git` supports+various commands like `commit` or `pull`.++Suppose we are creating a basic version control system similar to+`git`. Our program will have several runtime modes for doing+operations like `commit` or `pull`. Here is how we might define a+parser that recognizes the corresponding commands (for the full code,+see `doc/VersionControl.hs`):++```haskell+data Mode+ = CommitMode CommitSettings+ | PullMode PullSettings+ -- ... and probably other modes too+ deriving (Show)++parseMode :: UnixParser Mode+parseMode = cmd_commit <|> cmd_pull+ where+ cmd_commit =+ command ["commit"]+ "Make a new commit"+ $ CommitMode <$> parseCommitSettings+ cmd_pull =+ command ["pull"]+ "Download remote changes"+ $ PullMode <$> parsePullSettings+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ mangrove-cli.cabal view
@@ -0,0 +1,77 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.39.6.+--+-- see: https://github.com/sol/hpack++name: mangrove-cli+version: 0.1.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+homepage: https://github.com/quytelda/mangrove#readme+bug-reports: https://github.com/quytelda/mangrove/issues+author: Quytelda Kahja+maintainer: quytelda@tamalin.org+copyright: Copyright 2026 Quytelda Kahja+license: BSD-3-Clause+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/quytelda/mangrove++library+ exposed-modules:+ Mangrove+ Mangrove.Parser+ Mangrove.Resolve+ Mangrove.Scheme.Sub+ Mangrove.Scheme.Unix+ Mangrove.Separable+ Mangrove.Text+ Mangrove.TextParser+ Mangrove.Unix+ Mangrove.Valency+ other-modules:+ Paths_mangrove_cli+ autogen-modules:+ Paths_mangrove_cli+ hs-source-dirs:+ src+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+ build-depends:+ base >=4.7 && <5+ , containers >=0.6.7 && <0.9+ , mtl >=2.3.1 && <2.4+ , text >=2.0.2 && <2.2+ , transformers >=0.6.1 && <0.7+ default-language: Haskell2010++test-suite mangrove-cli-test+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ General+ Mangrove.ParserSpec+ Spec+ TestParsers+ Paths_mangrove_cli+ autogen-modules:+ Paths_mangrove_cli+ hs-source-dirs:+ test+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , containers >=0.6.7 && <0.9+ , hspec >=2.9 && <3+ , mangrove-cli+ , mtl >=2.3.1 && <2.4+ , text >=2.0.2 && <2.2+ , transformers >=0.6.1 && <0.7+ default-language: Haskell2010
+ src/Mangrove.hs view
@@ -0,0 +1,206 @@+{-# 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 an API (types and functions) for running argument parsers.+-}+module Mangrove+ ( -- * Standard Interface+ parseArguments++ -- * Types+ , ProgramInfo(..)+ , ParseTree+ , Scheme+ , Result(..)+ , SupportsHelp+ , StreamState+ , HelpHandler+ , HelpContinuation(..)++ -- * 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++-- | Program metadata for displaying help output.+data ProgramInfo = ProgramInfo+ { programName :: !Text -- ^ The program name+ , programDesc :: !Text -- ^ A description of the program+ } deriving (Show)++-- | The results of a parsing operation.+--+-- Only parsing schemes that support generating help output will yield+-- 'Help' values.+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 help yields human-readable help output (for+ -- parsers that support it).+ Help :: SupportsHelp 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 '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 help output.+runSilentParser+ :: (Scheme s, HelpSupport s ~ 'Silent)+ => 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+-- 'StreamState' as the starting state.+runSilentParser'+ :: (Scheme s, HelpSupport s ~ 'Silent)+ => ParseTree s r -- ^ Argument parser+ -> StreamState s -- ^ Initial stream state+ -> Result s r+runSilentParser' tree state =+ runArgumentParser' tree state Success Failure NoHelp++-- | Attempt to parse a value of type @r@ from a list of arguments,+-- where the parser @ParseTree s r@ supports help output.+runHelpfulParser+ :: SupportsHelp s+ => ProgramInfo -- ^ 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+-- 'StreamState' as the starting state.+runHelpfulParser'+ :: SupportsHelp s+ => ProgramInfo -- ^ Program metadata+ -> ParseTree s r -- ^ Argument parser+ -> StreamState s -- ^ Initial stream state+ -> Result s r+runHelpfulParser' info tree state =+ runArgumentParser' tree state Success Failure (OnHelp _onHelpRequest)+ where+ _onHelpRequest state' =+ Help $ makeHelpInfo tree (streamContext state') (programName info) (programDesc info)++-- | A variant of 'runHelpfulParser' that treats help requests as+-- failures.+runHelpfulParser_+ :: SupportsHelp s+ => ParseTree s r -- ^ Argument parser+ -> [Text] -- ^ Input arguments+ -> Result s r+runHelpfulParser_ tree args =+ runArgumentParser' tree (argsToState args) Success Failure (OnHelp _onHelpRequest)+ where+ _onHelpRequest 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 help was requested, we abandon parsing and print+-- the relevant help output to stdout, then exit without indicating an+-- error.+parseArguments+ :: SupportsHelp 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 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+ Help 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+ -> HelpHandler s a -- ^ Help request handler+ -> a+runArgumentParser tree args =+ runArgumentParser' tree StreamState+ { streamContent = args+ , streamContext = []+ , streamEscaped = False+ }++-- | A more general form of 'runArgumentParser' that accepts a custom+-- 'StreamState' as the starting state.+runArgumentParser'+ :: Scheme s+ => ParseTree s r -- ^ Argument parser+ -> StreamState s -- ^ Initial stream state+ -> ([Text] -> r -> a) -- ^ Success handler+ -> (Text -> a) -- ^ Failure handler+ -> HelpHandler s a -- ^ Help 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"+ , onHelpRequest = hhelp+ }
+ src/Mangrove/Parser.hs view
@@ -0,0 +1,520 @@+{-# 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 #-}++{-|+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.++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.+-}+module Mangrove.Parser+ ( -- * Parse Trees+ ParseTree(..)+ , isProduct+ , isSum+ , isOptional+ , isChoice++ -- ** Feeding Trees+ , satiate++ -- * Parsing Schemes+ , Scheme(..)+ , HelpCapability(..)+ , SupportsHelp(..)++ -- * Stream Parser+ , StreamParser(..)+ , StreamHandler(..)+ , StreamState(..)+ , HelpHandler+ , HelpContinuation(..)++ -- ** Help+ , requestHelp++ -- ** Escaping+ , setEscaped+ , getEscaped++ -- ** Context+ , getContext+ , setContext+ , withContext+ , formatError++ -- ** Streaming+ , popMaybe+ , peekMaybe+ , pop+ , peek+ , push+ , pop_+ ) where++import Control.Applicative+import Control.Monad.Except+import Data.Kind+import qualified Data.List as List+import Data.Maybe+import Data.Proxy+import Data.Text (Text)+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TLB++import Mangrove.Resolve+import Mangrove.Separable+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 _ = ""++instance (Separable s, Valency s) => Separable (ParseTree s) where+ separate (SumNode l r) = Exhibit norm (modalsL <> modalsR)+ where+ Exhibit normL modalsL = separate l+ Exhibit normR modalsR = separate r+ norm = liftA2 SumNode normL normR+ <|> normL+ <|> normR+ separate (ProdNode f l r) = Exhibit norm modals+ where+ Exhibit normL modalsL = separate l+ Exhibit normR modalsR = separate r+ node = ProdNode f+ norm = liftA2 node normL normR+ cross g modalTrees normalTrees =+ [ g (if usesTerseOutput m && isOptional n then empty else n) <$> m+ | m <- modalTrees+ , n <- normalTrees+ ]+ modals = cross (flip node) modalsL (maybeToList normR)+ <> cross node modalsR (maybeToList normL)+ <> [liftA2 node u v | u <- modalsL, v <- modalsR]+ separate (ParseNode p) = ParseNode <$> separate p+ separate n = Exhibit (Just n) []++--------------------------------------------------------------------------------+-- Parsing Schemes++-- | A marker that distinguishes "silent" schemes (which produce no+-- help output) from "helpful" schemes, which support the production+-- of help output.+data HelpCapability = Silent | Helpful++-- | 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 supports help+ -- output.+ --+ -- It is 'Silent' by default, but must be set to 'Helpful' if the+ -- scheme will implement an instance of 'SupportsHelp'.+ type HelpSupport s :: HelpCapability+ type HelpSupport s = 'Silent++ -- | '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++-- | A class for schemes that support human-readable help output.+--+-- NOTE: In order to define a 'SupportsHelp' instance for some @Scheme+-- s@, @HelpSupport s@ must be set to 'Helpful'.+class (Scheme s, HelpSupport s ~ 'Helpful) => SupportsHelp s where+ makeHelpInfo :: ParseTree s r -> [Token s] -> Text -> Text -> 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)++-- | A handler for when help is requested.+--+-- This will hold a continuation function for helpful parsing+-- schemes, or a placeholder value for silent schemes.+data family HelpContinuation (cap :: HelpCapability) (s :: Type -> Type) r++data instance HelpContinuation 'Silent s r+ = NoHelp+ deriving (Functor)++newtype instance HelpContinuation 'Helpful s r+ = OnHelp (StreamState s -> r)+ deriving (Functor)++-- | A handler for when help is requested.+--+-- This will hold a continuation function for helpful parsing+-- schemes, or a placeholder value for silent schemes.+type HelpHandler s r = HelpContinuation (HelpSupport 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+ , onHelpRequest :: HelpHandler s r -- ^ Help Continuation+ }++-- | The amazing stream parsing monad! This monad tracks the stream+-- state and context. It short-circuits when exceptions or+-- help-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 help information is requested. Short-circuits any+-- further operations.+requestHelp :: HelpSupport s ~ 'Helpful => StreamParser s a+requestHelp = StreamParser $ \handler state ->+ case onHelpRequest handler of+ OnHelp h -> h state++-- | 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 }+ ()++--------------------------------------------------------------------------------++-- | '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 EmptyNode = empty+feed (ValueNode _) = empty+feed (ParseNode parser) = ValueNode <$> activate parser+feed (ProdNode f l r) =+ (ProdNode f <$> feed l <*> pure r) <|>+ (ProdNode f l <$> feed r)+feed (SumNode l r) = feed l <|> feed r+feed (ManyNode _ tree) =+ ProdNode (:)+ <$> feed tree+ <*> pure (ManyNode False tree)++-- | 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 tree = do+ parseSpecials+ result <- optional $ feed tree+ case result of+ Just tree' -> satiate tree'+ Nothing -> pure tree
+ src/Mangrove/Resolve.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++{-|+Module : Mangrove.Resolve+Copyright : (c) Quytelda Kahja, 2026+License : BSD-3-Clause++Resolvable parsers represent expressions that can be evaluated to a+value once they have received the appropriate input.+-}+module Mangrove.Resolve+ ( -- * Resolution+ Resolve(..)+ , ResolveM(..)+ , renderExpectedError+ , resolveLifted+ ) where++import Control.Applicative+import Control.Monad.Except+import qualified Data.List as List+import Mangrove.Text++-- | A monad for resolving parsers and expression trees.+--+-- We track two kinds of failure: (1) we expected something specific+-- and didn't find it, and (2) the parser resolved to an empty value.+data ResolveM a+ = EmptyError+ | ExpectedError [Builder]+ | Value a+ deriving (Functor)++instance Applicative ResolveM where+ pure = Value++ Value f <*> r = fmap f r+ ExpectedError es <*> _ = ExpectedError es+ EmptyError <*> _ = EmptyError++instance Alternative ResolveM where+ empty = EmptyError++ ExpectedError es1 <|> ExpectedError es2 = ExpectedError $ es1 <> es2+ l@(Value _) <|> _ = l+ _ <|> r = r++instance Monad ResolveM where+ return = pure++ Value a >>= f = f a+ ExpectedError es >>= _ = ExpectedError es+ EmptyError >>= _ = EmptyError++-- | An error message for 'EmptyError's.+renderEmptyError :: Builder+renderEmptyError = "empty"++-- | Format an error message for 'ExpectedError's.+renderExpectedError :: [Builder] -> Builder+renderExpectedError es =+ "expected: " <> (mconcat . List.intersperse " or ") es++-- | Things that can be resolved to a value, but might fail to+-- resolve.+class Resolve m where+ resolve :: m r -> ResolveM r++-- | Lift 'resolve' into 'MonadError Builder'.+resolveLifted :: (Resolve f, MonadError Builder m) => f r -> m r+resolveLifted mr = case resolve mr of+ EmptyError -> throwError renderEmptyError+ ExpectedError es -> throwError $ renderExpectedError es+ Value a -> pure a
+ src/Mangrove/Scheme/Sub.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++{-|+Module : Mangrove.Scheme.Sub+Copyright : (c) Quytelda Kahja, 2026+License : BSD-3-Clause++A parsing scheme for Unix-style subarguments (i.e. arguments passed as+subarguments to an option).+-}+module Mangrove.Scheme.Sub+ ( -- * Types+ SubScheme(..)+ , Token(..)+ , SubParser++ -- * Properties+ , hasSubOptions+ ) where++import Control.Applicative+import Data.Text (Text)++import Mangrove.Parser+import Mangrove.Resolve+import Mangrove.Separable+import Mangrove.Text+import Mangrove.TextParser+import Mangrove.Valency++-- | Parsers for subarguments of an option (e.g. @--option key=value@).+data SubScheme r+ = Parameter (TextParser r) -- ^ Parses freeform arguments+ | Option Text (TextParser r) -- ^ Suboptions have the form "KEY=VALUE"+ deriving (Functor)++instance Valency SubScheme where+ valency _ = Just 1++instance Resolve SubScheme where+ resolve (Parameter (TextParser hint _)) =+ ExpectedError [render hint]+ resolve (Option key (TextParser hint _)) =+ ExpectedError [render key <> "=" <> render hint]++instance Separable SubScheme where+ separate s = Exhibit (Just s) []++instance Scheme SubScheme where+ data Token SubScheme+ = SubAssoc Text Text -- ^ A "KEY=VALUE" argument+ | SubArgument Text -- ^ A standard freeform argument+ deriving (Eq, Show)++ delimiter _ = ','++ activate parser = do+ next <- peek+ escaped <- getEscaped+ case (parser, keyEqualsValue next) of+ (Parameter tp, Nothing) ->+ withContext (SubArgument next) $+ pop_ *> runTextParser tp next+ (Option _ _, Nothing) ->+ empty+ (Option key tp, Just (k,v))+ | not escaped && key == k ->+ withContext (SubAssoc k v) $+ pop_ *> runTextParser tp v+ (Parameter tp, Just _)+ | escaped ->+ withContext (SubArgument next) $+ pop_ *> runTextParser tp next+ | otherwise ->+ empty+ _ -> empty++ usageInfo (Parameter tp) = render $ parserHint tp+ usageInfo (Option key tp) = render key <> "=" <> render (parserHint tp)++instance Render (Token SubScheme) where+ render (SubAssoc key value) = render key <> "=" <> render value+ render (SubArgument value) = render value++-- | Type alias for SubScheme parse trees.+type SubParser = ParseTree SubScheme++-- | Check whether a parse tree contains any suboption parsers. This+-- allows us to determine if we need to parse "KEY=VALUE" pairs.+hasSubOptions :: ParseTree SubScheme r -> Bool+hasSubOptions EmptyNode = False+hasSubOptions (ValueNode _) = False+hasSubOptions (ParseNode (Parameter _)) = False+hasSubOptions (ParseNode (Option _ _)) = True+hasSubOptions (ProdNode _ l r) = hasSubOptions l || hasSubOptions r+hasSubOptions (SumNode l r) = hasSubOptions l || hasSubOptions r+hasSubOptions (ManyNode _ tree) = hasSubOptions tree
+ src/Mangrove/Scheme/Unix.hs view
@@ -0,0 +1,456 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++{-|+Module : Mangrove.Scheme.Unix+Copyright : (c) Quytelda Kahja, 2026+License : BSD-3-Clause++A parsing scheme for Unix-style command line arguments.+-}+module Mangrove.Scheme.Unix+ ( -- * Describing Commands & Options+ Flag(..)+ , OptionInfo(..)+ , CommandInfo(..)++ -- * Unix Scheme+ , UnixScheme(..)+ , Token(..)+ , UnixParser++ -- * Help+ , addHelpOptions+ , renderHelp+ ) where++import Control.Applicative+import Control.Monad+import Control.Monad.Except+import qualified Data.List as List+import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NonEmpty+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe+import Data.String+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TLB++import Mangrove+import Mangrove.Parser+import Mangrove.Resolve+import Mangrove.Scheme.Sub (SubScheme)+import qualified Mangrove.Scheme.Sub as Sub+import Mangrove.Separable+import Mangrove.Text+import Mangrove.TextParser+import Mangrove.Valency++--------------------------------------------------------------------------------+-- User Interface Descriptions++-- | A flag is a special argument that identifies a named option to+-- the parser. Flags can have two forms: long flags start with a+-- double dash (e.g. "--example") followed by a string while short+-- flags start with only a single dash (e.g. "-e") and are identified+-- by a single character.+--+-- For convenience, 'Flag' is an instance of 'Data.String.IsString'.+-- Thus, you can write @"--flop"@ instead of @LongFlag "flop"@ and+-- @"-c"@ instead of @ShortFlag \'c\'@.+data Flag+ = LongFlag Text+ | ShortFlag Char+ deriving (Eq, Ord, Show)++instance IsString Flag where+ fromString ('-':'-':name)+ | not (null name) = LongFlag $ T.pack name+ fromString ['-', c]+ | c /= '-' = ShortFlag c+ fromString s = error $ "not a valid flag: " <> s++instance Render Flag where+ render (LongFlag s) = "--" <> render s+ render (ShortFlag c) = "-" <> render c++-- | A description of a CLI option.+data OptionInfo = OptionInfo+ { optFlags :: NonEmpty Flag -- ^ A list of flags that trigger this option.+ , optHelp :: Text -- ^ A description displayed in help output.+ } deriving (Eq, Ord, Show)++-- | Get a representative flag for this option (e.g. the first one).+optHead :: OptionInfo -> Flag+optHead = NonEmpty.head . optFlags++-- | A description of a CLI command.+data CommandInfo = CommandInfo+ { cmdNames :: NonEmpty Text -- ^ Command Names+ , cmdHelp :: Text -- ^ A description displayed in help output.+ } deriving (Eq, Ord, Show)++-- | Get a representative command name for this command (e.g. the+-- first one).+cmdHead :: CommandInfo -> Text+cmdHead = NonEmpty.head . cmdNames++-- | A parsing scheme for Unix-style command line syntax.+data UnixScheme r+ -- | A freeform positional parameter+ = Parameter (TextParser r)+ -- | A subcommand with its own parse tree+ | Command CommandInfo (ParseTree UnixScheme r)+ -- | A named option that might support suboptions+ | Option OptionInfo (ParseTree SubScheme r)+ -- | A special option that requests help information+ | HelpOption OptionInfo+ deriving (Functor)++instance Valency UnixScheme where+ valency (Parameter _) = Just 1+ valency (Command _ subtree) = fmap (+1) (valency subtree)+ valency (Option _ subtree) = fmap (max 2) (valency subtree)+ valency (HelpOption _) = Just 1++instance Resolve UnixScheme where+ resolve (Parameter (TextParser hint _)) =+ ExpectedError [render hint]+ resolve (Option info _) =+ ExpectedError [render $ optHead info]+ resolve (HelpOption info) =+ ExpectedError [render $ optHead info]+ resolve (Command info _) =+ ExpectedError [render $ cmdHead info]++instance Separable UnixScheme where+ separate p@(HelpOption _) = Exhibit Nothing [Modal True p]+ separate (Command info subtree) =+ Exhibit Nothing $ (Modal False <$> maybeToList mregular) <> modals+ where+ Exhibit mregular modals = Command info <$> separate subtree+ separate p = Exhibit (Just p) []++-- | A parser for interpreting options. An option always begins with a+-- flag, followed optionally by an "=" sign and a bound argument. The+-- strings "--" and "-" are not treated as options.+parseUnixOption :: Alternative f => Text -> f (Flag, Maybe Text)+parseUnixOption (T.stripPrefix "--" -> Just s)+ | not (T.null s) =+ case keyEqualsValue s of+ Just (k, v) -> pure (LongFlag k, Just v)+ Nothing -> pure (LongFlag s, Nothing)+parseUnixOption (T.stripPrefix "-" >=> T.uncons -> Just (k,v))+ | k /= '-' =+ pure (ShortFlag k, if T.null v then Nothing else Just v)+parseUnixOption _ = empty++-- | Does this text look like a flag? We check whether it starts with+-- "-" followed by any other character.+isMarked :: Text -> Bool+isMarked "-" = False+isMarked s = "-" `T.isPrefixOf` s++instance Scheme UnixScheme where+ data Token UnixScheme+ -- | A freeform positional argument that is not an option or command+ = UnixArgument Text+ -- | A recognized subcommand+ | UnixCommand Text+ -- | A named option with optional bound argument+ | UnixOption Flag (Maybe Text)+ deriving (Eq, Show)++ type HelpSupport UnixScheme = 'Helpful++ delimiter _ = ' '++ parseSpecials = do+ peekMaybe >>= \case+ Just "--" -> pop_ *> setEscaped True+ _ -> pure ()++ activate (Parameter tp) = do+ next <- peek++ -- Arguments that begin with a dash should never be treated as+ -- unbound subarguments. However, the string "-" is always+ -- accepted since this is commonly used to represent stdin.+ escaped <- getEscaped+ guard $ escaped || not (isMarked next)++ withContext (UnixArgument next) $+ pop_ *> runTextParser tp next++ activate (Option info subtree) = do+ -- Arguments should never be interpreted as options when escaped.+ getEscaped >>= guard . not++ (flag, mbound) <- peek >>= parseUnixOption+ guard $ flag `elem` optFlags info+ pop_++ -- We need to convert whatever argument string we have (if any)+ -- into a list of subarguments as input for the subparser. If the+ -- subtree accepts multiple arguments, we split the input by+ -- comma. Otherwise, we can just pass a singleton list containing+ -- the argument string.+ --+ -- If the subtree contains no suboptions, we enable escaping to+ -- prevent arguments containing an "=" sign from being interpreted+ -- as suboptions. This is necessary because individual+ -- subparameter parsers have no way to determine that such an+ -- argument won't be consumed by a subsequent suboption parser.+ -- Escaping forces subparameter parsers to consume the argument,+ -- regardless of its form.+ let splitArgs s = if multary subtree+ then T.split (== ',') s+ else [s]+ initState args = StreamState+ { streamContent = args+ , streamContext = []+ , streamEscaped = not $ Sub.hasSubOptions subtree+ }+ parseSubargs args =+ runArgumentParser' subtree (initState args)+ (curry pure)+ (throwError . render)+ NoHelp++ withContext (UnixOption flag mbound) $ do+ -- If a bound argument (e.g. --floop=blah) is provided, we+ -- expect it to be consumed by the subparser. If it isn't fully+ -- consumed, we have nothing to do with the leftovers, so we+ -- throw an error.+ --+ -- If there's no bound argument but the next regular argument+ -- doesn't look like an option, then we try running the+ -- subparser using that as input. If it is fully consumed, we+ -- pop it from the front of the stream. If nothing is consumed,+ -- we leave it at the head of the stream. However, if it is+ -- partially consumed, then something has gone wrong, and we+ -- throw an error.+ mnext <- peekMaybe+ case (mbound, mnext) of+ (Just argString, _) -> do+ (leftover, result) <- parseSubargs (splitArgs argString)+ forM_ leftover $ \arg ->+ throwError $ "unrecognized subargument: " <> render arg+ pure result+ (_, Just argString)+ | not (isMarked argString) -> do+ let args = splitArgs argString+ (leftover, result) <- parseSubargs args+ when (length args /= length leftover) $ do+ forM_ leftover $ \arg ->+ throwError $ "unrecognized subargument: " <> render arg+ pop_+ pure result+ _ -> do+ (_, result) <- parseSubargs []+ pure result++ activate (HelpOption info) = do+ -- Arguments should never be interpreted as options when escaped.+ getEscaped >>= guard . not++ (flag, mbound) <- peek >>= parseUnixOption+ guard $ flag `elem` optFlags info+ pop_++ withContext (UnixOption flag mbound)+ requestHelp++ activate (Command info subtree) = do+ -- Arguments should never be interpreted as commands when escaped.+ getEscaped >>= guard . not++ next <- peek+ guard $ next `elem` cmdNames info+ && not ("-" `T.isPrefixOf` next) -- not sure if this check is necessary?+ pop_++ withContext (UnixCommand next) $ do+ satiate subtree+ >>= resolveLifted++ usageInfo (Parameter tp) = render $ parserHint tp+ usageInfo (Command info subtree) =+ "{" <> render (cmdHead info) <> " " <> render subtree <> "}"+ usageInfo (Option info subtree) =+ render flag+ <> if nullary subtree+ then mempty+ else separator <> renderDelimitedIf braces isChoice subtree+ where flag = optHead info+ separator = case flag of+ LongFlag _ -> "="+ _ -> ""+ usageInfo (HelpOption info) =+ render (optHead info)++instance Render (Token UnixScheme) where+ render (UnixArgument s) = render s+ render (UnixCommand s) = render s+ render (UnixOption f Nothing) = render f+ render (UnixOption f@(LongFlag _) (Just v)) = render f <> "=" <> render v+ render (UnixOption f@(ShortFlag _) (Just v)) = render f <> render v++instance SupportsHelp UnixScheme where+ makeHelpInfo tree context name desc = renderText+ $ "Usage:\n"+ <> renderUsages tree <> "\n"+ <> render desc <> "\n"+ <> renderHelp tree context+ where+ renderUsageLine s = render name <> " " <> render s <> "\n"+ renderUsages = foldMap renderUsageLine . exhibitToList . separate++-- | Convenient type alias for Unix-flavored parse trees.+type UnixParser = ParseTree UnixScheme++--------------------------------------------------------------------------------+-- Help++-- | Automatically insert a help option at the top level of the tree+-- and every subcommand tree.+addHelpOptions+ :: NonEmpty Flag+ -> Text+ -> ParseTree UnixScheme r+ -> ParseTree UnixScheme r+addHelpOptions flags desc tree = ParseNode helpOption <|> go tree+ where+ helpOption :: UnixScheme a+ helpOption = HelpOption $ OptionInfo flags desc++ go :: ParseTree UnixScheme a -> ParseTree UnixScheme a+ go (ParseNode (Command info subtree)) =+ ParseNode+ $ Command info+ $ ParseNode helpOption <|> go subtree+ go (ProdNode f l r) = ProdNode f (go l) (go r)+ go (SumNode l r) = SumNode (go l) (go r)+ go (ManyNode require p) = ManyNode require (go p)+ go node = node++data OptionHelp = OptionHelp+ { colShorts :: TL.Text -- Column 1+ , colLongs :: TL.Text -- Column 2+ , colArg :: TL.Text -- Column 3+ , colDesc :: TL.Text -- Column 4+ } deriving (Eq, Ord, Show)++makeOptionHelp :: OptionInfo -> ParseTree SubScheme r -> OptionHelp+makeOptionHelp OptionInfo{..} subtree =+ OptionHelp+ { colLongs = fmtFlagList longs+ , colShorts = fmtFlagList shorts+ , colArg = if nullary subtree+ then mempty+ else renderLazyText subtree+ , colDesc = TL.fromStrict optHelp+ }+ where+ isLongFlag LongFlag{} = True+ isLongFlag _ = False+ (longs, shorts) = NonEmpty.partition isLongFlag optFlags+ fmtFlagList = TL.intercalate ", " . fmap renderLazyText++-- | Enumerate descriptive information for all options available in a+-- parse tree, indexed by the set of commands under which they exist.+collectOptions :: ParseTree UnixScheme r -> Map [CommandInfo] [OptionHelp]+collectOptions tree = go tree mempty+ where+ go :: ParseTree UnixScheme r+ -> Map [CommandInfo] [OptionHelp]+ -> Map [CommandInfo] [OptionHelp]+ go (ParseNode (Option info subtree)) =+ Map.insertWith (<>) [] [makeOptionHelp info subtree]+ go (ParseNode (Command info subtree)) =+ Map.union $ Map.mapKeys (info :) $ collectOptions subtree+ go (ProdNode _ l r) = go r . go l+ go (SumNode l r) = go r . go l+ go (ManyNode _ p) = go p+ go _ = id++renderOptionTable :: [OptionHelp] -> Builder+renderOptionTable xs = foldMap formatRow $ List.sort xs+ where+ maxLengthBy f = maximum $ TL.length . f <$> xs+ col1width = maxLengthBy colShorts+ col2width = maxLengthBy colLongs+ col3width = maxLengthBy colArg++ formatRow OptionHelp{..} =+ TLB.fromLazyText $ TL.intercalate " "+ [ TL.justifyLeft col1width ' ' colShorts+ , TL.justifyLeft col2width ' ' colLongs+ , TL.justifyLeft col3width ' ' colArg+ , colDesc+ , "\n"+ ]++renderHeader :: [CommandInfo] -> Builder+renderHeader [] = mempty+renderHeader cmds@(info : _) =+ fmtCommand cmds+ <> " command"+ <> aliasInfo+ <> ": "+ <> render (cmdHelp info)+ <> "\n"+ where+ quote m = "\"" <> m <> "\""+ fmtCommand = quote . render . T.unwords . fmap cmdHead . reverse+ aliases = NonEmpty.tail $ cmdNames info+ aliasInfo =+ if null aliases+ then mempty+ else " (alt: " <> render (T.intercalate ", " aliases) <> ")"++-- | Format an index of commands and options for help output display.+renderTables :: Map [CommandInfo] [OptionHelp] -> Builder+renderTables =+ Map.foldlWithKey+ (\acc cmds desc ->+ acc+ <> "\n"+ <> renderHeader cmds+ <> renderOptionTable desc+ ) mempty++-- | Select only the options tables which exist under a particular+-- command sequence.+selectSubtable+ :: [Text]+ -> Map [CommandInfo] [OptionHelp]+ -> Map [CommandInfo] [OptionHelp]+selectSubtable cmds =+ Map.filterWithKey (\infos _ -> isParentCommand cmds infos)++isParentCommand :: [Text] -> [CommandInfo] -> Bool+isParentCommand cmds =+ and . zipWith (\cmd info -> cmd `elem` cmdNames info) cmds++-- | Render formatted help information for all commands and options+-- that exist underneath the current command context.+renderHelp+ :: ParseTree UnixScheme r+ -> [Token UnixScheme] -- ^ Context Stack+ -> Builder+renderHelp tree contexts =+ renderTables+ $ selectSubtable commandContext+ $ collectOptions tree+ where+ commandContext = reverse [s | UnixCommand s <- contexts]
+ src/Mangrove/Separable.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE KindSignatures #-}++{-|+Module : Mangrove.Separable+Copyright : (c) Quytelda Kahja, 2026+License : BSD-3-Clause++Tools for decomposing parsers into different modal subparsers.+-}+module Mangrove.Separable+ ( Separable(..)+ , Modal(..)+ , usesTerseOutput+ , Exhibit(..)+ , exhibitToList+ ) where++import Data.Kind+import Data.Maybe++-- | A modal branch of a parser or parse tree is a particular subtree+-- that, when triggered, excludes the rest of the tree from receiving+-- input. This can happen because the parsing context changed (for+-- example, when a command is recognized) or when the parsing is+-- exited entirely (for example, when a help option is encountered).+data Modal a = Modal Bool a+ deriving (Functor)++instance Applicative Modal where+ pure = Modal False+ Modal terse1 f <*> Modal terse2 x = Modal (terse1 && terse2) (f x)++-- | Modal trees that exit the parsing flow entirely have no+-- opportunity to make use of optional parsers, since their values+-- will never be evaluated. Thus, we mark those trees as having+-- "terse" output so that we can omit the optional subtrees when+-- generating help information.+usesTerseOutput :: Modal a -> Bool+usesTerseOutput (Modal terseOutput _) = terseOutput++-- | An 'Exhibit' represents an object whose modal sub-components have+-- been split off for the purpose of better help output.+--+-- Every parser and parse tree can be decomposed into one regular tree+-- and a list of modal trees.+data Exhibit a = Exhibit (Maybe a) [Modal a]+ deriving (Functor)++-- | Convert an 'Exhibit' to a regular list of regular and modal+-- components.+exhibitToList :: Exhibit a -> [a]+exhibitToList (Exhibit mnorm modals) =+ maybeToList mnorm <> [t | Modal _ t <- modals]++-- | A 'Separable' parser is one that can be decomposed into regular+-- and modal subparsers.+--+-- We do this so that we can render usage information for each parser+-- mode separately. This makes the usage of complex commands+-- significantly easier to read.+--+-- NOTE: Decomposed subparsers are intended for display purposes+-- (hence the 'Exhibit' type). Trying to parse input with them is+-- likely to fail.+class Functor s => Separable (s :: Type -> Type) where+ separate :: s r -> Exhibit (s r)
+ src/Mangrove/Text.hs view
@@ -0,0 +1,107 @@+{-# 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
+ src/Mangrove/TextParser.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++{-|+Module : Mangrove.TextParser+Copyright : (c) Quytelda Kahja, 2026+License : BSD-3-Clause++Structures for parsing text input, along with some default parsers.+-}++module Mangrove.TextParser+ ( TextParser(..)+ , runTextParser+ , DefaultParser(..)+ ) where++import Control.Monad.Except+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy.Builder as TLB+import qualified Data.Text.Read as TR++import Mangrove.Text++-- | A 'TextParser' is the most atomic client-defined parsing unit. It+-- parses textual data that is not otherwise part of the parsing+-- scheme into the actual results that will be combined and returned+-- once parsing completes.+data TextParser r = TextParser+ { parserHint :: Text -- ^ A hint about the type of input this parser expects+ , parserRun :: Text -> Either Builder r -- ^ An actual parsing function+ } deriving (Functor)++-- | Lift a 'TextParser' into some 'MonadError'.+runTextParser :: MonadError Builder m => TextParser r -> Text -> m r+runTextParser tp = liftEither . parserRun tp++-- | A typeclass for types that have a convenient default+-- 'TextParser'.+class DefaultParser r where+ -- | A reasonable default TextParser implementation.+ defaultParser :: TextParser r++exactly :: TR.Reader a -> Text -> Either Builder a+exactly reader text =+ case reader text of+ Left err -> throwError $ TLB.fromString err+ Right (result, "") -> pure result+ Right (_, leftover) -> throwError $ "unexpected input: " <> render leftover++instance DefaultParser Bool where+ defaultParser = TextParser+ { parserHint = "BOOL"+ , parserRun = parse+ }+ where+ parse "true" = pure True+ parse "false" = pure False+ parse "yes" = pure True+ parse "no" = pure False+ parse _ = throwError "expected true|false|yes|no"++instance DefaultParser Int where+ defaultParser = TextParser+ { parserHint = "INT"+ , parserRun = exactly TR.decimal+ }++instance DefaultParser Integer where+ defaultParser = TextParser+ { parserHint = "INT"+ , parserRun = exactly TR.decimal+ }++instance DefaultParser Word where+ defaultParser = TextParser+ { parserHint = "INT"+ , parserRun = exactly TR.decimal+ }++instance DefaultParser Char where+ defaultParser = TextParser+ { parserHint = "CHAR"+ , parserRun = parse+ }+ where+ parse (T.unpack -> [c]) = pure c+ parse _ = throwError "input contains multiple characters"++instance DefaultParser Float where+ defaultParser = TextParser+ { parserHint = "FLOAT"+ , parserRun = exactly TR.rational+ }++instance DefaultParser Double where+ defaultParser = TextParser+ { parserHint = "DOUBLE"+ , parserRun = exactly TR.rational+ }++instance DefaultParser Text where+ defaultParser = TextParser+ { parserHint = "STRING"+ , parserRun = pure+ }++instance DefaultParser String where+ defaultParser = TextParser+ { parserHint = "STRING"+ , parserRun = pure . T.unpack+ }
+ src/Mangrove/Unix.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE GADTs #-}++{-|+Module : Mangrove.Unix+Copyright : (c) Quytelda Kahja, 2026+License : BSD-3-Clause++An API for defining, constructing, and running Unix-style command line+parsers.+-}++module Mangrove.Unix+ ( -- * Types+ UnixScheme+ , SubScheme+ , UnixParser+ , SubParser+ , Flag(..)+ , TextParser(..)+ , DefaultParser(..)++ -- * Tree-building Combinators+ , parameter+ , option+ , optionPure+ , switch+ , command+ , subparameter+ , suboption++ -- ** Help Options+ , addHelpOptions+ ) where++import Control.Applicative+import Data.List.NonEmpty (NonEmpty)+import Data.Text (Text)++import Mangrove.Parser+import Mangrove.Scheme.Sub (SubScheme, SubParser)+import qualified Mangrove.Scheme.Sub as Sub+import Mangrove.Scheme.Unix+import Mangrove.TextParser++--------------------------------------------------------------------------------+-- Tree-building Combinators++-- | Create a parameter parser from a 'TextParser'.+parameter+ :: TextParser r+ -> UnixParser r+parameter = ParseNode . Parameter++-- | Define a general CLI option.+option+ :: NonEmpty Flag+ -> Text+ -> SubParser r+ -> UnixParser r+option flags help = ParseNode . Option (OptionInfo flags help)++-- | Define a CLI option which takes no parameter and produces a pure value.+optionPure+ :: NonEmpty Flag+ -> Text+ -> a+ -> UnixParser a+optionPure flags help = ParseNode . Option (OptionInfo flags help) . pure++-- | Define a CLI option which produces 'True' if present and 'False'+-- otherwise.+switch :: NonEmpty Flag -> Text -> UnixParser Bool+switch flags help = optionPure flags help True <|> pure False++-- | Define a CLI subcommand with it's own parsing subtree.+command+ :: NonEmpty Text+ -> Text+ -> UnixParser r+ -> UnixParser r+command cmds help = ParseNode . Command (CommandInfo cmds help)++-- | Define a subparameter to a CLI option.+subparameter :: TextParser a -> SubParser a+subparameter = ParseNode . Sub.Parameter++-- | Define a suboption to a CLI option.+suboption :: Text -> TextParser a -> SubParser a+suboption key = ParseNode . Sub.Option key
+ src/Mangrove/Valency.hs view
@@ -0,0 +1,43 @@+{-|+Module : Mangrove.Valency+Copyright : (c) Quytelda Kahja, 2026+License : BSD-3-Clause++Typeclass and functions for reasoning about the number of arguments a+parser can consume.+-}++module Mangrove.Valency+ ( Valency(..)+ ) where++-- | Valency represents the maximum number of arguments a parsing+-- structure can consume.+--+-- If the valency of a parser is @Just n@, then it might consume up to+-- @n@ arguments. If the valency is 'Nothing', it can consume an+-- arbitrary number of arguments.+class Valency s where+ -- | Compute the maximum valency of a parser.+ valency :: s r -> Maybe Int++ -- | Test whether a parser has zero inputs.+ --+ -- This does NOT include trees that accept input optionally or trees+ -- that only accept impossible input.+ nullary :: s r -> Bool+ nullary s =+ case valency s of+ Just n -> n <= 0+ Nothing -> False++ -- | Multary parsers can consume more than one argument.+ --+ -- This does not exclude parsers that could potentially accept zero+ -- or one inputs, as long as the maximum number of inputs is greater+ -- than one.+ multary :: s r -> Bool+ multary s =+ case valency s of+ Just n -> n > 1+ Nothing -> True
+ test/General.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}++module General (spec) where++import Control.Applicative++import Test.Hspec++import Mangrove+import Mangrove.Text++import TestParsers++optionSpec :: Spec+optionSpec = do+ it "parses long options" $ do+ runHelpfulParser_ opt_example_unit ["--example"]+ `shouldBe` Success [] ()+ it "parses short options" $ do+ runHelpfulParser_ opt_e_unit ["-e"]+ `shouldBe` Success [] ()++ it "parses options in any order" $ do+ runHelpfulParser_ (opt_e_unit *> opt_f_unit) ["-e", "-f"]+ `shouldBe` Success [] ()+ runHelpfulParser_ (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"]+ `shouldBe` Success [] True+ context "when switch is absent" $ do+ it "yields False" $ do+ runHelpfulParser_ 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"]+ `shouldBe` Success [] "qwer"+ runHelpfulParser_ opt_e_param ["-eqwer"]+ `shouldBe` Success [] "qwer"+ context "when no argument is expected" $ do+ it "parsing fails" $ do+ runHelpfulParser_ opt_example_unit ["--example=qwer"]+ `shouldBe` Failure "--example=qwer: unrecognized subargument: qwer"+ runHelpfulParser_ 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"]+ `shouldBe` Success ["qwer"] ()++ context "when an argument is required" $ do+ it "renders with parameter hint" $ do+ render opt_example_param `shouldBe` "--example=STRING"+ render opt_e_param `shouldBe` "-eSTRING"++ context "when no argument is provided" $ do+ it "fails to parse" $ do+ runHelpfulParser_ 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"]+ `shouldBe` Success [] "qwer"++ context "when an argument is optional" $ do+ it "renders parameter hint in brackets" $ do+ render opt_example_param_optional `shouldBe` "--example=[STRING]"++ context "when no argument is provided" $ do+ it "yields a default value" $ do+ runHelpfulParser_ opt_example_param_optional ["--example"]+ `shouldBe` Success [] "asdf"+ it "does not consume subsequent options" $ do+ runHelpfulParser_ 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"]+ `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"]+ `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"]+ `shouldBe` Success [] "1,3"+ runHelpfulParser_ 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"]+ `shouldBe` Success [] "asdf"+ runHelpfulParser_ 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"]+ `shouldBe` Success [] "value=asdf"+ runHelpfulParser_ opt_example_param ["--example=value=asdf"]+ `shouldBe` Success [] "value=asdf"++ describe "help options" $ do+ let progInfo = ProgramInfo "example" "description"+ isHelpResult (Help _) = True+ isHelpResult _ = False++ context "when a help option is present" $ do+ it "requests help" $ do+ runHelpfulParser progInfo (withHelp opt_example_unit) ["--help"]+ `shouldSatisfy` isHelpResult+ it "works for subcommands" $ do+ runHelpfulParser progInfo (withHelp cmd_example_tree) ["example", "--help"]+ `shouldSatisfy` isHelpResult+ runHelpfulParser progInfo (withHelp cmd_example_tree) ["example", "asdf", "--help"]+ `shouldSatisfy` isHelpResult++ context "when a help option is absent" $ do+ it "doesn't request help" $ do+ runHelpfulParser_ (withHelp opt_example_unit) ["--example"]+ `shouldBe` Success [] ()+ runHelpfulParser_ (withHelp opt_example_unit) []+ `shouldBe` Failure "expected: --help or --example"+ it "isn't activated by escaped options" $ do+ runHelpfulParser_ (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 ["-"]+ `shouldBe` Success [] "-"++ context "when \"--\" is present in the argument list" $ do+ it "treats subsequent arguments as free arguments" $ do+ runHelpfulParser_ param_text ["--", "asdf"]+ `shouldBe` Success [] "asdf"+ it "doesn't treat subsequent arguments as options" $ do+ runHelpfulParser_ (option_asdf <|> param_text) ["--", "--asdf"]+ `shouldBe` Success [] "--asdf"+ it "doesn't treat subsequent arguments as commands" $ do+ runHelpfulParser_ (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 []+ `shouldBe` Failure "expected: STRING"++ context "when not all input can be consumed" $ do+ it "returns unconsumed arguments" $ do+ runHelpfulParser_ param_text ["asdf", "qwer"]+ `shouldBe` Success ["qwer"] "asdf"++spec :: Spec+spec = do+ describe "General functionality" generalSpec+ describe "CLI Options" optionSpec
+ test/Main.hs view
@@ -0,0 +1,11 @@+module Main (main) where++import qualified Spec+import Test.Hspec++import qualified General++main :: IO ()+main = hspec $ do+ General.spec+ Spec.spec
+ test/Mangrove/ParserSpec.hs view
@@ -0,0 +1,179 @@+{-# 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+ | SHelpReq+ deriving (Eq, Show)++-- | Sink the results of a 'StreamParser' into a data type for easier inspection.+runStreamParser'+ :: SupportsHelp 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)+ , onHelpRequest = OnHelp $ \s -> (s, SHelpReq)+ }++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` tail (streamContent initState_singleton)+ it "preserves the context" $ do+ streamContext initState_singleton `shouldBe` streamContext finalState
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}
+ test/TestParsers.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}++module TestParsers where++import Control.Applicative+import Data.Text (Text)++import Mangrove.Scheme.Unix+import Mangrove.TextParser+import Mangrove.Unix++opt_example_unit :: UnixParser ()+opt_example_unit = option [LongFlag "example"] "" $ pure ()++opt_e_unit :: UnixParser ()+opt_e_unit = option [ShortFlag 'e'] "" $ pure ()++opt_e_param :: UnixParser Text+opt_e_param = option [ShortFlag 'e'] "" $ subparameter defaultParser++opt_f_unit :: UnixParser ()+opt_f_unit = option [ShortFlag 'f'] "" $ pure ()++opt_example_param :: UnixParser Text+opt_example_param = option [LongFlag "example"] "" $ subparameter defaultParser++opt_example_switch :: UnixParser Bool+opt_example_switch = switch [LongFlag "example"] ""++opt_example_param_optional :: UnixParser Text+opt_example_param_optional =+ option [LongFlag "example"] ""+ $ subparameter defaultParser <|> pure "asdf"++param_text :: UnixParser Text+param_text = parameter defaultParser++option_asdf :: UnixParser Text+option_asdf = option ["--asdf", "-a"] "" $ pure "qwer"++command_asdf :: UnixParser Text+command_asdf = command ["asdf"] "" $ pure "qwer"++cmd_example_tree :: UnixParser Text+cmd_example_tree = command ["example"] "" $ command ["asdf"] "" $ pure "qwer"++opt_example_pair :: UnixParser (Int, Int)+opt_example_pair = option ["--example"] "" $ (,)+ <$> subparameter defaultParser+ <*> subparameter defaultParser++opt_example_subopt :: UnixParser Text+opt_example_subopt =+ option ["--example"] "" $ suboption "value" defaultParser++opt_home_create :: UnixParser (Text, Bool)+opt_home_create =+ option ["--home"] "Specify home directory and whether to create it" $ (,)+ <$> subparameter defaultParser+ <*> (suboption "create" defaultParser <|> pure False)++withHelp :: UnixParser r -> UnixParser r+withHelp = addHelpOptions ["--help"]+ "Display help and usage information"