diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,30 @@ ## Unreleased +## 0.4.0.0 - 2026-09-13 + +### Added + +- Show instances for data structures related to parser trees +- A TextParser for paths (FilePath) +- 'Request' type family associated with Scheme class +- Property based tests using QuickCheck + +### Changed + +- Split Mangrove.Parser module back into several modules (ParseTree, + Scheme, Stream, Token) +- Move the contents of Mangrove module to Mangrove.Parser, then + re-export them from the Mangrove module +- Parameterize the StreamParser monad by request type +- Drop phantom type parameter from ProgramInfo + +### Removed + +- usageInfo method of Scheme class +- HelpContinuation family +- HelpHandler type alias + ## 0.3.0.0 - 2026-08-27 ### Added diff --git a/mangrove-cli.cabal b/mangrove-cli.cabal --- a/mangrove-cli.cabal +++ b/mangrove-cli.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: mangrove-cli -version: 0.3.0.0 +version: 0.4.0.0 synopsis: Build CLI argument parsers using Applicative. description: Please see the README on GitHub at category: CLI, Options, Parsing @@ -17,7 +17,7 @@ license: BSD-3-Clause license-file: LICENSE build-type: Simple -extra-source-files: +extra-doc-files: README.md CHANGELOG.md @@ -29,11 +29,16 @@ exposed-modules: Mangrove Mangrove.Parser + Mangrove.ParseTree + Mangrove.Render Mangrove.Resolve + Mangrove.Scheme + Mangrove.Scheme.Common Mangrove.Scheme.Sub Mangrove.Scheme.Unix - Mangrove.Text + Mangrove.Stream Mangrove.TextParser + Mangrove.Token Mangrove.Unix Mangrove.Valency other-modules: @@ -55,9 +60,13 @@ type: exitcode-stdio-1.0 main-is: Main.hs other-modules: + Arbitrary General - Mangrove.ParserSpec + Mangrove.ParseTreeSpec + Mangrove.StreamSpec + Mangrove.Test.Stream Spec + StructureEq TestParsers Paths_mangrove_cli autogen-modules: @@ -68,11 +77,14 @@ build-tool-depends: hspec-discover:hspec-discover >=2.8.5 && <3 build-depends: - base >=4.7 && <5 + QuickCheck >=2.14.2 && <2.18 + , base >=4.7 && <5 , containers >=0.6.4 && <0.9 , hspec >=2.8.5 && <3 , mangrove-cli , mtl >=2.2.2 && <2.4 + , quickcheck-instances >=0.3.28 && <0.5 + , random >=1.2.1.1 && <1.3 , text >=1.2.5 && <2.2 , transformers >=0.5.6 && <0.7 default-language: Haskell2010 diff --git a/src/Mangrove.hs b/src/Mangrove.hs --- a/src/Mangrove.hs +++ b/src/Mangrove.hs @@ -1,200 +1,24 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeOperators #-} - {-| Module : Mangrove Copyright : (c) Quytelda Kahja, 2026 License : BSD-3-Clause -This module contains types and functions necessary for running -argument parsers. +This module exports the full API required for running any generic +parser. For constructing parsers, you'll need to import the building +blocks for the specific kind of parser you are building. For example, +"Mangrove.Unix" contains the tools for building UNIX-style parsers. -} module Mangrove - ( -- * Standard Interface - parseArguments + ( module Mangrove.Parser - -- * Types - , ProgramInfo(..) + -- * Re-exported Types , ParseTree , Scheme - , Result(..) - , SupportsResponse + , ProgramInfo(..) , StreamState - , RequestType(..) - , RequestHandler - , ReqContinuation(..) - - -- * Pure Interface - -- ** Helpful Parsers - , runHelpfulParser - , runHelpfulParser' - , runHelpfulParser_ - - -- ** Silent Parsers - , runSilentParser - , runSilentParser' - - -- ** General Parsers (CPS) - , runArgumentParser - , runArgumentParser' ) where -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as TIO -import System.Environment -import System.Exit -import System.IO - import Mangrove.Parser -import Mangrove.Resolve -import Mangrove.Text - --- | The results of a parsing operation. --- --- Only parsing schemes that support generating responses can use the --- 'Response' constructor. -data Result s r where - -- | A successful parsing operation yields a list of leftover - -- arguments and a result value. - Success :: ![Text] -> !r -> Result s r - -- | A failed parsing operation yields an error message. - Failure :: !Text -> Result s r - -- | A request for information yields a human-readable response (for - -- parsers that support it). - Response :: SupportsResponse s => !Text -> Result s r - -deriving instance Show r => Show (Result s r) -deriving instance Eq r => Eq (Result s r) - --- | Create a default initial t'StreamState' from a list of arguments. -argsToState :: [Text] -> StreamState s -argsToState args = StreamState args [] False - --- | Attempt to parse a value of type @r@ from a list of arguments, --- where the parser @ParseTree s r@ doesn't support requests. -runSilentParser - :: (Scheme s, RequestSupport s ~ 'False) - => ParseTree s r -- ^ Argument parser - -> [Text] -- ^ Input arguments - -> Result s r -runSilentParser tree = runSilentParser' tree . argsToState - --- | A more general form of 'runSilentParser' that accepts a custom --- stream starting state. -runSilentParser' - :: (Scheme s, RequestSupport s ~ 'False) - => ParseTree s r -- ^ Argument parser - -> StreamState s -- ^ Initial stream state - -> Result s r -runSilentParser' tree state = - runArgumentParser' tree state Success Failure NoRequests - --- | Attempt to parse a value of type @r@ from a list of arguments, --- where the parser @ParseTree s r@ supports requests. -runHelpfulParser - :: SupportsResponse s - => ProgramInfo s -- ^ Program metadata - -> ParseTree s r -- ^ Argument parser - -> [Text] -- ^ Input arguments - -> Result s r -runHelpfulParser info tree = runHelpfulParser' info tree . argsToState - --- | A more general form of 'runHelpfulParser' that accepts a custom --- stream starting state. -runHelpfulParser' - :: SupportsResponse s - => ProgramInfo s -- ^ Program metadata - -> ParseTree s r -- ^ Argument parser - -> StreamState s -- ^ Initial stream state - -> Result s r -runHelpfulParser' info tree state = - runArgumentParser' tree state Success Failure (OnRequest _onRequest) - where - _onRequest state' HelpRequest = - Response $ makeHelpInfo tree (streamContext state') info - _onRequest _ VersionRequest = - Response $ makeVersionInfo info - --- | A variant of 'runHelpfulParser' that treats requests as failures. --- --- This is useful if you know that no requests will ever be made. -runHelpfulParser_ - :: SupportsResponse s - => ParseTree s r -- ^ Argument parser - -> [Text] -- ^ Input arguments - -> Result s r -runHelpfulParser_ tree args = - runArgumentParser' tree (argsToState args) Success Failure (OnRequest _onRequest) - where - _onRequest state' _ = Failure $ - formatError (streamContext state') "help requested" - --- | Parse the command line arguments passed to the program, then --- invoke the program's entrypoint with the results of the parsing. If --- parsing fails, we instead display an error to stderr and exit. --- Alternatively, if information was requested, we abandon parsing and --- print the relevant response to stdout, then exit without indicating --- an error. -parseArguments - :: SupportsResponse s - => ProgramInfo s -- ^ Program metadata - -> ParseTree s r -- ^ Argument parser - -> (r -> IO a) -- ^ Program Entrypoint - -> IO a -parseArguments info tree action = do - args <- map T.pack <$> getArgs - case runHelpfulParser info tree args of - Success [] result -> action result - Success (token:_) _ -> do - hPutBuilder stderr $ "unexpected " <> render token <> "\n" - exitFailure - Failure err -> do - TIO.hPutStrLn stderr err - exitFailure - Response output -> do - TIO.putStr output - exitSuccess - --- | Satiate a 'ParseTree' with all the input it can consume, then --- attempt to evaluate it. -runArgumentParser - :: Scheme s - => ParseTree s r -- ^ Argument parser - -> [Text] -- ^ Input arguments - -> ([Text] -> r -> a) -- ^ Success handler - -> (Text -> a) -- ^ Failure handler - -> RequestHandler s a -- ^ Request handler - -> a -runArgumentParser tree = runArgumentParser' tree . argsToState - --- | A more general form of 'runArgumentParser' that accepts a custom --- stream starting state. -runArgumentParser' - :: Scheme s - => ParseTree s r -- ^ Argument parser - -> StreamState s -- ^ Initial stream state - -> ([Text] -> r -> a) -- ^ Success handler - -> (Text -> a) -- ^ Failure handler - -> RequestHandler s a -- ^ Request handler - -> a -runArgumentParser' tree state cok cerr hhelp = - runStreamParser (satiate tree) handler state - where - _onFailure state' = cerr . formatError (streamContext state') - _onSuccess state' tree' = - case (streamContent state', resolve tree') of - (leftovers, Value result) -> cok leftovers result - ([], EmptyError) -> _onFailure state' "empty" - ([], ExpectedError es) -> _onFailure state' $ renderExpectedError es - (token:_, _) -> _onFailure state' $ "unexpected " <> render token - handler = StreamHandler - { onSuccess = _onSuccess - , onFailure = _onFailure - , onEmpty = flip _onFailure "empty" - , onRequest = hhelp - } +import Mangrove.ParseTree +import Mangrove.Scheme +import Mangrove.Stream diff --git a/src/Mangrove/ParseTree.hs b/src/Mangrove/ParseTree.hs new file mode 100644 --- /dev/null +++ b/src/Mangrove/ParseTree.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +{-| +Module : Mangrove.ParseTree +Copyright : (c) Quytelda Kahja, 2026 +License : BSD-3-Clause + +A 'ParseTree' is a tree-shaped parser that "filter-feeds" on a stream +of arguments, collecting inputs at the leaves and feeding the results +up the tree for processing. 'ParseTree's are parameterized by the +parser scheme that determines the kind of inputs it accepts. +-} + +module Mangrove.ParseTree + ( -- * Parse Trees + ParseTree(..) + , isProduct + , isSum + , isOptional + , isChoice + ) where + +import Control.Applicative +import Data.Kind +import Data.Proxy + +import Mangrove.Render +import Mangrove.Resolve +import Mangrove.Token +import Mangrove.Valency + +-- | `ParseTree scheme r` is an expression tree composed of parsers +-- from scheme @scheme@ which evaluates to a value of type @r@ when +-- supplied with the proper input. +data ParseTree (scheme :: Type -> Type) (r :: Type) where + -- | Terminal node with no value (abstracts 'empty') + EmptyNode :: ParseTree scheme r + -- | A terminal node with a resolved value (abstracts 'pure') + ValueNode :: !r -> ParseTree scheme r + -- | A parser awaiting input + ParseNode :: scheme r -> ParseTree scheme r + -- | Abstracts 'liftA2' and by extension '(<*>)' + ProdNode :: !(u -> v -> r) -> ParseTree scheme u -> ParseTree scheme v -> ParseTree scheme r + -- | Abstracts '(<|>)' + SumNode :: ParseTree scheme r -> ParseTree scheme r -> ParseTree scheme r + -- | Abstracts 'many' (@MaybeNode False@) and 'some' (@MaybeNode True@) + ManyNode :: !Bool -> ParseTree scheme r -> ParseTree scheme [r] + +instance (forall a. Show (s a)) => Show (ParseTree s r) where + showsPrec _ EmptyNode = showString "EmptyNode" + showsPrec p (ValueNode _) = + showParen (p >= 10) + $ showString "ValueNode _" + showsPrec p (ParseNode s) = + showParen (p >= 10) + $ showString "ParseNode " + . showsPrec 11 s + showsPrec p (ProdNode _ l r) = + showParen (p >= 10) + $ showString "ProdNode _ " + . showsPrec 11 l + . showString " " + . showsPrec 11 r + showsPrec p (SumNode l r) = + showParen (p >= 10) + $ showString "SumNode " + . showsPrec 11 l + . showString " " + . showsPrec 11 r + showsPrec p (ManyNode b t) = + showParen (p >= 10) + $ showString "ManyNode " + . showsPrec 11 b + . showString " " + . showsPrec 11 t + +instance Functor p => Functor (ParseTree p) where + fmap _ EmptyNode = EmptyNode + fmap f (ValueNode value) = ValueNode $ f value + fmap f (ParseNode parser) = ParseNode $ fmap f parser + fmap f (ProdNode g l r) = ProdNode (\u v -> f $ g u v) l r + fmap f (SumNode l r) = SumNode (fmap f l) (fmap f r) + fmap f node = ProdNode ($) (pure f) node + -- This takes advantage of the fact that f <$> x = pure f <*> x. + +instance Functor p => Applicative (ParseTree p) where + pure = ValueNode + liftA2 = ProdNode + +instance Functor p => Alternative (ParseTree p) where + empty = EmptyNode + (<|>) = SumNode + many = ManyNode False + some = ManyNode True + +instance Valency s => Valency (ParseTree s) where + valency EmptyNode = Just 0 + valency (ValueNode _) = Just 0 + valency (ParseNode p) = valency p + valency (ProdNode _ l r) = (+) <$> valency l <*> valency r + valency (SumNode l r) = max <$> valency l <*> valency r + valency (ManyNode _ tree) = + case valency tree of + Just n | n <= 0 -> Just 0 + _ -> Nothing -- i.e. infinity + -- In the above case of 'ManyNode _ p', a ManyNode can accept an + -- arbitrary number of parameters, so the maximum valency is either + -- infinite or zero depending on whether the valency of 'p' is zero. + + -- Since ParseTrees themselves don't accept inputs, we can provide a + -- slightly more efficient implementation of nullary. + nullary EmptyNode = True + nullary (ValueNode _) = True + nullary (ParseNode p) = nullary p + nullary (ProdNode _ l r) = nullary l && nullary r + nullary (SumNode l r) = nullary l && nullary r + nullary (ManyNode _ tree) = nullary tree + +instance Resolve s => Resolve (ParseTree s) where + resolve EmptyNode = EmptyError + resolve (ValueNode value) = pure value + resolve (ParseNode parser) = resolve parser + resolve (ProdNode f l r) = f <$> resolve l <*> resolve r + resolve (SumNode l r) = resolve l <|> resolve r + resolve (ManyNode False _) = pure [] + resolve (ManyNode True p) = pure <$> resolve p + -- NOTE: If a ManyNode contains a resolvable node, one might expect + -- the result to be an infinite list (e.g. `resolve $ many + -- (ValueNode 1)` to give `Right [1,1,1,1,..]`) or for the + -- computation to diverge (as is the case for `many (Just 1)`). + -- However, by only attempting at most resolutions of the subtree, + -- we will get either zero or one results. For example, `resolve $ + -- many (ValueNode 1)` will give `Right []`. + -- + -- Whether this is the best possible way to handle the situation is + -- unclear. This avoids infinite loops, but might not be the + -- expected behavior in some unforseen use-case. + +-- | Is this a 'ProdNode'? +isProduct :: ParseTree s r -> Bool +isProduct (ProdNode {}) = True +isProduct _ = False + +-- | Is this a 'SumNode'? +isSum :: ParseTree s r -> Bool +isSum (SumNode {}) = True +isSum _ = False + +-- | Does this subtree accept optional input? +isOptional :: Valency s => ParseTree s r -> Bool +isOptional (SumNode l (ValueNode _)) = not $ nullary l +isOptional (ManyNode False p) = not $ nullary p +isOptional _ = False + +-- | Is this a 'SumNode' a choice between two different (non-empty) +-- inputs? +isChoice :: Valency s => ParseTree s r -> Bool +isChoice (SumNode l r) = not (nullary l) && not (nullary r) +isChoice _ = False + +instance (Valency s, HasTokens s, forall a. Render (s a)) => Render (ParseTree s r) where + -- special cases + render n@(SumNode l _) + | isOptional n = renderDelimitedIf brackets (not . isOptional) l + + render (ParseNode parser) = render parser + render (ProdNode _ l r) + | nullary l && nullary r = "" + | nullary l = _render r + | nullary r = _render l + | otherwise = _render l <> render sep <> _render r + where + _render = renderDelimitedIf braces isChoice + sep = delimiter (Proxy @s) + render (SumNode l r) + | nullary l && nullary r = "" + | nullary l = _render r + | nullary r = _render l + | otherwise = _render l <> "|" <> _render r + where + _render = renderDelimitedIf braces isProduct + render (ManyNode required p) = wrap $ render p <> "..." + where + wrap = if required + then braces + else brackets + + -- Constant nodes that don't accept input have no usage. + render _ = "" diff --git a/src/Mangrove/Parser.hs b/src/Mangrove/Parser.hs --- a/src/Mangrove/Parser.hs +++ b/src/Mangrove/Parser.hs @@ -1,483 +1,60 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolymorphicComponents #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE TypeFamilies #-} {-| Module : Mangrove.Parser Copyright : (c) Quytelda Kahja, 2026 License : BSD-3-Clause -This module contains the data types and type classes that make up a -generic argument parser, as well as a stream parsing monad in which -parsing takes place. - -A 'ParseTree' is a tree-shaped parser that "filter-feeds" on a stream -of arguments, collecting inputs at the leaves and feeding the results -up the tree for processing. 'ParseTree's are parameterized by the -parser scheme that determines the kind of inputs it accepts. +This module contains types and functions necessary for running +argument parsers. These functions are generic across different parsing +schemes. -A "scheme" is a system of parsers and tokens. It determines the method -by which argument strings are separated. It parses a sequence of -arguments into tokens and values. +Most clients won't import this module directly, since its contents are +re-exported by the "Mangrove" module alongside other helpful symbols. -} module Mangrove.Parser - ( -- * Parse Trees - ParseTree(..) - , isProduct - , isSum - , isOptional - , isChoice - - -- ** Feeding Trees - , satiate - - -- * Parsing Schemes - , Scheme(..) - , ProgramInfo(..) - , SupportsResponse(..) - - -- * Stream Parser - , StreamParser(..) - , StreamHandler(..) - , StreamState(..) - , RequestHandler - , ReqContinuation(..) - - -- ** Requests - , RequestType(..) - , request - - -- ** Escaping - , setEscaped - , getEscaped + ( -- * Standard Interface + parseArguments - -- ** Context - , getContext - , setContext - , withContext - , formatError + -- * Pure Interface + , Result(..) + , runArgumentParser + , runArgumentParser' - -- ** Streaming - , popMaybe - , peekMaybe - , pop - , peek - , push - , pop_ + -- * Feeding Parser Trees + , satiate ) where import Control.Applicative -import Control.Monad.Except -import Data.Kind -import qualified Data.List as List -import Data.Proxy -import Data.Text (Text) -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Builder as TLB -import Data.Version +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import System.Environment +import System.Exit +import System.IO +import Mangrove.ParseTree +import Mangrove.Render import Mangrove.Resolve -import Mangrove.Text -import Mangrove.Valency - --------------------------------------------------------------------------------- --- Parse Trees - --- | `ParseTree scheme r` is an expression tree composed of parsers --- from scheme @scheme@ which evaluates to a value of type @r@ when --- supplied with the proper input. -data ParseTree (scheme :: Type -> Type) (r :: Type) where - -- | Terminal node with no value (abstracts 'empty') - EmptyNode :: ParseTree scheme r - -- | A terminal node with a resolved value (abstracts 'pure') - ValueNode :: !r -> ParseTree scheme r - -- | A parser awaiting input - ParseNode :: scheme r -> ParseTree scheme r - -- | Abstracts 'liftA2' and by extension '(<*>)' - ProdNode :: !(u -> v -> r) -> ParseTree scheme u -> ParseTree scheme v -> ParseTree scheme r - -- | Abstracts '(<|>)' - SumNode :: ParseTree scheme r -> ParseTree scheme r -> ParseTree scheme r - -- | Abstracts 'many' (@MaybeNode False@) and 'some' (@MaybeNode True@) - ManyNode :: !Bool -> ParseTree scheme r -> ParseTree scheme [r] - -instance Functor p => Functor (ParseTree p) where - fmap _ EmptyNode = EmptyNode - fmap f (ValueNode value) = ValueNode $ f value - fmap f (ParseNode parser) = ParseNode $ fmap f parser - fmap f (ProdNode g l r) = ProdNode (\u v -> f $ g u v) l r - fmap f (SumNode l r) = SumNode (fmap f l) (fmap f r) - fmap f node = ProdNode ($) (pure f) node - -- This takes advantage of the fact that f <$> x = pure f <*> x. - -instance Functor p => Applicative (ParseTree p) where - pure = ValueNode - liftA2 = ProdNode - -instance Functor p => Alternative (ParseTree p) where - empty = EmptyNode - (<|>) = SumNode - many = ManyNode False - some = ManyNode True - -instance Valency s => Valency (ParseTree s) where - valency EmptyNode = Just 0 - valency (ValueNode _) = Just 0 - valency (ParseNode p) = valency p - valency (ProdNode _ l r) = (+) <$> valency l <*> valency r - valency (SumNode l r) = max <$> valency l <*> valency r - valency (ManyNode _ tree) = - case valency tree of - Just n | n <= 0 -> Just 0 - _ -> Nothing -- i.e. infinity - -- In the above case of 'ManyNode _ p', a ManyNode can accept an - -- arbitrary number of parameters, so the maximum valency is either - -- infinite or zero depending on whether the valency of 'p' is zero. - - -- Since ParseTrees themselves don't accept inputs, we can provide a - -- slightly more efficient implementation of nullary. - nullary EmptyNode = True - nullary (ValueNode _) = True - nullary (ParseNode p) = nullary p - nullary (ProdNode _ l r) = nullary l && nullary r - nullary (SumNode l r) = nullary l && nullary r - nullary (ManyNode _ tree) = nullary tree - -instance Resolve s => Resolve (ParseTree s) where - resolve EmptyNode = EmptyError - resolve (ValueNode value) = pure value - resolve (ParseNode parser) = resolve parser - resolve (ProdNode f l r) = f <$> resolve l <*> resolve r - resolve (SumNode l r) = resolve l <|> resolve r - resolve (ManyNode False _) = pure [] - resolve (ManyNode True p) = pure <$> resolve p - -- NOTE: If a ManyNode contains a resolvable node, one might expect - -- the result to be an infinite list (e.g. `resolve $ many - -- (ValueNode 1)` to give `Right [1,1,1,1,..]`) or for the - -- computation to diverge (as is the case for `many (Just 1)`). - -- However, by only attempting at most resolutions of the subtree, - -- we will get either zero or one results. For example, `resolve $ - -- many (ValueNode 1)` will give `Right []`. - -- - -- Whether this is the best possible way to handle the situation is - -- unclear. This avoids infinite loops, but might not be the - -- expected behavior in some unforseen use-case. - --- | Is this a 'ProdNode'? -isProduct :: ParseTree s r -> Bool -isProduct (ProdNode {}) = True -isProduct _ = False - --- | Is this a 'SumNode'? -isSum :: ParseTree s r -> Bool -isSum (SumNode {}) = True -isSum _ = False - --- | Does this subtree accept optional input? -isOptional :: Valency s => ParseTree s r -> Bool -isOptional (SumNode l (ValueNode _)) = not $ nullary l -isOptional (ManyNode False p) = not $ nullary p -isOptional _ = False - --- | Is this a 'SumNode' a choice between two different (non-empty) --- inputs? -isChoice :: Valency s => ParseTree s r -> Bool -isChoice (SumNode l r) = not (nullary l) && not (nullary r) -isChoice _ = False - -instance (Valency s, Scheme s) => Render (ParseTree s r) where - -- special cases - render n@(SumNode l _) - | isOptional n = renderDelimitedIf brackets (not . isOptional) l - - render (ParseNode parser) = usageInfo parser - render (ProdNode _ l r) - | nullary l && nullary r = "" - | nullary l = _render r - | nullary r = _render l - | otherwise = _render l <> render sep <> _render r - where - _render = renderDelimitedIf braces isChoice - sep = delimiter (Proxy @s) - render (SumNode l r) - | nullary l && nullary r = "" - | nullary l = _render r - | nullary r = _render l - | otherwise = _render l <> "|" <> _render r - where - _render = renderDelimitedIf braces isProduct - render (ManyNode required p) = wrap $ render p <> "..." - where - wrap = if required - then braces - else brackets - - -- Constant nodes that don't accept input have no usage. - render _ = "" - --------------------------------------------------------------------------------- --- Parsing Schemes - --- | A scheme is a system of parsers and tokens. It parses a sequence --- of arguments into tokens and values. -class (Functor s, Resolve s, Eq (Token s), Render (Token s), Show (Token s)) => Scheme (s :: Type -> Type) where - -- | A token represents a particular interpretation of an argument - -- string under this parsing scheme. - data Token s - - -- | This type indicates whether a parsing scheme accepts requests - -- for information. - -- - -- When @RequestSupport scheme@ is @True@, a 'SupportsResponse' - -- instance should be provided for @scheme@. - type RequestSupport s :: Bool - type RequestSupport s = 'False - - -- | 'delimiter' is the character that separates argument strings in - -- combined string representation. For example, arguments in the CLI - -- command @ls -a -l /var@ are separated by spaces. - delimiter :: Proxy s -> Char - - -- | Parse special control arguments that don't represent tokens in - -- the scheme, but control aspects of how parsing proceeds (e.g. - -- escaping). - parseSpecials :: StreamParser s () - parseSpecials = pure () - - -- | 'activate' tries to run a parser on the current input. If the - -- parser doesn't apply, it consumes nothing and returns empty. If - -- it does apply, it consumes the relevant input and returns a - -- result. - activate :: s r -> StreamParser s r - - -- | Render human-readable usage information for a particular - -- parser. - usageInfo :: s r -> Builder - --- | Program metadata for displaying help output. -data ProgramInfo (s :: Type -> Type) = ProgramInfo - { programName :: !Text -- ^ The program name - , programVersion :: !Version -- ^ The program version - , programDesc :: !Text -- ^ A description of the program - } deriving (Show) - --- | A class for schemes that support human-readable responses to --- requests for help or version information. -class (Scheme s, RequestSupport s ~ 'True) => SupportsResponse s where - makeVersionInfo :: ProgramInfo s -> Text - makeHelpInfo :: ParseTree s r -> [Token s] -> ProgramInfo s -> Text - --------------------------------------------------------------------------------- --- Stream Parser - --- | The current state of a stream parser. --- --- The content of a stream is just a list of 'Text' values. The --- context stack is a list of tokens currently being processed; when a --- token is recognized, it gets added to front of the list while the --- token is being parsed into a usable value. When this parsing --- completes, the token is popped from the front of the list. --- --- A streams can also enable "escaped" mode by setting 'streamEscaped' --- to 'True'. What this actually does is parser-dependant, but usually --- it restricts how subsequent arguments can be interpreted. For --- example, in the Unix scheme, escaping forces all subsequent --- arguments to be interpreted as positional arguments, even if they --- would normally be interpreted as options or commands. -data StreamState s = StreamState - { streamContent :: ![Text] -- ^ A sequence of 'Text' values - , streamContext :: ![Token s] -- ^ A stack representing current parsing context - , streamEscaped :: !Bool -- ^ Escaped mode - } - -deriving instance Scheme s => Show (StreamState s) -deriving instance Scheme s => Eq (StreamState s) - --- | What information is being requested? -data RequestType - = VersionRequest -- ^ A request for version information - | HelpRequest -- ^ A request for help and usage information - deriving (Eq, Show) - --- | A handler for when information is requested. --- --- This will hold a continuation function for helpful parsing --- schemes, or a placeholder value for silent schemes. -data family ReqContinuation (cap :: Bool) (s :: Type -> Type) r - -data instance ReqContinuation 'False s r - = NoRequests - deriving (Functor) - -newtype instance ReqContinuation 'True s r - = OnRequest (StreamState s -> RequestType -> r) - deriving (Functor) - --- | A handler for when information is requested. --- --- This will hold a continuation function for helpful parsing --- schemes, or a placeholder value for silent schemes. -type RequestHandler s r = ReqContinuation (RequestSupport s) s r - --- | A collection of continuations to be called for each situation a --- stream parser might encounter. -data StreamHandler s a r = StreamHandler - { onSuccess :: StreamState s -> a -> r -- ^ Success Continuation - , onEmpty :: StreamState s -> r -- ^ Empty continuation - , onFailure :: StreamState s -> Builder -> r -- ^ Failure Continuation - , onRequest :: RequestHandler s r -- ^ Request Continuation - } - --- | The amazing stream parsing monad! This monad tracks the stream --- state and context. It short-circuits when exceptions or requests --- are raised. -newtype StreamParser s a = StreamParser - { runStreamParser - :: forall r. StreamHandler s a r - -> StreamState s - -> r - } - -instance Functor (StreamParser s) where - fmap f parser = StreamParser $ \handler -> - runStreamParser parser handler { onSuccess = \s -> onSuccess handler s . f } - -instance Applicative (StreamParser s) where - pure a = StreamParser $ \handler state -> onSuccess handler state a - mf <*> ma = StreamParser $ \handler -> - runStreamParser mf - handler { onSuccess = \s f -> runStreamParser ma handler { onSuccess = \s' -> onSuccess handler s' . f } s } - -instance Alternative (StreamParser s) where - empty = StreamParser $ \handler -> onEmpty handler - l <|> r = StreamParser $ \handler -> - runStreamParser l handler { onEmpty = runStreamParser r handler } - -instance Monad (StreamParser s) where - return = pure - ma >>= f = StreamParser $ \handler -> - runStreamParser ma handler { onSuccess = \s a -> runStreamParser (f a) handler s } - -instance MonadError Builder (StreamParser s) where - throwError err = StreamParser $ \handler state -> onFailure handler state err - catchError ma recover = StreamParser $ \handler state -> - runStreamParser ma - handler { onFailure = \_ err -> runStreamParser (recover err) handler state } - state - --- | Enable or disable escaped parsing. What this actually does is --- parser-dependant, but usually it restricts how subsequent arguments --- can be interpreted. For example, in the Unix scheme, escaping --- forces all subsequent arguments to be interpreted as positional --- arguments, even if they would normally be interpreted as options or --- commands. -setEscaped :: Bool -> StreamParser s () -setEscaped b = StreamParser $ \handler state -> - onSuccess handler state { streamEscaped = b } () - --- | Check whether escaped parsing is enabled. -getEscaped :: StreamParser s Bool -getEscaped = StreamParser $ \handler state -> - onSuccess handler state (streamEscaped state) - --- | Signal that information is requested. Short-circuits any further --- operations. -request :: RequestSupport s ~ 'True => RequestType -> StreamParser s a -request requestType = StreamParser $ \handler state -> - case onRequest handler of - OnRequest h -> h state requestType - --- | Get a list representing the current context stack. -getContext :: StreamParser s [Token s] -getContext = StreamParser $ \handler state -> - onSuccess handler state (streamContext state) - --- | Replace the context stack. -setContext :: [Token s] -> StreamParser s () -setContext contexts = StreamParser $ \handler state -> - onSuccess handler state { streamContext = contexts } () - --- | Push the provided token onto the context stack, then perform some --- computation. Afterwards, the stack is restored to its prior state. -withContext :: Token s -> StreamParser s a -> StreamParser s a -withContext context action = do - oldContext <- getContext - setContext $ context : oldContext - action <* setContext oldContext - --- | Format an error message with context information. -formatError :: Render tok => [tok] -> Builder -> Text -formatError contexts err = - TL.toStrict - $ TLB.toLazyText - $ mconcat - $ List.intersperse ": " - $ reverse - $ err : map render contexts - --------------------------------------------------------------------------------- - --- | Remove and return the first token in the stream. -popMaybe :: StreamParser s (Maybe Text) -popMaybe = StreamParser $ \handler state -> - case streamContent state of - (t:ts') -> onSuccess handler state { streamContent = ts' } (Just t) - _ -> onSuccess handler state Nothing - --- | View the first token in the stream without consuming it. -peekMaybe :: StreamParser s (Maybe Text) -peekMaybe = StreamParser $ \handler state -> - case streamContent state of - (t:_) -> onSuccess handler state (Just t) - _ -> onSuccess handler state Nothing - --- | Remove and return the first token in the stream. Evaluates to --- 'empty' if there are no tokens in the stream. -pop :: StreamParser s Text -pop = StreamParser $ \handler state -> - case streamContent state of - (t:ts') -> onSuccess handler state { streamContent = ts' } t - _ -> onEmpty handler state - --- | View the first token in the stream without consuming it. --- Evaluates to 'empty' if there are no tokens in the stream. -peek :: StreamParser s Text -peek = StreamParser $ \handler state -> - case streamContent state of - (t:_) -> onSuccess handler state t - _ -> onEmpty handler state - --- | Prepend a token to the front of the stream. -push :: Text -> StreamParser s () -push t = StreamParser $ \handler state -> - onSuccess handler - state { streamContent = t : streamContent state } - () - --- | Discard the first token in the stream. Nothing happens if there --- are no tokens in the stream. -pop_ :: StreamParser s () -pop_ = StreamParser $ \handler state -> - onSuccess handler - state { streamContent = drop 1 $ streamContent state } - () +import Mangrove.Scheme +import Mangrove.Stream +import Mangrove.Token -------------------------------------------------------------------------------- +-- Feeding ParseTrees -- | 'feed' traverses the tree until it activates a parser that -- consumes input. When a subtree successfully consumes input, it is -- replaced with an updated subtree and the traversal ceases. -feed :: Scheme s => ParseTree s r -> StreamParser s (ParseTree s r) +feed :: Scheme s => ParseTree s r -> StreamParser (Request s) (Token s) (ParseTree s r) feed EmptyNode = empty feed (ValueNode _) = empty feed (ParseNode parser) = ValueNode <$> activate parser @@ -493,10 +70,92 @@ -- | Repeatedly traverse the tree, each time activating the first -- parser that can consume available input, until no more input can be -- consumed. -satiate :: Scheme s => ParseTree s r -> StreamParser s (ParseTree s r) +satiate :: Scheme s => ParseTree s r -> StreamParser (Request s) (Token s) (ParseTree s r) satiate tree = do parseSpecials result <- optional $ feed tree case result of Just tree' -> satiate tree' Nothing -> pure tree + +-------------------------------------------------------------------------------- +-- Running Parsers + +-- | Create a default initial t'StreamState' from a list of arguments. +argsToState :: [Text] -> StreamState s +argsToState args = StreamState args [] False + +-- | The result of an argument parsing operation. +data Result req a + = Success ![Text] !a + | Failure !Text + | Request !req + deriving (Eq, Functor, Show) + +-- | Resolve the output of a parsing operation and sink it into a +-- 'Result'. +sinkResult + :: Scheme s + => StreamHandler (Request s) (Token s) (ParseTree s r) (Result (Request s) r) +sinkResult = StreamHandler + { onSuccess = _onSuccess + , onEmpty = _onEmpty + , onFailure = _onFailure + , onRequest = _onRequest + } + where + _onFailure state' = Failure . formatError (streamContext state') + _onEmpty = flip _onFailure "empty" + _onSuccess state' tree' = + case (streamContent state', resolve tree') of + (leftovers, Value result) -> Success leftovers result + ([], EmptyError) -> _onFailure state' "empty" + ([], ExpectedError es) -> _onFailure state' $ renderExpectedError es + (token:_, _) -> _onFailure state' $ "unexpected " <> render token + _onRequest _ = Request + +-- | A more general form of 'runArgumentParser' that accepts a custom +-- stream starting state. +runArgumentParser' + :: Scheme s + => ParseTree s r + -> StreamState (Token s) + -> Result (Request s) r +runArgumentParser' tree = + runStreamParser (satiate tree) sinkResult + +-- | Satiate a 'ParseTree' with all the input it can consume, then +-- attempt to evaluate it. Empty results are treated as failures. +runArgumentParser + :: Scheme s + => ParseTree s r + -> [Text] + -> Result (Request s) r +runArgumentParser tree = + runArgumentParser' tree . argsToState + +-- | Parse the command line arguments passed to the program, then +-- invoke the program's entrypoint with the results of the parsing. If +-- parsing fails, we instead display an error to stderr and exit. +-- Alternatively, if information was requested, we abandon parsing and +-- print the response to stdout, then exit without indicating an +-- error. +parseArguments + :: Scheme s + => ProgramInfo -- ^ Program metadata + -> ParseTree s r -- ^ Argument parser + -> (r -> IO a) -- ^ Program entrypoint + -> IO a +parseArguments info tree action = do + args <- map T.pack <$> getArgs + case runArgumentParser tree args of + Success [] result -> action result + Success (token:_) _ -> do + hPutBuilder stderr $ "unexpected " <> render token <> "\n" + exitFailure + Failure err -> do + TIO.hPutStrLn stderr err + exitFailure + Request req -> do + TIO.putStr $ respond req tree info + exitSuccess diff --git a/src/Mangrove/Render.hs b/src/Mangrove/Render.hs new file mode 100644 --- /dev/null +++ b/src/Mangrove/Render.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +{-| +Module : Mangrove.Render +Copyright : (c) Quytelda Kahja, 2026 +License : BSD-3-Clause + +Facilities for textual representation of data structures. +-} +module Mangrove.Render + ( -- * Text Rendering + Render(..) + , renderLazyText + , renderText + , putBuilder + , hPutBuilder + + -- * Helpers & Combinators + , between + , brackets + , braces + , quotes + , renderDelimitedIf + + -- * Re-exports + , Builder + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Data.Text.Lazy.Builder (Builder) +import qualified Data.Text.Lazy.Builder as TLB +import qualified Data.Text.Lazy.IO as TLIO +import System.IO + +-- | A class for things that can be rendered to a text 'Builder'. +class Render a where + render :: a -> Builder + +instance Render Builder where + render = id + +instance Render T.Text where + render = TLB.fromText + +instance Render Char where + render = TLB.singleton + +instance Render String where + render = TLB.fromString + +-- | Convert renderable data directly to lazy 'TL.Text'. +renderLazyText :: Render a => a -> TL.Text +renderLazyText = TLB.toLazyText . render + +-- | Convert renderable data directly to strict 'T.Text'. +renderText :: Render a => a -> Text +renderText = TL.toStrict . TLB.toLazyText . render + +-- | Write the contents of a 'Builder' to standard output. +putBuilder :: Builder -> IO () +putBuilder = TLIO.putStr . TLB.toLazyText + +-- | Write the contents of a 'Builder' to some IO handle. +hPutBuilder :: Handle -> Builder -> IO () +hPutBuilder handle = TLIO.hPutStr handle . TLB.toLazyText + +-------------------------------------------------------------------------------- +-- Combinators + +-- | @between open close s@ surrounds @s@ with @open@ and @close@ +-- (i.e. @open <> s <> close@). +between :: Monoid m => m -> m -> m -> m +between open close s = open <> s <> close + +-- | Surround a string with square brackets. +brackets :: Builder -> Builder +brackets = between "[" "]" + +-- | Surround a string with curly braces. +braces :: Builder -> Builder +braces = between "{" "}" + +-- | Surround a string with double quotes. +quotes :: Builder -> Builder +quotes = between "\"" "\"" + +-- | @renderDelimitedIf wrap f x@ will render @x@ as a 'Builder'. If +-- the condition @f x@ is @True@, the result will be modified using +-- the function @wrap@, otherwise the result will be returned +-- unmodified. +renderDelimitedIf :: Render a => (Builder -> Builder) -> (a -> Bool) -> a -> Builder +renderDelimitedIf wrap f x = (if f x then wrap else id) (render x) diff --git a/src/Mangrove/Resolve.hs b/src/Mangrove/Resolve.hs --- a/src/Mangrove/Resolve.hs +++ b/src/Mangrove/Resolve.hs @@ -21,7 +21,8 @@ import Control.Applicative import Control.Monad.Except import qualified Data.List as List -import Mangrove.Text + +import Mangrove.Render -- | A monad for resolving parsers and expression trees. -- diff --git a/src/Mangrove/Scheme.hs b/src/Mangrove/Scheme.hs new file mode 100644 --- /dev/null +++ b/src/Mangrove/Scheme.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} + +{-| +Module : Mangrove.Scheme +Copyright : (c) Quytelda Kahja, 2026 +License : BSD-3-Clause + +A "scheme" is a set of parsers with an associated token type. The +scheme also defines the way the parser handles requests. +-} + +module Mangrove.Scheme + ( Scheme(..) + , ProgramInfo(..) + ) where + +import Data.Kind +import Data.Text (Text) +import Data.Version + +import Mangrove.ParseTree +import Mangrove.Resolve +import Mangrove.Stream +import Mangrove.Token + +-- | Program metadata for displaying help output. +data ProgramInfo = ProgramInfo + { programName :: !Text -- ^ The program name + , programDesc :: !Text -- ^ A description of the program + , programVersion :: !Version -- ^ The program version + } deriving (Show) + +-- | A scheme is a system of parsers and tokens. It parses a sequence +-- of arguments into tokens and values. +class (Functor s, HasTokens s, Resolve s) => Scheme (s :: Type -> Type) where + -- | What type of requests does this scheme support? This should be + -- 'Data.Void.Void' if requests are unsupported. + type Request s + + -- | Generate a response to a request. If requests are unsupported + -- for this scheme, the implementation of the function should be + -- 'Data.Void.absurd'. + respond :: Request s -> ParseTree s r -> ProgramInfo -> Text + + -- | Parse special control arguments that don't represent tokens in + -- the scheme, but control aspects of how parsing proceeds (e.g. + -- escaping). + parseSpecials :: StreamParser (Request s) (Token s) () + parseSpecials = pure () + + -- | 'activate' tries to run a parser on the current input. If the + -- parser doesn't apply, it consumes nothing and returns empty. If + -- it does apply, it consumes the relevant input and returns a + -- result. + activate :: s r -> StreamParser (Request s) (Token s) r diff --git a/src/Mangrove/Scheme/Common.hs b/src/Mangrove/Scheme/Common.hs new file mode 100644 --- /dev/null +++ b/src/Mangrove/Scheme/Common.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE ViewPatterns #-} + +{-| +Module : Mangrove.Scheme.Common +Copyright : (c) Quytelda Kahja, 2026 +License : BSD-3-Clause + +This module is for utilities used by more than one parsing scheme. +-} + +module Mangrove.Scheme.Common + ( keyEqualsValue + ) where + +import Data.Text (Text) +import qualified Data.Text as T + +-- | Parse a 'Text' of the form "key=value" into ("key", "value"). If +-- the delimiter ('=') does not appear in the string, the result is +-- 'Nothing'. +keyEqualsValue :: Text -> Maybe (Text, Text) +keyEqualsValue s = + case T.break (== '=') s of + (key, T.uncons -> Just (_, value)) -> Just (key, value) + _ -> Nothing diff --git a/src/Mangrove/Scheme/Sub.hs b/src/Mangrove/Scheme/Sub.hs --- a/src/Mangrove/Scheme/Sub.hs +++ b/src/Mangrove/Scheme/Sub.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} @@ -22,12 +23,18 @@ ) where import Control.Applicative -import Data.Text (Text) +import Data.Text (Text) +import Data.Void +import GHC.Generics -import Mangrove.Parser +import Mangrove.ParseTree +import Mangrove.Render import Mangrove.Resolve -import Mangrove.Text +import Mangrove.Scheme +import Mangrove.Scheme.Common +import Mangrove.Stream import Mangrove.TextParser +import Mangrove.Token import Mangrove.Valency -- | Parsers for subarguments of an option (e.g. @--option key=value@). @@ -36,6 +43,18 @@ | Option !Text (TextParser r) -- ^ Suboptions have the form "KEY=VALUE" deriving (Functor) +instance Show (SubScheme r) where + showsPrec p (Parameter tp) = + showParen (p >= 10) + $ showString "Parameter " + . showsTextParser tp + showsPrec p (Option key tp) = + showParen (p >= 10) + $ showString "Option " + . shows key + . showString " " + . showsTextParser tp + instance Valency SubScheme where valency _ = Just 1 @@ -45,14 +64,19 @@ resolve (Option key (TextParser hint _)) = ExpectedError [render key <> "=" <> render hint] -instance Scheme SubScheme where +instance HasTokens SubScheme where data Token SubScheme = SubAssoc Text Text -- ^ A "KEY=VALUE" argument | SubArgument Text -- ^ A standard freeform argument - deriving (Eq, Show) + deriving (Eq, Generic, Show) delimiter _ = ',' +instance Scheme SubScheme where + type Request SubScheme = Void + + respond = absurd + activate parser = do next <- peek escaped <- getEscaped @@ -74,8 +98,9 @@ empty _ -> empty - usageInfo (Parameter tp) = render $ parserHint tp - usageInfo (Option key tp) = render key <> "=" <> render (parserHint tp) +instance Render (SubScheme r) where + render (Parameter tp) = render $ parserHint tp + render (Option key tp) = render key <> "=" <> render (parserHint tp) instance Render (Token SubScheme) where render (SubAssoc key value) = render key <> "=" <> render value diff --git a/src/Mangrove/Scheme/Unix.hs b/src/Mangrove/Scheme/Unix.hs --- a/src/Mangrove/Scheme/Unix.hs +++ b/src/Mangrove/Scheme/Unix.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} @@ -21,9 +22,13 @@ , CommandInfo(..) -- * Unix Scheme + , UnixParser , UnixScheme(..) , Token(..) - , UnixParser + , UnixRequest(..) + , UnixRequest' + , helpRequest + , versionRequest -- * Help , addHelpOptions @@ -46,14 +51,19 @@ import qualified Data.Text.Lazy.Builder as TLB import Data.Version import Data.Void +import GHC.Generics -import Mangrove import Mangrove.Parser +import Mangrove.ParseTree +import Mangrove.Render import Mangrove.Resolve +import Mangrove.Scheme +import Mangrove.Scheme.Common import Mangrove.Scheme.Sub (SubScheme) import qualified Mangrove.Scheme.Sub as Sub -import Mangrove.Text +import Mangrove.Stream import Mangrove.TextParser +import Mangrove.Token import Mangrove.Valency -------------------------------------------------------------------------------- @@ -71,7 +81,7 @@ data Flag = LongFlag !Text | ShortFlag !Char - deriving (Eq, Ord, Show) + deriving (Eq, Generic, Ord, Show) instance IsString Flag where fromString ('-':'-':name) @@ -105,6 +115,49 @@ cmdHead :: CommandInfo -> Text cmdHead = NonEmpty.head . cmdNames +-- | Requests supported by UNIX-style parsers. +data UnixRequest + = VersionRequest -- ^ A request for version information + | HelpRequest [Text] -- ^ A request for help and usage information + deriving (Eq, Generic, Show) + +-- | Context-aware requests +type UnixRequest' = [Token UnixScheme] -> UnixRequest + +-- | A request for help information within the current command context +helpRequest :: UnixRequest' +helpRequest context = HelpRequest [cmd | UnixCommand cmd <- context] + +-- | A request for version information +versionRequest :: UnixRequest' +versionRequest _ = VersionRequest + +-- | Generate a response to a help request. +respondHelpRequest + :: [Text] + -> ParseTree UnixScheme r + -> ProgramInfo + -> Text +respondHelpRequest cmds tree info = renderText + $ "Usage:\n" + <> formatUsages (programName info) usages <> "\n\n" + <> render (programDesc info) <> "\n" + <> renderHelp tree cmds + where + usages = decomposeTree tree cmds + +-- | Generate a response to a version request. +respondVersionRequest + :: ProgramInfo + -> Text +respondVersionRequest info = renderText + $ render (programName info) + <> " version " + <> renderVersion (programVersion info) + <> "\n" + where + renderVersion = TLB.fromString . showVersion + -- | A parsing scheme for Unix-style command line syntax. data UnixScheme r -- | A freeform positional parameter @@ -114,9 +167,32 @@ -- | A named option that might support suboptions | Option !OptionInfo (ParseTree SubScheme r) -- | A special option that raises a request for information - | RequestOption !OptionInfo !RequestType + | RequestOption !OptionInfo !UnixRequest' deriving (Functor) +instance Show (UnixScheme r) where + showsPrec p (Parameter tp) = + showParen (p >= 10) + $ showString "Parameter " + . showsTextParser tp + showsPrec p (Option info subtree) = + showParen (p >= 10) + $ showString "Option " + . showsPrec 11 info + . showString " " + . showsPrec 11 subtree + showsPrec p (Command info subtree) = + showParen (p >= 10) + $ showString "Command " + . showsPrec 11 info + . showString " " + . showsPrec 11 subtree + showsPrec p (RequestOption info _) = + showParen (p >= 10) + $ showString "RequestOption " + . showsPrec 11 info + . showString " _" + instance Valency UnixScheme where valency (Parameter _) = Just 1 valency (Command _ subtree) = fmap (+1) (valency subtree) @@ -153,7 +229,7 @@ isMarked "-" = False isMarked s = "-" `T.isPrefixOf` s -instance Scheme UnixScheme where +instance HasTokens UnixScheme where data Token UnixScheme -- | A freeform positional argument that is not an option or command = UnixArgument Text @@ -161,12 +237,16 @@ | UnixCommand Text -- | A named option with optional bound argument | UnixOption Flag (Maybe Text) - deriving (Eq, Show) - - type RequestSupport UnixScheme = 'True + deriving (Eq, Generic, Show) delimiter _ = ' ' +instance Scheme UnixScheme where + type Request UnixScheme = UnixRequest + + respond (HelpRequest cmds) tree info = respondHelpRequest cmds tree info + respond VersionRequest _ info = respondVersionRequest info + parseSpecials = do peekMaybe >>= \case Just "--" -> pop_ *> setEscaped True @@ -214,10 +294,9 @@ , streamEscaped = not $ Sub.hasSubOptions subtree } parseSubargs args = - runArgumentParser' subtree (initState args) - (curry pure) - (throwError . render) - NoRequests + case runArgumentParser' subtree (initState args) of + Success leftover result -> pure (leftover, result) + Failure err -> throwError $ render err withContext (UnixOption flag mbound) $ do -- If a bound argument (e.g. --floop=blah) is provided, we @@ -252,7 +331,7 @@ (_, result) <- parseSubargs [] pure result - activate (RequestOption info requestType) = do + activate (RequestOption info mkRequest) = do -- Arguments should never be interpreted as options when escaped. getEscaped >>= guard . not @@ -261,7 +340,7 @@ pop_ withContext (UnixOption flag mbound) $ - request requestType + getContext >>= request . mkRequest activate (Command info subtree) = do -- Arguments should never be interpreted as commands when escaped. @@ -276,10 +355,11 @@ satiate subtree >>= resolveLifted - usageInfo (Parameter tp) = render $ parserHint tp - usageInfo (Command info subtree) = +instance Render (UnixScheme r) where + render (Parameter tp) = render $ parserHint tp + render (Command info subtree) = "{" <> render (cmdHead info) <> " " <> render subtree <> "}" - usageInfo (Option info subtree) = + render (Option info subtree) = render flag <> if nullary subtree then mempty @@ -288,7 +368,7 @@ separator = case flag of LongFlag _ -> "=" _ -> "" - usageInfo (RequestOption info _) = + render (RequestOption info _) = render (optHead info) instance Render (Token UnixScheme) where @@ -318,11 +398,11 @@ -- > decomposeTree tree [] -- No filtering -- > decomposeTree tree ["stash", "list"] -- Select "stash list" command decomposeTree :: ParseTree UnixScheme r -> [Text] -> Usages r -decomposeTree (ParseNode (RequestOption info requestType)) commands = +decomposeTree (ParseNode (RequestOption info mkRequest)) commands = -- If we're currently searching for a specific command, then -- this request option is irrelevant. - let node = ParseNode (RequestOption info requestType) - in Usages (if null commands then [node] else []) Nothing [] + let node = ParseNode (RequestOption info mkRequest) + in Usages [node | null commands] Nothing [] decomposeTree (ParseNode (Command info subtree)) commands | commandMismatch = @@ -339,7 +419,7 @@ where commandMismatch = case commands of - (command : _) -> not $ command `elem` cmdNames info + (command : _) -> command `notElem` cmdNames info [] -> False decomposeTree (SumNode l r) commands = @@ -382,24 +462,6 @@ where usageModes = map vacuous reqs <> maybeToList misc <> cmds -instance SupportsResponse UnixScheme where - makeVersionInfo info = renderText - $ render (programName info) - <> " version " - <> renderVersion (programVersion info) - <> "\n" - where - renderVersion = TLB.fromString . showVersion - - makeHelpInfo tree context info = renderText - $ "Usage:\n" - <> formatUsages (programName info) usages <> "\n\n" - <> render (programDesc info) <> "\n" - <> renderHelp tree context - where - commandContext = [cmd | UnixCommand cmd <- context] - usages = decomposeTree tree commandContext - -- | Convenient type alias for Unix-flavored parse trees. type UnixParser = ParseTree UnixScheme @@ -416,7 +478,7 @@ addHelpOptions flags desc tree = ParseNode helpOption <|> go tree where helpOption :: UnixScheme a - helpOption = RequestOption (OptionInfo flags desc) HelpRequest + helpOption = RequestOption (OptionInfo flags desc) helpRequest go :: ParseTree UnixScheme a -> ParseTree UnixScheme a go (ParseNode (Command info subtree)) = @@ -497,8 +559,7 @@ <> render (cmdHelp info) <> "\n" where - quote m = "\"" <> m <> "\"" - fmtCommand = quote . render . T.unwords . fmap cmdHead . reverse + fmtCommand = quotes . render . T.unwords . fmap cmdHead . reverse aliases = NonEmpty.tail $ cmdNames info aliasInfo = if null aliases @@ -533,11 +594,9 @@ -- that exist underneath the current command context. renderHelp :: ParseTree UnixScheme r - -> [Token UnixScheme] -- ^ Context Stack + -> [Text] -- ^ Command Context -> Builder -renderHelp tree contexts = +renderHelp tree cmds = renderTables - $ selectSubtable commandContext + $ selectSubtable cmds $ collectOptions tree - where - commandContext = reverse [s | UnixCommand s <- contexts] diff --git a/src/Mangrove/Stream.hs b/src/Mangrove/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Mangrove/Stream.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolymorphicComponents #-} +{-# LANGUAGE TypeFamilies #-} + +{-| +Module : Mangrove.Stream +Copyright : (c) Quytelda Kahja, 2026 +License : BSD-3-Clause + +Provides a basic stream-parsing monad for parsing argument sequences +with error handling and context management. +-} + +module Mangrove.Stream + ( -- * Stream Parser + StreamParser(..) + , StreamHandler(..) + , StreamState(..) + , failure + , request + + -- ** Escaping + , setEscaped + , getEscaped + + -- ** Context + , getContext + , setContext + , withContext + , formatError + + -- ** Streaming + , popMaybe + , peekMaybe + , pop + , peek + , push + , pop_ + , getContent +) where + +import Control.Applicative +import Control.Monad.Except +import qualified Data.List as List +import Data.Text (Text) +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TLB +import GHC.Generics + +import Mangrove.Render + +-- | The current state of a stream parser. +-- +-- The content of a stream is just a list of 'Text' values. The +-- context stack is a list of tokens currently being processed; when a +-- token is recognized, it gets added to front of the list while the +-- token is being parsed into a usable value. When this parsing +-- completes, the token is popped from the front of the list. +-- +-- A streams can also enable "escaped" mode by setting 'streamEscaped' +-- to 'True'. What this actually does is parser-dependant, but usually +-- it restricts how subsequent arguments can be interpreted. For +-- example, in the Unix scheme, escaping forces all subsequent +-- arguments to be interpreted as positional arguments, even if they +-- would normally be interpreted as options or commands. +data StreamState tok = StreamState + { streamContent :: ![Text] -- ^ A sequence of 'Text' values + , streamContext :: ![tok] -- ^ A stack representing current parsing context + , streamEscaped :: !Bool -- ^ Escaped mode + } deriving (Eq, Generic, Show) + +-- | A collection of continuations to be called for each situation a +-- stream parser might encounter. +data StreamHandler req tok a r = StreamHandler + { onSuccess :: StreamState tok -> a -> r -- ^ Success Continuation + , onEmpty :: StreamState tok -> r -- ^ Empty continuation + , onFailure :: StreamState tok -> Builder -> r -- ^ Failure Continuation + , onRequest :: StreamState tok -> req -> r -- ^ Request Continuation + } deriving (Functor) + +-- | The amazing stream parsing monad! This monad tracks the stream +-- state and context. It short-circuits when exceptions or requests +-- are raised. +newtype StreamParser req tok a = StreamParser + { runStreamParser + :: forall r. StreamHandler req tok a r + -> StreamState tok + -> r + } + +instance Functor (StreamParser req tok) where + fmap f parser = StreamParser $ \handler -> + runStreamParser parser handler { onSuccess = \s -> onSuccess handler s . f } + +instance Applicative (StreamParser req tok) where + pure a = StreamParser $ \handler state -> onSuccess handler state a + mf <*> ma = StreamParser $ \handler -> + runStreamParser mf + handler { onSuccess = \s f -> runStreamParser ma handler { onSuccess = \s' -> onSuccess handler s' . f } s } + +instance Alternative (StreamParser req tok) where + empty = StreamParser $ \handler -> onEmpty handler + l <|> r = StreamParser $ \handler -> + runStreamParser l handler { onEmpty = runStreamParser r handler } + +instance Monad (StreamParser req tok) where + return = pure + ma >>= f = StreamParser $ \handler -> + runStreamParser ma handler { onSuccess = \s a -> runStreamParser (f a) handler s } + +-- | Exit parsing with an error message because something has gone +-- wrong. +failure :: Builder -> StreamParser req tok a +failure err = StreamParser $ \handler state -> + onFailure handler state err + +instance MonadError Builder (StreamParser req tok) where + throwError = failure + catchError ma recover = StreamParser $ \handler state -> + runStreamParser ma + handler { onFailure = \_ err -> runStreamParser (recover err) handler state } + state + +-- | Enable or disable escaped parsing. What this actually does is +-- parser-dependant, but usually it restricts how subsequent arguments +-- can be interpreted. For example, in the Unix scheme, escaping +-- forces all subsequent arguments to be interpreted as positional +-- arguments, even if they would normally be interpreted as options or +-- commands. +setEscaped :: Bool -> StreamParser req tok () +setEscaped b = StreamParser $ \handler state -> + onSuccess handler state { streamEscaped = b } () + +-- | Check whether escaped parsing is enabled. +getEscaped :: StreamParser req tok Bool +getEscaped = StreamParser $ \handler state -> + onSuccess handler state (streamEscaped state) + +-- | Signal that information is requested. Short-circuits any further +-- operations. +request :: req -> StreamParser req tok a +request requestType = StreamParser $ \handler state -> + onRequest handler state requestType + +-- | Get a list representing the current context stack. +getContext :: StreamParser req tok [tok] +getContext = StreamParser $ \handler state -> + onSuccess handler state (streamContext state) + +-- | Replace the context stack. +setContext :: [tok] -> StreamParser req tok () +setContext contexts = StreamParser $ \handler state -> + onSuccess handler state { streamContext = contexts } () + +-- | Push the provided token onto the context stack, then perform some +-- computation. Afterwards, the stack is restored to its prior state. +withContext :: tok -> StreamParser req tok a -> StreamParser req tok a +withContext context action = do + oldContext <- getContext + setContext $ context : oldContext + action <* setContext oldContext + +-- | Format an error message with context information. +formatError :: Render tok => [tok] -> Builder -> Text +formatError contexts err = + TL.toStrict + $ TLB.toLazyText + $ mconcat + $ List.intersperse ": " + $ reverse + $ err : map render contexts + +-------------------------------------------------------------------------------- + +-- | Retrieve the full list of unconsumed input. This doesn't consume +-- anything or alter the state. +getContent :: StreamParser req tok [Text] +getContent = StreamParser $ \handler state -> + onSuccess handler state $ streamContent state + +-- | Remove and return the first token in the stream. +popMaybe :: StreamParser req tok (Maybe Text) +popMaybe = StreamParser $ \handler state -> + case streamContent state of + (t:ts') -> onSuccess handler state { streamContent = ts' } (Just t) + _ -> onSuccess handler state Nothing + +-- | View the first token in the stream without consuming it. +peekMaybe :: StreamParser req tok (Maybe Text) +peekMaybe = StreamParser $ \handler state -> + case streamContent state of + (t:_) -> onSuccess handler state (Just t) + _ -> onSuccess handler state Nothing + +-- | Remove and return the first token in the stream. Evaluates to +-- 'empty' if there are no tokens in the stream. +pop :: StreamParser req tok Text +pop = StreamParser $ \handler state -> + case streamContent state of + (t:ts') -> onSuccess handler state { streamContent = ts' } t + _ -> onEmpty handler state + +-- | View the first token in the stream without consuming it. +-- Evaluates to 'empty' if there are no tokens in the stream. +peek :: StreamParser req tok Text +peek = StreamParser $ \handler state -> + case streamContent state of + (t:_) -> onSuccess handler state t + _ -> onEmpty handler state + +-- | Prepend a token to the front of the stream. +push :: Text -> StreamParser req tok () +push t = StreamParser $ \handler state -> + onSuccess handler + state { streamContent = t : streamContent state } + () + +-- | Discard the first token in the stream. Nothing happens if there +-- are no tokens in the stream. +pop_ :: StreamParser req tok () +pop_ = StreamParser $ \handler state -> + onSuccess handler + state { streamContent = drop 1 $ streamContent state } + () diff --git a/src/Mangrove/Text.hs b/src/Mangrove/Text.hs deleted file mode 100644 --- a/src/Mangrove/Text.hs +++ /dev/null @@ -1,107 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -{-| -Module : Mangrove.Text -Copyright : (c) Quytelda Kahja, 2026 -License : BSD-3-Clause - -Utilities for dealing with various types of text. --} -module Mangrove.Text - ( -- * Text Rendering - Render(..) - , renderLazyText - , renderText - , putBuilder - , hPutBuilder - - -- * Helpers & Combinators - , between - , brackets - , braces - , renderDelimitedIf - , keyEqualsValue - - -- * Re-exports - , Builder - ) where - -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import Data.Text.Lazy.Builder (Builder) -import qualified Data.Text.Lazy.Builder as TLB -import qualified Data.Text.Lazy.IO as TLIO -import System.IO - --- | A class for things that can be rendered to a text 'Builder'. -class Render a where - render :: a -> Builder - -instance Render Builder where - render = id - -instance Render T.Text where - render = TLB.fromText - -instance Render Char where - render = TLB.singleton - -instance Render String where - render = TLB.fromString - --- | Convert renderable data directly to lazy 'TL.Text'. -renderLazyText :: Render a => a -> TL.Text -renderLazyText = TLB.toLazyText . render - --- | Convert renderable data directly to strict 'T.Text'. -renderText :: Render a => a -> Text -renderText = TL.toStrict . TLB.toLazyText . render - --- | Write the contents of a 'Builder' to standard output. -putBuilder :: Builder -> IO () -putBuilder = TLIO.putStr . TLB.toLazyText - --- | Write the contents of a 'Builder' to some IO handle. -hPutBuilder :: Handle -> Builder -> IO () -hPutBuilder handle = TLIO.hPutStr handle . TLB.toLazyText - --------------------------------------------------------------------------------- --- Combinators - --- | @between open close s@ surrounds @s@ with @open@ and @close@ --- (i.e. @open <> s <> close@). -between :: Monoid m => m -> m -> m -> m -between open close s = open <> s <> close - --- | Surround a string with square brackets. -brackets :: Builder -> Builder -brackets = between "[" "]" - --- | Surround a string with curly braces. -braces :: Builder -> Builder -braces = between "{" "}" - --- | @renderDelimitedIf wrap f x@ will render @x@ as a 'Builder'. If --- the condition @f x@ is @True@, the result will be modified using --- the function @wrap@, otherwise the result will be returned --- unmodified. -renderDelimitedIf :: Render a => (Builder -> Builder) -> (a -> Bool) -> a -> Builder -renderDelimitedIf wrap f x = (if f x then wrap else id) (render x) - --------------------------------------------------------------------------------- --- Utility Functions - --- | Parse a 'Text' of the form "key=value" into ("key", "value"). If --- the delimiter ('=') does not appear in the string, the result is --- 'Nothing'. -keyEqualsValue :: Text -> Maybe (Text, Text) -keyEqualsValue s = - case T.break (== '=') s of - (key, T.uncons -> Just (_, value)) -> Just (key, value) - _ -> Nothing diff --git a/src/Mangrove/TextParser.hs b/src/Mangrove/TextParser.hs --- a/src/Mangrove/TextParser.hs +++ b/src/Mangrove/TextParser.hs @@ -31,6 +31,8 @@ , parseLazyText , parseLazyTextBuilder , parseString + , parseFilePath + , showsTextParser -- * Automatic Parser Selection , DefaultParser(..) @@ -44,7 +46,7 @@ import qualified Data.Text.Lazy.Builder as TLB import qualified Data.Text.Read as TR -import Mangrove.Text +import Mangrove.Render -- | A @TextParser@ is the most basic client-defined parsing unit. It -- parses textual data that is not otherwise part of the parsing @@ -55,6 +57,21 @@ , parserRun :: Text -> Either Text r -- ^ An actual parsing function } deriving (Functor) +instance Show (TextParser r) where + showsPrec p parser = showParen (p >= 11) + $ showString "TextParser " + . showString "{ parserHint = " . shows (parserHint parser) + . showString ", parserRun = _" + . showString "}" + +-- | A nicer way to show t'TextParser's is to use the parser's hint, +-- surrounded by angle brackets, e.g. @@. +showsTextParser :: TextParser a -> ShowS +showsTextParser TextParser{parserHint = hint} = + showString "<" + . showString (T.unpack hint) + . showString ">" + -- | A more general function for running t'TextParser's. runTextParser :: MonadError Builder m => TextParser r -> Text -> m r runTextParser tp = liftEither . first TLB.fromText . parserRun tp @@ -152,7 +169,7 @@ instance DefaultParser Double where defaultParser = parseDouble --- | Parse a strict 'Text' value. +-- | Parse a strict 'T.Text' value. -- -- Since the input is already strict 'Text', this parser simply returns it for free. parseText :: TextParser Text @@ -164,6 +181,7 @@ instance DefaultParser Text where defaultParser = parseText +-- | Parse a lazy 'TL.Text' value. parseLazyText :: TextParser TL.Text parseLazyText = TextParser { parserHint = "STRING" @@ -173,6 +191,7 @@ instance DefaultParser TL.Text where defaultParser = parseLazyText +-- | Parse a lazy text 'TLB.Builder'. parseLazyTextBuilder :: TextParser TLB.Builder parseLazyTextBuilder = TextParser { parserHint = "STRING" @@ -191,3 +210,10 @@ instance DefaultParser String where defaultParser = parseString + +-- | Parser for 'FilePath's. +-- +-- This is the same as 'parseString' but with a more specialized +-- parser hint. +parseFilePath :: TextParser FilePath +parseFilePath = parseString { parserHint = "PATH" } diff --git a/src/Mangrove/Token.hs b/src/Mangrove/Token.hs new file mode 100644 --- /dev/null +++ b/src/Mangrove/Token.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +{-| +Module : Mangrove.Token +Copyright : (c) Quytelda Kahja, 2026 +License : BSD-3-Clause + +Parsing schemes convert arguments into some form of token. This module +defines the requirements for a scheme's associated token type. +-} + +module Mangrove.Token + ( HasTokens(..) + ) where + +import Data.Kind +import Data.Proxy + +import Mangrove.Render + +-- | Parsing schemes convert arguments into some form of token. This +-- class defines the associated token type for a particular scheme. +class (Eq (Token s), Show (Token s), Render (Token s)) => HasTokens (s :: Type -> Type) where + -- | A token represents a particular interpretation of an argument + -- string. + data Token s + + -- | 'delimiter' is the character that separates argument strings in + -- combined string representation. For example, arguments in the CLI + -- command @ls -a -l /var@ are separated by spaces. + delimiter :: Proxy s -> Char diff --git a/src/Mangrove/Unix.hs b/src/Mangrove/Unix.hs --- a/src/Mangrove/Unix.hs +++ b/src/Mangrove/Unix.hs @@ -5,8 +5,13 @@ Copyright : (c) Quytelda Kahja, 2026 License : BSD-3-Clause -An API for defining, constructing, and running Unix-style command line -parsers. +This module contains the building blocks for creating UNIX-style +command line parsers. Parsers are intended to be combined using the +standard combinators in "Control.Applicative". + +The functions for running parsers live in the "Mangrove.Parser" module +and are re-exported by the "Mangrove" module alongside other useful +symbols. -} module Mangrove.Unix @@ -18,6 +23,8 @@ , Flag(..) , TextParser(..) , DefaultParser(..) + , UnixRequest(..) + , UnixRequest' -- * Tree-building Combinators , parameter @@ -29,15 +36,19 @@ , subparameter , suboption - -- ** Help Options + -- ** Help Options , addHelpOptions + + -- * Requests + , helpRequest + , versionRequest ) where import Control.Applicative import Data.List.NonEmpty (NonEmpty) import Data.Text (Text) -import Mangrove.Parser +import Mangrove.ParseTree import Mangrove.Scheme.Sub (SubParser, SubScheme) import qualified Mangrove.Scheme.Sub as Sub import Mangrove.Scheme.Unix @@ -81,7 +92,7 @@ requestOption :: NonEmpty Flag -> Text - -> RequestType + -> UnixRequest' -> UnixParser a requestOption flags help = ParseNode . RequestOption (OptionInfo flags help) diff --git a/test/Arbitrary.hs b/test/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/test/Arbitrary.hs @@ -0,0 +1,164 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} + +module Arbitrary + ( ArgList(..) + , Name(..) + ) where + +import Data.Char +import Data.Text (Text) +import qualified Data.Text as T +import System.Random +import Test.QuickCheck hiding (Result (..)) +import Test.QuickCheck.Gen (Gen (..)) +import Test.QuickCheck.Instances () + +import Mangrove +import Mangrove.ParseTree +import Mangrove.Render +import qualified Mangrove.Scheme.Sub as Sub +import Mangrove.Scheme.Unix +import qualified Mangrove.Scheme.Unix as Unix +import Mangrove.Stream +import Mangrove.TextParser +import Mangrove.Unix + +-------------------------------------------------------------------------------- +-- Arbitrary Name Generator + +randomNameChar :: RandomGen g => g -> (Char, g) +randomNameChar gen = (chr (n + offset), gen') + where + (n, gen') = uniformR (0, 62) gen + offset + | n >= 0 && n < 10 = 48 + | n >= 10 && n < 36 = 55 + | n >= 36 && n < 62 = 61 + -- The only remaining case is n == 62. + | otherwise = 33 + +randomNameText :: RandomGen g => g -> Int -> Text +randomNameText gen n = T.unfoldrN n (Just . randomNameChar) gen + +genNameChar :: Gen Char +genNameChar = MkGen $ const . fst . randomNameChar + +genNameText :: Gen Text +genNameText = MkGen randomNameText `suchThat` (not . T.null) + +-- | newtype wrapper for 'Text' that holds results from 'genNameText' +newtype Name = Name { getName :: Text } + deriving (Eq, Show) + +getNames :: Functor f => f Name -> f Text +getNames = fmap getName + +instance Arbitrary Name where + arbitrary = Name <$> genNameText + +-------------------------------------------------------------------------------- +-- Generic ParseTrees + +genParser :: Scheme s => Gen (s Int) -> Gen (ParseTree s Int) +genParser genScheme = sized $ \n -> oneof $ + if n <= 0 + then [ pure EmptyNode, ValueNode <$> arbitrary ] + else [ pure EmptyNode + , ValueNode <$> arbitrary + , ParseNode <$> genScheme + , ProdNode <$> arbitrary @(Int -> Int -> Int) + <*> genParser genScheme + <*> genParser genScheme + , SumNode <$> genParser genScheme <*> genParser genScheme + -- ManyNode can only give us a `UnixParser [Int]`, so we have + -- to wrap it in order to make the types match. + , (fmap . fmap) sum $ ManyNode <$> arbitrary <*> genParser genScheme + ] + +-------------------------------------------------------------------------------- +-- SubScheme Parsers + +instance Arbitrary (Token SubScheme) where + arbitrary = + oneof [ SubAssoc <$> genNameText <*> arbitrary + , SubArgument <$> arbitrary + ] + +instance CoArbitrary (Token SubScheme) + +genSubScheme :: Gen (SubScheme Int) +genSubScheme = + oneof [ pure $ Sub.Parameter defaultParser + , flip Sub.Option defaultParser <$> arbitrary + ] + +instance Arbitrary (ParseTree SubScheme Int) where + arbitrary = genParser genSubScheme + +-------------------------------------------------------------------------------- +-- UnixScheme Parsers + +instance Arbitrary Flag where + arbitrary = + oneof [ LongFlag <$> genNameText + , ShortFlag <$> genNameChar + ] + +instance CoArbitrary Flag + +instance Arbitrary Unix.OptionInfo where + arbitrary = OptionInfo <$> arbitrary <*> arbitrary + +instance Arbitrary Unix.CommandInfo where + arbitrary = CommandInfo <$> fmap getNames arbitrary <*> arbitrary + +instance Arbitrary (Token UnixScheme) where + arbitrary = + oneof [ UnixArgument <$> arbitrary + , UnixCommand <$> genNameText + , UnixOption <$> arbitrary <*> arbitrary + ] + +instance CoArbitrary (Token UnixScheme) + +instance Arbitrary UnixRequest where + arbitrary = elements [HelpRequest [], VersionRequest] + +instance CoArbitrary UnixRequest + +genUnixScheme :: Gen (UnixScheme Int) +genUnixScheme = + oneof [ pure $ Unix.Parameter defaultParser + , Unix.Option <$> arbitrary <*> arbitrary + , Unix.Command <$> arbitrary <*> arbitrary + , Unix.RequestOption <$> arbitrary <*> arbitrary + ] + +instance Arbitrary (ParseTree UnixScheme Int) where + arbitrary = genParser genUnixScheme + +-------------------------------------------------------------------------------- +-- StreamParsers + +genUnixArgument :: Gen Text +genUnixArgument = renderText <$> arbitrary @(Token UnixScheme) + +genUnixArgs :: Gen [Text] +genUnixArgs = sized $ \n -> vectorOf n genUnixArgument + +newtype ArgList = ArgList { getArgs :: [Text] } + deriving (Show) + +instance Arbitrary ArgList where + arbitrary = ArgList <$> genUnixArgs + +instance Arbitrary (StreamState (Token UnixScheme)) where + arbitrary = StreamState <$> genUnixArgs <*> arbitrary <*> arbitrary + +instance CoArbitrary (StreamState (Token UnixScheme)) diff --git a/test/General.hs b/test/General.hs --- a/test/General.hs +++ b/test/General.hs @@ -4,58 +4,56 @@ module General (spec) where import Control.Applicative - -import Data.Version import Test.Hspec import Mangrove -import Mangrove.Text +import Mangrove.Render import TestParsers optionSpec :: Spec optionSpec = do it "parses long options" $ do - runHelpfulParser_ opt_example_unit ["--example"] + runArgumentParser opt_example_unit ["--example"] `shouldBe` Success [] () it "parses short options" $ do - runHelpfulParser_ opt_e_unit ["-e"] + runArgumentParser opt_e_unit ["-e"] `shouldBe` Success [] () it "parses options in any order" $ do - runHelpfulParser_ (opt_e_unit *> opt_f_unit) ["-e", "-f"] + runArgumentParser (opt_e_unit *> opt_f_unit) ["-e", "-f"] `shouldBe` Success [] () - runHelpfulParser_ (opt_e_unit *> opt_f_unit) ["-f", "-e"] + runArgumentParser (opt_e_unit *> opt_f_unit) ["-f", "-e"] `shouldBe` Success [] () describe "switches" $ do context "when switch is present" $ do it "yields True" $ do - runHelpfulParser_ opt_example_switch ["--example"] + runArgumentParser opt_example_switch ["--example"] `shouldBe` Success [] True context "when switch is absent" $ do it "yields False" $ do - runHelpfulParser_ opt_example_switch [] + runArgumentParser opt_example_switch [] `shouldBe` Success [] False context "when a bound argument is provided" $ do context "when an argument is expected" $ do it "parses the argument" $ do - runHelpfulParser_ opt_example_param ["--example=qwer"] + runArgumentParser opt_example_param ["--example=qwer"] `shouldBe` Success [] "qwer" - runHelpfulParser_ opt_e_param ["-eqwer"] + runArgumentParser opt_e_param ["-eqwer"] `shouldBe` Success [] "qwer" context "when no argument is expected" $ do it "parsing fails" $ do - runHelpfulParser_ opt_example_unit ["--example=qwer"] + runArgumentParser opt_example_unit ["--example=qwer"] `shouldBe` Failure "--example=qwer: unrecognized subargument: qwer" - runHelpfulParser_ opt_e_unit ["-eqwer"] + runArgumentParser opt_e_unit ["-eqwer"] `shouldBe` Failure "-eqwer: unrecognized subargument: qwer" context "when no argument is expected" $ do context "when an argument is available" $ do it "doesn't consume the argument" $ do - runHelpfulParser_ opt_example_unit ["--example", "qwer"] + runArgumentParser opt_example_unit ["--example", "qwer"] `shouldBe` Success ["qwer"] () context "when an argument is required" $ do @@ -65,11 +63,11 @@ context "when no argument is provided" $ do it "fails to parse" $ do - runHelpfulParser_ opt_example_param ["--example"] + runArgumentParser opt_example_param ["--example"] `shouldBe` Failure "--example: expected: STRING" context "when an argument is provided" $ do it "the argument is consumed" $ do - runHelpfulParser_ opt_example_param ["--example", "qwer"] + runArgumentParser opt_example_param ["--example", "qwer"] `shouldBe` Success [] "qwer" context "when an argument is optional" $ do @@ -78,97 +76,91 @@ context "when no argument is provided" $ do it "yields a default value" $ do - runHelpfulParser_ opt_example_param_optional ["--example"] + runArgumentParser opt_example_param_optional ["--example"] `shouldBe` Success [] "asdf" it "does not consume subsequent options" $ do - runHelpfulParser_ opt_example_param_optional ["--example", "--option"] + runArgumentParser opt_example_param_optional ["--example", "--option"] `shouldBe` Success ["--option"] "asdf" context "when an argument is provided" $ do it "parses the argument" $ do - runHelpfulParser_ opt_example_param_optional ["--example", "qwer"] + runArgumentParser opt_example_param_optional ["--example", "qwer"] `shouldBe` Success [] "qwer" describe "compound options" $ do context "when the subtree accepts multiple arguments" $ do it "splits the input by delimiter" $ do - runHelpfulParser_ opt_example_pair ["--example", "1,3"] + runArgumentParser opt_example_pair ["--example", "1,3"] `shouldBe` Success [] (1,3) context "when the subtree can't accept multiple argument" $ do it "doesn't split the input by delimiter" $ do - runHelpfulParser_ opt_example_param ["--example", "1,3"] + runArgumentParser opt_example_param ["--example", "1,3"] `shouldBe` Success [] "1,3" - runHelpfulParser_ opt_example_param_optional ["--example", "1,3"] + runArgumentParser opt_example_param_optional ["--example", "1,3"] `shouldBe` Success [] "1,3" context "when the subtree accepts suboptions" $ do it "parses key=value pairs" $ do - runHelpfulParser_ opt_example_subopt ["--example", "value=asdf"] + runArgumentParser opt_example_subopt ["--example", "value=asdf"] `shouldBe` Success [] "asdf" - runHelpfulParser_ opt_example_subopt ["--example=value=asdf"] + runArgumentParser opt_example_subopt ["--example=value=asdf"] `shouldBe` Success [] "asdf" context "when the subtree can't accept suboptions" $ do it "doesn't parse key=value pairs" $ do - runHelpfulParser_ opt_example_param ["--example", "value=asdf"] + runArgumentParser opt_example_param ["--example", "value=asdf"] `shouldBe` Success [] "value=asdf" - runHelpfulParser_ opt_example_param ["--example=value=asdf"] + runArgumentParser opt_example_param ["--example=value=asdf"] `shouldBe` Success [] "value=asdf" describe "help options" $ do - let progInfo = ProgramInfo - { programName = "example" - , programVersion = makeVersion [1,0] - , programDesc = "description" - } :: ProgramInfo s - - isResponse (Response {}) = True - isResponse _ = False + let isRequest (Request {}) = True + isRequest _ = False context "when a help option is present" $ do it "requests help" $ do - runHelpfulParser progInfo (withHelp opt_example_unit) ["--help"] - `shouldSatisfy` isResponse + runArgumentParser (withHelp opt_example_unit) ["--help"] + `shouldSatisfy` isRequest it "works for subcommands" $ do - runHelpfulParser progInfo (withHelp cmd_example_tree) ["example", "--help"] - `shouldSatisfy` isResponse - runHelpfulParser progInfo (withHelp cmd_example_tree) ["example", "asdf", "--help"] - `shouldSatisfy` isResponse + runArgumentParser (withHelp cmd_example_tree) ["example", "--help"] + `shouldSatisfy` isRequest + runArgumentParser (withHelp cmd_example_tree) ["example", "asdf", "--help"] + `shouldSatisfy` isRequest context "when a help option is absent" $ do it "doesn't request help" $ do - runHelpfulParser_ (withHelp opt_example_unit) ["--example"] + runArgumentParser (withHelp opt_example_unit) ["--example"] `shouldBe` Success [] () - runHelpfulParser_ (withHelp opt_example_unit) [] + runArgumentParser (withHelp opt_example_unit) [] `shouldBe` Failure "expected: --help or --example" it "isn't activated by escaped options" $ do - runHelpfulParser_ (withHelp opt_example_unit) ["--", "--help"] + runArgumentParser (withHelp opt_example_unit) ["--", "--help"] `shouldBe` Failure "unexpected --help" generalSpec :: Spec generalSpec = do context "when \"-\" is given as an argument" $ do it "parses the string \"-\"" $ do - runHelpfulParser_ param_text ["-"] + runArgumentParser param_text ["-"] `shouldBe` Success [] "-" context "when \"--\" is present in the argument list" $ do it "treats subsequent arguments as free arguments" $ do - runHelpfulParser_ param_text ["--", "asdf"] + runArgumentParser param_text ["--", "asdf"] `shouldBe` Success [] "asdf" it "doesn't treat subsequent arguments as options" $ do - runHelpfulParser_ (option_asdf <|> param_text) ["--", "--asdf"] + runArgumentParser (option_asdf <|> param_text) ["--", "--asdf"] `shouldBe` Success [] "--asdf" it "doesn't treat subsequent arguments as commands" $ do - runHelpfulParser_ (command_asdf <|> param_text) ["--", "asdf"] + runArgumentParser (command_asdf <|> param_text) ["--", "asdf"] `shouldBe` Success [] "asdf" context "when not enough input is provided" $ do it "fails to generate a result" $ do - runHelpfulParser_ param_text [] + runArgumentParser param_text [] `shouldBe` Failure "expected: STRING" context "when not all input can be consumed" $ do it "returns unconsumed arguments" $ do - runHelpfulParser_ param_text ["asdf", "qwer"] + runArgumentParser param_text ["asdf", "qwer"] `shouldBe` Success ["qwer"] "asdf" spec :: Spec diff --git a/test/Mangrove/ParseTreeSpec.hs b/test/Mangrove/ParseTreeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Mangrove/ParseTreeSpec.hs @@ -0,0 +1,282 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Mangrove.ParseTreeSpec (spec) where + +import Control.Applicative +import Data.Text (Text) +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck hiding (Result (..)) + +import Mangrove +import Mangrove.ParseTree +import Mangrove.Scheme.Unix +import Mangrove.Valency + +import Arbitrary +import StructureEq +import TestParsers + +-------------------------------------------------------------------------------- +-- Functor Laws + +prop_fmapIdLaw :: UnixParser Int -> Bool +prop_fmapIdLaw tree = structEq tree (fmap id tree) + +prop_fmapComLaw :: UnixParser Int -> Bool +prop_fmapComLaw tree = + fmap (inc . dbl) tree + `structEq` + (fmap inc . fmap dbl) tree + where + inc = (1+) + dbl = (2*) + +-------------------------------------------------------------------------------- +-- Applicative Laws + +prop_applicativeIdLaw + :: ParseTree UnixScheme Int + -> ArgList + -> Bool +prop_applicativeIdLaw tree (ArgList args) = + result1 == result2 + where + result1 = runArgumentParser (pure id <*> tree) args + result2 = runArgumentParser tree args + +prop_applicativeHomLaw + :: Fun Int Int + -> Int + -> ArgList + -> Bool +prop_applicativeHomLaw (Fn f) value (ArgList args) = + result1 == result2 + where + tree1 = pure f <*> pure value :: ParseTree UnixScheme Int + tree2 = pure (f value) :: ParseTree UnixScheme Int + result1 = runArgumentParser tree1 args + result2 = runArgumentParser tree2 args + +prop_applicativeIntLaw + :: Fun (Int, Int) Int + -> ParseTree UnixScheme Int + -> Int + -> ArgList + -> Bool +prop_applicativeIntLaw (Fn2 f) tree n (ArgList args) = + result1 == result2 + where + u = fmap f tree + result1 = runArgumentParser (u <*> pure n) args + result2 = runArgumentParser (pure ($ n) <*> u) args + +prop_applicativeComLaw + :: Fun (Int, Int) Int + -> Fun (Int, Int) Int + -> ParseTree UnixScheme Int + -> ParseTree UnixScheme Int + -> ParseTree UnixScheme Int + -> ArgList + -> Bool +prop_applicativeComLaw (Fn2 f) (Fn2 g) t1 t2 w (ArgList args) = + result1 == result2 + where + u = fmap f t1 + v = fmap g t2 + tree1 = pure (.) <*> u <*> v <*> w + tree2 = u <*> (v <*> w) + result1 = runArgumentParser tree1 args + result2 = runArgumentParser tree2 args + +-------------------------------------------------------------------------------- + +prop_valencyPositive + :: UnixParser Int + -> Bool +prop_valencyPositive p = + all (>= 0) (valency p) + +prop_liftA2AddsValencies + :: UnixParser Int + -> UnixParser Int + -> Bool +prop_liftA2AddsValencies l r = + valency (liftA2 (+) l r) == liftA2 (+) (valency l) (valency r) + +prop_liftA2CombinesResults + :: Fun (Int, Int) Int + -> UnixParser Int + -> UnixParser Int + -> ArgList + -> Bool +prop_liftA2CombinesResults (Fn2 f) l r (ArgList args) = + case (resultL, resultR, resultA) of + (Success _ x, Success _ y, Success _ z) -> z == f x y + _ -> resultA == resultL || resultA == resultR + where + resultL = runArgumentParser l args + resultR = runArgumentParser r args + resultA = runArgumentParser (liftA2 f l r) args + +prop_altMaxesValency + :: UnixParser Int + -> UnixParser Int + -> Bool +prop_altMaxesValency l r = + valency (l <|> r) == liftA2 (max) (valency l) (valency r) + +prop_altPicksOne + :: ParseTree UnixScheme Int + -> ParseTree UnixScheme Int + -> ArgList + -> Bool +prop_altPicksOne l r (ArgList args) = + resultSum == resultL || resultSum == resultR + where + resultL = runArgumentParser l args + resultR = runArgumentParser r args + resultSum = runArgumentParser (l <|> r) args + +prop_altEmptyIdentity + :: (ParseTree UnixScheme Int -> ParseTree UnixScheme Int) + -> ParseTree UnixScheme Int + -> ArgList + -> Bool +prop_altEmptyIdentity append tree (ArgList args) = + runArgumentParser tree args == runArgumentParser (append tree) args + +-------------------------------------------------------------------------------- + +spec :: Spec +spec = do + describe "Functor Instance" $ do + prop "satisfies identity law" + prop_fmapIdLaw + prop "satisfies composition law" + prop_fmapComLaw + + describe "Applicative Instance" $ do + prop "satisfies identity law" + prop_applicativeIdLaw + prop "satisfies homomorphism law" + prop_applicativeHomLaw + prop "satisfies interchange law" + prop_applicativeIntLaw + prop "satisfies composition law" + prop_applicativeComLaw + + describe "Valency Instance" $ do + prop "valency is always positive" + prop_valencyPositive + + describe "pure" $ do + it "resolves to the given value" $ do + runArgumentParser (ValueNode 'a' :: ParseTree UnixScheme Char) [] + `shouldBe` Success [] 'a' + + describe "liftA2" $ do + it "combines two values" $ do + runArgumentParser (liftA2 (+) (pure 1) (pure 2) :: ParseTree UnixScheme Int) [] + `shouldBe` Success [] 3 + + -- should be equivalent + runArgumentParser ((+) <$> pure 1 <*> pure 2 :: ParseTree UnixScheme Int) [] + `shouldBe` Success [] 3 + + prop "combines results" + prop_liftA2CombinesResults + prop "adds valencies" + prop_liftA2AddsValencies + + describe "empty" $ do + it "doesn't resolve to any value" $ do + runArgumentParser (empty :: ParseTree UnixScheme Char) [] + `shouldBe` Failure "empty" + + it "has valency zero" $ do + valency (empty :: ParseTree UnixScheme Char) + `shouldBe` Just 0 + + describe "(<|>)" $ do + prop "valency equals the max valency between its children" + prop_altMaxesValency + prop "yields the left or the right result" + prop_altPicksOne + prop "empty is left identity" $ + prop_altEmptyIdentity (empty <|>) + prop "empty is right identity" $ + prop_altEmptyIdentity (<|> empty) + + context "when the left child is resolvable" $ do + it "resolves as the left child" $ do + runArgumentParser (pure "asdf" <|> opt_e_param) [] + `shouldBe` Success [] "asdf" + + -- When the right child is also resolvable, it should be + -- ignored. + runArgumentParser (pure "asdf" <|> pure "qwer" :: ParseTree UnixScheme Text) [] + `shouldBe` Success [] "asdf" + + context "when the left child is unresolvable" $ do + it "resolves as the right child" $ do + runArgumentParser (opt_e_param <|> pure "asdf") [] + `shouldBe` Success [] "asdf" + + context "when one child is triggered" $ do + it "prunes the other child" $ do + runArgumentParser (opt_e_unit <|> opt_f_unit) ["-e", "-f"] + `shouldBe` Success ["-f"] () + runArgumentParser (opt_e_unit <|> opt_f_unit) ["-f", "-e"] + `shouldBe` Success ["-e"] () + + describe "many" $ do + it "parses multiple instances" $ do + runArgumentParser (many opt_e_param) ["-e", "asdf", "-e", "qwer", "-e", "zxcv"] + `shouldBe` Success [] ["asdf", "qwer", "zxcv"] + it "parses zero instances" $ do + runArgumentParser (many opt_e_param) ["blah"] + `shouldBe` Success ["blah"] [] + + it "handles compound trees" $ do + let tree = (opt_f_unit *> opt_e_param) <|> opt_example_param + runArgumentParser (many tree) ["-f", "-e", "asdf", "--example", "qwer"] + `shouldBe` Success [] ["asdf", "qwer"] + + it "doesn't swallow arguments" $ do + runArgumentParser (many $ opt_f_unit *> opt_e_param) ["-f", "-e", "asdf", "-f"] + `shouldBe` Failure "expected: -e" + -- Some attempts at implementing many/some resulted in + -- arguments being silently swallowed if they were consumed by + -- a parser inside a ManyNode which didn't receive enough + -- input to resolve. In some cases this didn't occur until the + -- second instance of the subtree was triggered. The expected + -- behavior in this case is to fail with a message about what + -- input was missing. + + describe "some" $ do + it "parses multiple instances" $ do + runArgumentParser (some opt_e_param) ["-e", "asdf", "-e", "qwer", "-e", "zxcv"] + `shouldBe` Success [] ["asdf", "qwer", "zxcv"] + it "requires at least one instance" $ do + runArgumentParser (some opt_e_param) ["blah"] + `shouldBe` Failure "unexpected blah" + + it "handles compound trees" $ do + let tree = (opt_f_unit *> opt_e_param) <|> opt_example_param + runArgumentParser (some tree) ["-f", "-e", "asdf", "--example", "qwer"] + `shouldBe` Success [] ["asdf", "qwer"] + + it "doesn't swallow arguments" $ do + runArgumentParser (some $ opt_f_unit *> opt_e_param) ["-f", "-e", "asdf", "-f"] + `shouldBe` Failure "expected: -e" + + describe "optional" $ do + it "parses exactly one instance" $ do + runArgumentParser (optional opt_e_param) ["-e", "asdf", "-e", "qwer", "-e", "zxcv"] + `shouldBe` Success [ "-e", "qwer", "-e", "zxcv"] (Just "asdf") + it "parses zero instances" $ do + runArgumentParser (optional opt_e_param) ["blah"] + `shouldBe` Success ["blah"] Nothing diff --git a/test/Mangrove/ParserSpec.hs b/test/Mangrove/ParserSpec.hs deleted file mode 100644 --- a/test/Mangrove/ParserSpec.hs +++ /dev/null @@ -1,179 +0,0 @@ -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -module Mangrove.ParserSpec (spec) where - -import Control.Applicative -import Data.Text (Text) -import Data.Text.Lazy.Builder -import Test.Hspec - -import Mangrove -import Mangrove.Parser -import Mangrove.Scheme.Unix - -import TestParsers - -spec :: Spec -spec = do - spec_ParseTree - spec_StreamParser - -spec_ParseTree :: Spec -spec_ParseTree = do - describe "pure" $ do - it "resolves to the given value" $ do - runHelpfulParser_ (ValueNode 'a' :: ParseTree UnixScheme Char) [] - `shouldBe` Success [] 'a' - - describe "liftA2" $ do - it "combines two values" $ do - runHelpfulParser_ (liftA2 (+) (pure 1) (pure 2) :: ParseTree UnixScheme Int) [] - `shouldBe` Success [] 3 - - -- should be equivalent - runHelpfulParser_ ((+) <$> pure 1 <*> pure 2 :: ParseTree UnixScheme Int) [] - `shouldBe` Success [] 3 - - describe "empty" $ do - it "doesn't resolve to any value" $ do - runHelpfulParser_ (empty :: ParseTree UnixScheme Char) [] - `shouldBe` Failure "empty" - - describe "(<|>)" $ do - context "when the left child is resolvable" $ do - it "resolves as the left child" $ do - runHelpfulParser_ (pure "asdf" <|> opt_e_param) [] - `shouldBe` Success [] "asdf" - - -- When the right child is also resolvable, it should be - -- ignored. - runHelpfulParser_ (pure "asdf" <|> pure "qwer" :: ParseTree UnixScheme Text) [] - `shouldBe` Success [] "asdf" - - context "when the left child is unresolvable" $ do - it "resolves as the right child" $ do - runHelpfulParser_ (opt_e_param <|> pure "asdf") [] - `shouldBe` Success [] "asdf" - - context "when one child is triggered" $ do - it "prunes the other child" $ do - runHelpfulParser_ (opt_e_unit <|> opt_f_unit) ["-e", "-f"] - `shouldBe` Success ["-f"] () - runHelpfulParser_ (opt_e_unit <|> opt_f_unit) ["-f", "-e"] - `shouldBe` Success ["-e"] () - - describe "many" $ do - it "parses multiple instances" $ do - runHelpfulParser_ (many opt_e_param) ["-e", "asdf", "-e", "qwer", "-e", "zxcv"] - `shouldBe` Success [] ["asdf", "qwer", "zxcv"] - it "parses zero instances" $ do - runHelpfulParser_ (many opt_e_param) ["blah"] - `shouldBe` Success ["blah"] [] - - it "handles compound trees" $ do - let tree = (opt_f_unit *> opt_e_param) <|> opt_example_param - runHelpfulParser_ (many tree) ["-f", "-e", "asdf", "--example", "qwer"] - `shouldBe` Success [] ["asdf", "qwer"] - - it "doesn't swallow arguments" $ do - runHelpfulParser_ (many $ opt_f_unit *> opt_e_param) ["-f", "-e", "asdf", "-f"] - `shouldBe` Failure "expected: -e" - -- Some attempts at implementing many/some resulted in - -- arguments being silently swallowed if they were consumed by - -- a parser inside a ManyNode which didn't receive enough - -- input to resolve. In some cases this didn't occur until the - -- second instance of the subtree was triggered. The expected - -- behavior in this case is to fail with a message about what - -- input was missing. - - describe "some" $ do - it "parses multiple instances" $ do - runHelpfulParser_ (some opt_e_param) ["-e", "asdf", "-e", "qwer", "-e", "zxcv"] - `shouldBe` Success [] ["asdf", "qwer", "zxcv"] - it "requires at least one instance" $ do - runHelpfulParser_ (some opt_e_param) ["blah"] - `shouldBe` Failure "unexpected blah" - - it "handles compound trees" $ do - let tree = (opt_f_unit *> opt_e_param) <|> opt_example_param - runHelpfulParser_ (some tree) ["-f", "-e", "asdf", "--example", "qwer"] - `shouldBe` Success [] ["asdf", "qwer"] - - it "doesn't swallow arguments" $ do - runHelpfulParser_ (some $ opt_f_unit *> opt_e_param) ["-f", "-e", "asdf", "-f"] - `shouldBe` Failure "expected: -e" - - describe "optional" $ do - it "parses exactly one instance" $ do - runHelpfulParser_ (optional opt_e_param) ["-e", "asdf", "-e", "qwer", "-e", "zxcv"] - `shouldBe` Success [ "-e", "qwer", "-e", "zxcv"] (Just "asdf") - it "parses zero instances" $ do - runHelpfulParser_ (optional opt_e_param) ["blah"] - `shouldBe` Success ["blah"] Nothing - --------------------------------------------------------------------------------- --- Stream Parser Monad - -data StreamResult r - = SSuccess r - | SEmpty - | SFailure Builder - | SRequest RequestType - deriving (Eq, Show) - --- | Sink the results of a 'StreamParser' into a data type for easier inspection. -runStreamParser' - :: SupportsResponse s - => StreamParser s r - -> StreamState s - -> (StreamState s, StreamResult r) -runStreamParser' parser state = - runStreamParser parser handler state - where - handler = StreamHandler - { onSuccess = \s result -> (s, SSuccess result) - , onEmpty = \s -> (s, SEmpty) - , onFailure = \s err -> (s, SFailure err) - , onRequest = OnRequest $ \s t -> (s, SRequest t) - } - -initState_empty :: StreamState s -initState_empty = StreamState [] [] False - -initState_singleton :: StreamState s -initState_singleton = StreamState ["asdf"] [] False - -spec_StreamParser :: Spec -spec_StreamParser = do - describe "peek" $ do - context "when the stream is empty" $ do - let (finalState, result) = runStreamParser' peek (initState_empty @UnixScheme) - it "returns empty" $ do - result `shouldBe` SEmpty - it "preserves the state" $ do - initState_empty `shouldBe` finalState - - context "when the stream is not empty" $ do - let (finalState, result) = runStreamParser' peek (initState_singleton @UnixScheme) - it "gets the first item" $ do - result `shouldBe` SSuccess "asdf" - it "preserves the state" $ do - initState_singleton `shouldBe` finalState - - describe "pop" $ do - context "when the stream is empty" $ do - let (finalState, result) = runStreamParser' pop (initState_empty @UnixScheme) - it "returns empty" $ do - result `shouldBe` SEmpty - it "preserves the state" $ do - initState_empty `shouldBe` finalState - - context "when the stream is not empty" $ do - let (finalState, result) = runStreamParser' pop (initState_singleton @UnixScheme) - it "gets the first item without replacement" $ do - result `shouldBe` SSuccess "asdf" - streamContent finalState `shouldBe` drop 1 (streamContent initState_singleton) - it "preserves the context" $ do - streamContext initState_singleton `shouldBe` streamContext finalState diff --git a/test/Mangrove/StreamSpec.hs b/test/Mangrove/StreamSpec.hs new file mode 100644 --- /dev/null +++ b/test/Mangrove/StreamSpec.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Mangrove.StreamSpec (spec) where + +import Data.Maybe +import Data.Text (Text) +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck hiding (Result (..)) +import Test.QuickCheck.Instances () + +import Mangrove +import Mangrove.Scheme.Unix +import Mangrove.Stream +import Mangrove.Test.Stream + +-------------------------------------------------------------------------------- +-- Functor Laws + +prop_functorIdLaw + :: SP_Unix Int + -> StreamState (Token UnixScheme) + -> Bool +prop_functorIdLaw (SP_Unix m) state = + runSPU (fmap id m) state == runSPU m state + +prop_functorComLaw + :: Fun Int Int + -> Fun Int Int + -> SP_Unix Int + -> StreamState (Token UnixScheme) + -> Bool +prop_functorComLaw (Fn f) (Fn g) (SP_Unix m) state = + runSPU (fmap (f . g) m) state == runSPU ((fmap f . fmap g) m) state + +-------------------------------------------------------------------------------- +-- Applicative Laws + +prop_applicativeIdLaw + :: SP_Unix Int + -> StreamState (Token UnixScheme) + -> Bool +prop_applicativeIdLaw (SP_Unix m) state = + runSPU (pure id <*> m) state == runSPU m state + +prop_applicativeHomLaw + :: Fun Int Int + -> Int + -> StreamState (Token UnixScheme) + -> Bool +prop_applicativeHomLaw (Fn f) x state = + runSPU (pure f <*> pure x) state == runSPU (pure (f x)) state + +prop_applicativeIntLaw + :: SP_Unix (Int -> Int) + -> Int + -> StreamState (Token UnixScheme) + -> Bool +prop_applicativeIntLaw (SP_Unix u) y state = + runSPU (u <*> pure y) state == runSPU (pure ($ y) <*> u) state + +prop_applicativeComLaw + :: SP_Unix (Int -> Int) + -> SP_Unix (Int -> Int) + -> SP_Unix Int + -> StreamState (Token UnixScheme) + -> Bool +prop_applicativeComLaw (SP_Unix u) (SP_Unix v) (SP_Unix w) state = + runSPU (pure (.) <*> u <*> v <*> w) state + == runSPU (u <*> (v <*> w)) state + +-------------------------------------------------------------------------------- +-- Monad Laws + +prop_monadLeftId + :: Int + -> Fun Int (SP_Unix Int) + -> StreamState (Token UnixScheme) + -> Bool +prop_monadLeftId a fn state = + runSPU (f a) state == runSPU (return a >>= f) state + where + f = getSPU . applyFun fn + +prop_monadRightId + :: SP_Unix Int + -> StreamState (Token UnixScheme) + -> Bool +prop_monadRightId (SP_Unix m) state = + runSPU m state == runSPU (m >>= return) state + +prop_monadAssoc + :: SP_Unix Int + -> Fun Int (SP_Unix Int) + -> Fun Int (SP_Unix Int) + -> StreamState (Token UnixScheme) + -> Bool +prop_monadAssoc (SP_Unix m) fn1 fn2 state = + runSPU ((m >>= f) >>= g) state == runSPU (m >>= (\x -> f x >>= g)) state + where + f = getSPU . applyFun fn1 + g = getSPU . applyFun fn2 + +-------------------------------------------------------------------------------- + +prop_peek_preservesState + :: StreamState (Token UnixScheme) + -> Bool +prop_peek_preservesState state = + case runSPU peek state of + (_, state') -> state == state' + +prop_pop_preservesContext + :: StreamState (Token UnixScheme) + -> Bool +prop_pop_preservesContext state = + case runSPU pop state of + (_, state') -> streamContext state == streamContext state' + +prop_pop_preservesEscaped + :: StreamState (Token UnixScheme) + -> Bool +prop_pop_preservesEscaped state = + case runSPU pop state of + (_, state') -> streamEscaped state == streamEscaped state' + +prop_yieldsValueOrEmpty + :: SP_Unix_T Text + -> StreamState (Token UnixScheme) + -> Bool +prop_yieldsValueOrEmpty action state = + case runSPU action state of + (SPSuccess a, _) -> listToMaybe (streamContent state) == Just a + (SPEmpty, _) -> null $ streamContent state + _ -> False + +prop_consumesValue + :: SP_Unix_T a + -> StreamState (Token UnixScheme) + -> Bool +prop_consumesValue action state = + case runSPU action state of + (_, state') -> streamContent state' == drop 1 (streamContent state) + +spec :: Spec +spec = do + describe "Functor instance" $ do + prop "satisfies identity law" + prop_functorIdLaw + prop "satisfies composition law" + prop_functorComLaw + + describe "Applicative instance" $ do + prop "satisfies identity law" + prop_applicativeIdLaw + prop "satisfies homomorphism law" + prop_applicativeHomLaw + prop "satisfies interchange law" + prop_applicativeIntLaw + prop "satisfies composition law" + prop_applicativeComLaw + + describe "Monad instance" $ do + prop "satisfies left identity law" + prop_monadLeftId + prop "satisfies right identity law" + prop_monadRightId + prop "satisfies associativity law" + prop_monadAssoc + + describe "peek" $ do + prop "preserves the stream state" + prop_peek_preservesState + prop "yields first value or empty" $ + prop_yieldsValueOrEmpty peek + + describe "pop" $ do + prop "consumes values" $ + prop_consumesValue pop + prop "yields first value or empty" $ + prop_yieldsValueOrEmpty pop + prop "preserves escaped setting" $ + prop_pop_preservesEscaped + prop "preserves the stream state" + prop_pop_preservesContext diff --git a/test/Mangrove/Test/Stream.hs b/test/Mangrove/Test/Stream.hs new file mode 100644 --- /dev/null +++ b/test/Mangrove/Test/Stream.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} + +module Mangrove.Test.Stream + ( -- * Unix Stream Parser + SP_Unix_T + + -- * Stream Proxy + , StreamProxy(..) + , SPState + , SPResult(..) + , toStreamParser + , fromStreamParser + + -- * Unix Stream Parser Wrapper + , SP_Unix(..) + , runSPU + ) where + +import Control.Monad +import Data.Text (Text) +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TLB +import GHC.Generics +import Test.QuickCheck hiding (Result (..)) +import Test.QuickCheck.Instances () + +import Mangrove.Scheme +import Mangrove.Stream +import Mangrove.Token +import Mangrove.Unix + +import Arbitrary () + +type SPState = StreamState (Token UnixScheme) + +data SPResult a + = SPSuccess a + | SPEmpty + | SPFailure Text + | SPRequest UnixRequest + deriving (Eq, Show, Functor, Generic) + +instance Arbitrary a => Arbitrary (SPResult a) where + arbitrary = oneof + [ SPSuccess <$> arbitrary + , pure SPEmpty + , SPFailure <$> arbitrary + , SPRequest <$> arbitrary + ] + +newtype StreamProxy a = SP { runSP :: SPState -> (SPResult a, SPState) } + deriving (Functor, Generic) + +genSP :: Arbitrary a => Gen (StreamProxy a) +genSP = SP <$> arbitrary + +instance Applicative StreamProxy where + pure a = SP $ \state -> (SPSuccess a, state) + (<*>) = ap + +instance Monad StreamProxy where + return = pure + ma >>= f = SP $ \state -> + let (result, state') = runSP ma state + in case result of + SPSuccess a -> runSP (f a) state' + SPEmpty -> (SPEmpty, state') + SPFailure err -> (SPFailure err, state') + SPRequest reqType -> (SPRequest reqType, state') + +toStreamParser :: StreamProxy a -> SP_Unix_T a +toStreamParser prox = StreamParser $ \handler state -> + let (result, state') = runSP prox state + in case result of + SPSuccess a -> onSuccess handler state' a + SPEmpty -> onEmpty handler state' + SPFailure err -> onFailure handler state' (TLB.fromText err) + SPRequest reqType -> onRequest handler state' reqType + +sinkResult :: StreamHandler (Request UnixScheme) (Token UnixScheme) a (SPResult a, SPState) +sinkResult = StreamHandler + { onSuccess = \state' a -> (SPSuccess a, state') + , onEmpty = \state' -> (SPEmpty, state') + , onFailure = \state' err -> (SPFailure (TL.toStrict $ TLB.toLazyText err), state') + , onRequest = \state' req -> (SPRequest req, state') + } + +type SP_Unix_T a = StreamParser (Request UnixScheme) (Token UnixScheme) a + +fromStreamParser :: SP_Unix_T a -> StreamProxy a +fromStreamParser parser = SP $ runStreamParser parser sinkResult + +genStreamParser :: Arbitrary a => Gen (SP_Unix_T a) +genStreamParser = toStreamParser <$> genSP + +newtype SP_Unix a = SP_Unix + { getSPU :: SP_Unix_T a } + +instance Show (SP_Unix a) where + show _ = "(*)" + +instance Arbitrary a => Arbitrary (SP_Unix a) where + arbitrary = SP_Unix <$> genStreamParser + +-------------------------------------------------------------------------------- +-- Stream Helper + +runSPU + :: SP_Unix_T a + -> StreamState (Token UnixScheme) + -> (SPResult a, StreamState (Token UnixScheme)) +runSPU parser = runStreamParser parser sinkResult diff --git a/test/StructureEq.hs b/test/StructureEq.hs new file mode 100644 --- /dev/null +++ b/test/StructureEq.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE GADTs #-} + +module StructureEq + ( StructureEq(..) + ) where + +import Mangrove +import Mangrove.ParseTree +import qualified Mangrove.Scheme.Sub as Sub +import Mangrove.Scheme.Unix +import qualified Mangrove.Scheme.Unix as Unix +import Mangrove.TextParser +import Mangrove.Unix + +-- | Things that can be compared for structural equality. +class StructureEq s where + structEq :: s a -> s b -> Bool + +instance StructureEq TextParser where + structEq tp1 tp2 = parserHint tp1 == parserHint tp2 + +instance StructureEq SubScheme where + structEq (Sub.Parameter p1) (Sub.Parameter p2) = + structEq p1 p2 + structEq (Sub.Option key1 p1) (Sub.Option key2 p2) = + key1 == key2 && structEq p1 p2 + structEq _ _ = + False + +instance StructureEq UnixScheme where + structEq (Unix.Parameter p1) (Unix.Parameter p2) = + structEq p1 p2 + structEq (Unix.Option info1 subtree1) (Unix.Option info2 subtree2) = + info1 == info2 && structEq subtree1 subtree2 + structEq (Unix.Command info1 subtree1) (Unix.Command info2 subtree2) = + info1 == info2 && structEq subtree1 subtree2 + structEq (Unix.RequestOption info1 _) (Unix.RequestOption info2 _) = + info1 == info2 + structEq _ _ = + False + +instance StructureEq s => StructureEq (ParseTree s) where + structEq EmptyNode EmptyNode = + True + structEq (ValueNode _) (ValueNode _) = + True + structEq (ParseNode p1) (ParseNode p2) = + structEq p1 p2 + structEq (ProdNode _ l1 r1) (ProdNode _ l2 r2) = + structEq l1 l2 && structEq r1 r2 + structEq (SumNode l1 r1) (SumNode l2 r2) = + structEq l1 l2 && structEq r1 r2 + structEq (ManyNode b1 p1) (ManyNode b2 p2) = + b1 == b2 && structEq p1 p2 + structEq _ _ = + False + diff --git a/test/TestParsers.hs b/test/TestParsers.hs --- a/test/TestParsers.hs +++ b/test/TestParsers.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-missing-export-lists #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-}