diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,461 @@ +# Mangrove + +[![Unit Tests](https://github.com/quytelda/mangrove/actions/workflows/unit-tests.yml/badge.svg)](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 +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/mangrove-cli.cabal b/mangrove-cli.cabal new file mode 100644 --- /dev/null +++ b/mangrove-cli.cabal @@ -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 +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 diff --git a/src/Mangrove.hs b/src/Mangrove.hs new file mode 100644 --- /dev/null +++ b/src/Mangrove.hs @@ -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 + } diff --git a/src/Mangrove/Parser.hs b/src/Mangrove/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Mangrove/Parser.hs @@ -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 diff --git a/src/Mangrove/Resolve.hs b/src/Mangrove/Resolve.hs new file mode 100644 --- /dev/null +++ b/src/Mangrove/Resolve.hs @@ -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 diff --git a/src/Mangrove/Scheme/Sub.hs b/src/Mangrove/Scheme/Sub.hs new file mode 100644 --- /dev/null +++ b/src/Mangrove/Scheme/Sub.hs @@ -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 diff --git a/src/Mangrove/Scheme/Unix.hs b/src/Mangrove/Scheme/Unix.hs new file mode 100644 --- /dev/null +++ b/src/Mangrove/Scheme/Unix.hs @@ -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] diff --git a/src/Mangrove/Separable.hs b/src/Mangrove/Separable.hs new file mode 100644 --- /dev/null +++ b/src/Mangrove/Separable.hs @@ -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) diff --git a/src/Mangrove/Text.hs b/src/Mangrove/Text.hs new file mode 100644 --- /dev/null +++ b/src/Mangrove/Text.hs @@ -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 diff --git a/src/Mangrove/TextParser.hs b/src/Mangrove/TextParser.hs new file mode 100644 --- /dev/null +++ b/src/Mangrove/TextParser.hs @@ -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 + } diff --git a/src/Mangrove/Unix.hs b/src/Mangrove/Unix.hs new file mode 100644 --- /dev/null +++ b/src/Mangrove/Unix.hs @@ -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 diff --git a/src/Mangrove/Valency.hs b/src/Mangrove/Valency.hs new file mode 100644 --- /dev/null +++ b/src/Mangrove/Valency.hs @@ -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 diff --git a/test/General.hs b/test/General.hs new file mode 100644 --- /dev/null +++ b/test/General.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 diff --git a/test/Mangrove/ParserSpec.hs b/test/Mangrove/ParserSpec.hs new file mode 100644 --- /dev/null +++ b/test/Mangrove/ParserSpec.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} diff --git a/test/TestParsers.hs b/test/TestParsers.hs new file mode 100644 --- /dev/null +++ b/test/TestParsers.hs @@ -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"