diff --git a/CHANGELOG.md b/CHANGELOG.md index 6335a78..982b7d4 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -27,6 +27,7 @@ Breaking changes: without causing issues with `<$>`. - Rename module prefix from `Text.Parsing.Parser` to `Parsing` (#169 by @jamesdbrock) - Replace the `regex` parser. (#170 by @jamesdbrock) +- Reorganize Combinators for #154 (#182 by @jamesdbrock) New features: diff --git a/bench/Json/Parsing.purs b/bench/Json/Parsing.purs index bb109d1..dec8dd9 100644 --- a/bench/Json/Parsing.purs +++ b/bench/Json/Parsing.purs @@ -10,8 +10,6 @@ import Data.Maybe (Maybe(..)) import Data.Number as Number import Data.String.Regex.Flags (noFlags) import Data.Tuple (Tuple(..)) -import Effect.Exception (throw) -import Effect.Unsafe (unsafePerformEffect) import Parsing (ParserT, fail) import Parsing.Combinators (between, choice, sepBy, try) import Parsing.String (regex, skipSpaces, string) diff --git a/bench/Main.purs b/bench/Main.purs index ca1de5b..7f914c2 100644 --- a/bench/Main.purs +++ b/bench/Main.purs @@ -59,8 +59,7 @@ import Bench.Json.TestData (largeJson, mediumJson) import Data.Array (fold, replicate) import Data.Array as Array import Data.Either (Either(..), either) -import Data.List (many, manyRec) -import Data.List.Types (List) +import Data.List as List import Data.Maybe (Maybe(..)) import Data.String.Regex (Regex, regex) import Data.String.Regex as Regex @@ -69,9 +68,9 @@ import Effect (Effect) import Effect.Console (log) import Effect.Exception (throw) import Effect.Unsafe (unsafePerformEffect) -import Parsing (Parser, runParser) -import Parsing.Combinators (chainl, chainlRec, chainr, chainrRec, manyTill, manyTillRec, manyTillRec_, manyTill_, sepBy, sepByRec, sepEndBy1, sepEndBy1Rec) -import Parsing.String (anyChar, char, eof, string) +import Parsing (runParser) +import Parsing.Combinators (chainl, chainr, many, manyTill, manyTill_, sepBy, sepEndBy1, skipMany) +import Parsing.String (anyChar, eof, string) import Parsing.String.Basic (digit) import Performance.Minibench (benchWith) import StringParser as StringParser @@ -81,36 +80,18 @@ import StringParser.CodeUnits as StringParser.CodeUnits string23 :: String string23 = "23" -string23_10000 :: String -string23_10000 = fold $ replicate 5000 string23 - string23_1000 :: String string23_1000 = fold $ replicate 500 string23 +string23_10000 :: String +string23_10000 = fold $ replicate 5000 string23 + stringSkidoo :: String stringSkidoo = "skidoooooo" stringSkidoo_100000 :: String stringSkidoo_100000 = fold $ replicate 10000 stringSkidoo -parse23 :: Parser String (List Char) -parse23 = many digit - -parse23Points :: StringParser.Parser (List Char) -parse23Points = many StringParser.CodePoints.anyDigit - -parse23Units :: StringParser.Parser (List Char) -parse23Units = many StringParser.CodeUnits.anyDigit - -parse23Rec :: Parser String (List Char) -parse23Rec = manyRec digit - -parse23PointsRec :: StringParser.Parser (List Char) -parse23PointsRec = manyRec StringParser.CodePoints.anyDigit - -parse23UnitsRec :: StringParser.Parser (List Char) -parse23UnitsRec = manyRec StringParser.CodeUnits.anyDigit - pattern23 :: Regex pattern23 = either (unsafePerformEffect <<< throw) identity $ regex "\\d" @@ -123,12 +104,6 @@ pattern23 = either (unsafePerformEffect <<< throw) identity , unicode: true } -parseSkidoo :: Parser String (List String) -parseSkidoo = many $ string "skidoooooo" - -parseSkidooRec :: Parser String (List String) -parseSkidooRec = manyRec $ string "skidoooooo" - patternSkidoo :: Regex patternSkidoo = either (unsafePerformEffect <<< throw) identity $ regex "skidoooooo" @@ -164,81 +139,63 @@ main = do log "

digit 10000

" htmlTableWrap "runParser many digit 10000" $ benchWith 50 - $ \_ -> throwLeft $ runParser string23_10000 parse23 - htmlTableWrap "runParser manyRec digit 10000" $ benchWith 50 - $ \_ -> throwLeft $ runParser string23_10000 parse23Rec + $ \_ -> throwLeft $ runParser string23_10000 (many digit) htmlTableWrap "runParser Array.many digit 10000" $ benchWith 50 $ \_ -> throwLeft $ runParser string23_10000 (Array.many digit) htmlTableWrap "StringParser manyRec CodePoints.anyDigit 10000" $ benchWith 20 - $ \_ -> throwLeft $ StringParser.runParser parse23PointsRec string23_10000 + $ \_ -> throwLeft $ StringParser.runParser (List.manyRec StringParser.CodePoints.anyDigit) string23_10000 htmlTableWrap "StringParser manyRec CodeUnits.anyDigit 10000" $ benchWith 200 - $ \_ -> throwLeft $ StringParser.runParser parse23UnitsRec string23_10000 + $ \_ -> throwLeft $ StringParser.runParser (List.manyRec StringParser.CodeUnits.anyDigit) string23_10000 htmlTableWrap "Regex.match \\d* 10000" $ benchWith 200 $ \_ -> throwNothing "Regex.match failed" $ Regex.match pattern23 string23_10000 log "

string 100000

" htmlTableWrap "runParser many string" $ benchWith 200 - $ \_ -> throwLeft $ runParser stringSkidoo_100000 parseSkidoo - htmlTableWrap "runParser manyRec string" $ benchWith 200 - $ \_ -> throwLeft $ runParser stringSkidoo_100000 parseSkidooRec + $ \_ -> throwLeft $ runParser stringSkidoo_100000 (many $ string "skidoooooo") htmlTableWrap "Regex.match literal*" $ benchWith 200 $ \_ -> throwNothing "Regex.match failed" $ Regex.match patternSkidoo stringSkidoo_100000 - log "

sepBy 1000

" - htmlTableWrap "runParser sepBy 1000" $ benchWith 200 - $ \_ -> throwLeft $ runParser string23_1000 $ sepBy anyChar (pure unit) - htmlTableWrap "runParser sepByRec 1000" $ benchWith 200 - $ \_ -> throwLeft $ runParser string23_1000 $ sepByRec anyChar (pure unit) + log "

many anyChar 10000

" + htmlTableWrap "runParser many anyChar 10000" $ benchWith 50 + $ \_ -> throwLeft $ runParser string23_10000 (many anyChar) + htmlTableWrap "runParser Array.many anyChar 10000" $ benchWith 50 + $ \_ -> throwLeft $ runParser string23_10000 (Array.many anyChar) + + log "

skipMany anyChar 10000

" + htmlTableWrap "runParser skipMany anyChar 10000" $ benchWith 50 + $ \_ -> throwLeft $ runParser string23_10000 (skipMany anyChar) log "

sepBy 10000

" htmlTableWrap "runParser sepBy 10000" $ benchWith 50 $ \_ -> throwLeft $ runParser string23_10000 $ sepBy anyChar (pure unit) - htmlTableWrap "runParser sepByRec 10000" $ benchWith 50 - $ \_ -> throwLeft $ runParser string23_10000 $ sepByRec anyChar (pure unit) log "

sepEndBy1 10000

" htmlTableWrap "runParser sepEndBy1 10000" $ benchWith 50 $ \_ -> throwLeft $ runParser string23_10000 $ sepEndBy1 anyChar (pure unit) - htmlTableWrap "runParser sepEndBy1Rec 10000" $ benchWith 50 - $ \_ -> throwLeft $ runParser string23_10000 $ sepEndBy1Rec anyChar (pure unit) log "

chainl 10000

" htmlTableWrap "runParser chainl 10000" $ benchWith 50 $ \_ -> throwLeft $ runParser string23_10000 $ chainl anyChar (pure const) 'x' - htmlTableWrap "runParser chainlRec 10000" $ benchWith 50 - $ \_ -> throwLeft $ runParser string23_10000 $ chainlRec anyChar (pure const) 'x' log "

chainr 1000

" htmlTableWrap "runParser chainr 1000" $ benchWith 200 $ \_ -> throwLeft $ runParser string23_1000 $ chainr anyChar (pure const) 'x' - htmlTableWrap "runParser chainrRec 1000" $ benchWith 200 - $ \_ -> throwLeft $ runParser string23_1000 $ chainrRec anyChar (pure const) 'x' log "

chainr 10000

" htmlTableWrap "runParser chainr 10000" $ benchWith 50 $ \_ -> throwLeft $ runParser string23_10000 $ chainr anyChar (pure const) 'x' - htmlTableWrap "runParser chainrRec 10000" $ benchWith 50 - $ \_ -> throwLeft $ runParser string23_10000 $ chainrRec anyChar (pure const) 'x' log "

manyTill 1000

" htmlTableWrap "runParser manyTill 1000" $ benchWith 200 $ \_ -> throwLeft $ runParser string23_1000 $ manyTill anyChar eof - htmlTableWrap "runParser manyTillRec 1000" $ benchWith 200 - $ \_ -> throwLeft $ runParser string23_1000 $ manyTillRec anyChar eof htmlTableWrap "runParser manyTill_ 1000" $ benchWith 200 $ \_ -> throwLeft $ runParser string23_1000 $ manyTill_ anyChar eof - htmlTableWrap "runParser manyTillRec_ 1000" $ benchWith 200 - $ \_ -> throwLeft $ runParser string23_1000 $ manyTillRec_ anyChar eof log "

manyTill 10000

" htmlTableWrap "runParser manyTill 10000" $ benchWith 50 $ \_ -> throwLeft $ runParser string23_10000 $ manyTill anyChar eof - htmlTableWrap "runParser manyTillRec 10000" $ benchWith 50 - $ \_ -> throwLeft $ runParser string23_10000 $ manyTillRec anyChar eof htmlTableWrap "runParser manyTill_ 10000" $ benchWith 50 $ \_ -> throwLeft $ runParser string23_10000 $ manyTill_ anyChar eof - htmlTableWrap "runParser manyTillRec_ 10000" $ benchWith 50 - $ \_ -> throwLeft $ runParser string23_10000 $ manyTillRec_ anyChar eof log "

mediumJson

" htmlTableWrap "runParser json mediumJson" $ benchWith 200 diff --git a/spago-dev.dhall b/spago-dev.dhall index 43fcd14..d12fef8 100644 --- a/spago-dev.dhall +++ b/spago-dev.dhall @@ -14,7 +14,6 @@ in conf // , "console" , "enums" , "effect" - , "free" , "psci-support" , "minibench" , "exceptions" diff --git a/src/Parsing/Combinators.purs b/src/Parsing/Combinators.purs index 23b432c..44d193f 100644 --- a/src/Parsing/Combinators.purs +++ b/src/Parsing/Combinators.purs @@ -1,98 +1,81 @@ +-- | ## Combinators +-- | +-- | A parser combinator is a function which takes some +-- | parsers as arguments and returns a new parser. +-- | -- | ## Combinators in other packages -- | -- | Many variations of well-known monadic and applicative combinators used for parsing are --- | defined in other PureScript packages. It’s awkward to re-export --- | them because their names overlap so much, so we list them here. +-- | defined in other PureScript packages. We list some of them here. +-- | +-- | If you use a combinator from some other package for parsing, keep in mind +-- | this surprising truth about the __parsing__ package: +-- | All combinators used with this package will be stack-safe, +-- | but usually the `MonadRec` combinators will run faster. -- | -- | ### Data.Array +-- | +-- | Expect better parsing speed from the `List`-based combinators in this +-- | module than from `Array`-based combinators. +-- | -- | * [Data.Array.many](https://pursuit.purescript.org/packages/purescript-arrays/docs/Data.Array#v:many) -- | * [Data.Array.some](https://pursuit.purescript.org/packages/purescript-arrays/docs/Data.Array#v:some) --- | --- | ### Data.Array.NonEmpty -- | * [Data.Array.NonEmpty.some](https://pursuit.purescript.org/packages/purescript-arrays/docs/Data.Array.NonEmpty#v:some) -- | -- | ### Data.List --- | * [Data.List.many](https://pursuit.purescript.org/packages/purescript-lists/docs/Data.List#v:many) --- | * [Data.List.some](https://pursuit.purescript.org/packages/purescript-lists/docs/Data.List#v:some) --- | * [Data.List.someRec](https://pursuit.purescript.org/packages/purescript-lists/docs/Data.List#v:someRec) --- | * [Data.List.manyRec](https://pursuit.purescript.org/packages/purescript-lists/docs/Data.List#v:manyRec) -- | --- | ### Data.List.NonEmpty --- | * See the __many1__ combinator below. +-- | For good parsing speed we recommend using the `many` and `many1` combinators in this package +-- | to parse a `List`. -- | -- | ### Data.List.Lazy +-- | -- | * [Data.List.Lazy.many](https://pursuit.purescript.org/packages/purescript-lists/docs/Data.List.Lazy#v:many) -- | * [Data.List.Lazy.some](https://pursuit.purescript.org/packages/purescript-lists/docs/Data.List.Lazy#v:some) --- | * [Data.List.Lazy.replicateM](https://pursuit.purescript.org/packages/purescript-lists/docs/Data.List.Lazy#v:replicateM) -- | --- | ## Combinators in this package +-- | ### Data.Unfoldable.replicateA Data.List.Lazy.replicateM -- | --- | A parser combinator is a function which takes some --- | parsers as arguments and returns a new parser. --- | --- | The __many__ combinator applied to parser `p :: Parser s a` will return --- | a parser `many p :: Parser s (Array a)` which will repeat the --- | parser `p` as many times as possible. If `p` never consumes input when it --- | fails then `many p` will always succeed --- | but may return an empty array. --- | --- | The __replicateA n__ combinator applied to parser `p :: Parser s a` will --- | return a parser `replicateA n p :: Parser s (Array a)` which will --- | repeat parser `p` exactly `n` times. `replicateA n p` will only succeed --- | if it can match parser `p` exactly `n` consecutive times. +-- | The __replicateA__ and __replicateM__ combinators are re-exported from +-- | this module. `replicateA n p` or `replicateM n p` +-- | will repeat parser `p` exactly `n` times. The `replicateA` combinator can +-- | produce either an `Array` or a `List`. module Parsing.Combinators - ( () - , () - , (<~?>) - , asErrorMessage - , between - , chainl - , chainl1 - , chainl1Rec - , chainlRec - , chainr - , chainr1 - , chainr1Rec - , chainrRec - , choice - , endBy - , endBy1 - , endBy1Rec - , endByRec + ( try + , tryRethrow , lookAhead + , choice + , between + , notFollowedBy + , option + , optionMaybe + , optional + , many , many1 - , many1Rec , many1Till - , many1TillRec - , many1TillRec_ , many1Till_ , manyTill - , manyTillRec - , manyTillRec_ , manyTill_ - , module Control.Plus - , module Data.Unfoldable - , module Data.Unfoldable1 - , notFollowedBy - , option - , optionMaybe - , optional + , skipMany + , skipMany1 , sepBy , sepBy1 - , sepBy1Rec - , sepByRec , sepEndBy , sepEndBy1 - , sepEndBy1Rec - , sepEndByRec - , skipMany - , skipMany1 - , skipMany1Rec - , skipManyRec - , try - , tryRethrow + , endBy + , endBy1 + , chainl + , chainl1 + , chainr + , chainr1 + , module Control.Plus + , module Data.Unfoldable + , module Data.Unfoldable1 + , module Data.List.Lazy , withErrorMessage + , () , withLazyErrorMessage + , (<~?>) + , asErrorMessage + , () ) where import Prelude @@ -102,7 +85,9 @@ import Control.Monad.Rec.Class (Step(..), tailRecM) import Control.Plus (empty, (<|>), alt) import Data.Foldable (class Foldable, foldl, foldr) import Data.Function.Uncurried (mkFn2, mkFn5, runFn2, runFn5) -import Data.List (List(..), many, manyRec, reverse, (:)) +import Data.List (List(..), reverse, (:)) +import Data.List as List +import Data.List.Lazy (replicateM) import Data.List.NonEmpty (NonEmptyList, cons') import Data.List.NonEmpty as NEL import Data.Maybe (Maybe(..), fromMaybe) @@ -122,7 +107,7 @@ infixl 4 withErrorMessage as -- | in cases where constructing the error message is expensive, so it's -- | preferable to defer it until an error actually happens. -- | --- |```purs +-- |```purescript -- |parseBang :: Parser Char -- |parseBang = char '!' <~?> \_ -> "Expected a bang" -- |``` @@ -157,9 +142,6 @@ option a p = p <|> pure a optional :: forall m s a. ParserT s m a -> ParserT s m Unit optional p = void p <|> pure unit --- TODO Is this optional parser correct? Isn't this parser supposed to succeed --- even if p fails? Otherwise what's the point? I think we need try (void p). - -- | pure `Nothing` in the case where a parser fails without consuming input. optionMaybe :: forall m s a. ParserT s m a -> ParserT s m (Maybe a) optionMaybe p = option Nothing (Just <$> p) @@ -219,15 +201,17 @@ lookAhead (ParserT k1) = ParserT (mkFn2 \_ res -> runFn2 done state1 res) ) --- | Match one or more times. -many1 :: forall m s a. ParserT s m a -> ParserT s m (NonEmptyList a) -many1 p = NEL.cons' <$> p <*> many p +-- | Match the parser `p` as many times as possible. +-- | +-- | If `p` never consumes input when it +-- | fails then `many p` will always succeed, +-- | but may return an empty list. +many :: forall s m a. ParserT s m a -> ParserT s m (List a) +many = List.manyRec -- | Match one or more times. --- | --- | Stack-safe version of `many1` at the expense of a `MonadRec` constraint. -many1Rec :: forall m s a. ParserT s m a -> ParserT s m (NonEmptyList a) -many1Rec p = NEL.cons' <$> p <*> manyRec p +many1 :: forall m s a. ParserT s m a -> ParserT s m (NonEmptyList a) +many1 p = NEL.cons' <$> p <*> List.manyRec p -- | Parse phrases delimited by a separator. -- | @@ -239,53 +223,20 @@ many1Rec p = NEL.cons' <$> p <*> manyRec p sepBy :: forall m s a sep. ParserT s m a -> ParserT s m sep -> ParserT s m (List a) sepBy p sep = map NEL.toList (sepBy1 p sep) <|> pure Nil --- | Parse phrases delimited by a separator. --- | --- | Stack-safe version of `sepBy` at the expense of a `MonadRec` constraint. -sepByRec :: forall m s a sep. ParserT s m a -> ParserT s m sep -> ParserT s m (List a) -sepByRec p sep = map NEL.toList (sepBy1Rec p sep) <|> pure Nil - -- | Parse phrases delimited by a separator, requiring at least one match. sepBy1 :: forall m s a sep. ParserT s m a -> ParserT s m sep -> ParserT s m (NonEmptyList a) sepBy1 p sep = do a <- p - as <- many $ sep *> p - pure (NEL.cons' a as) - --- | Parse phrases delimited by a separator, requiring at least one match. --- | --- | Stack-safe version of `sepBy1` at the expense of a `MonadRec` constraint. -sepBy1Rec :: forall m s a sep. ParserT s m a -> ParserT s m sep -> ParserT s m (NonEmptyList a) -sepBy1Rec p sep = do - a <- p - as <- manyRec $ sep *> p + as <- List.manyRec $ sep *> p pure (NEL.cons' a as) -- | Parse phrases delimited and optionally terminated by a separator. sepEndBy :: forall m s a sep. ParserT s m a -> ParserT s m sep -> ParserT s m (List a) sepEndBy p sep = map NEL.toList (sepEndBy1 p sep) <|> pure Nil --- | Parse phrases delimited and optionally terminated by a separator. --- | --- | Stack-safe version of `sepEndBy` at the expense of a `MonadRec` constraint. -sepEndByRec :: forall m s a sep. ParserT s m a -> ParserT s m sep -> ParserT s m (List a) -sepEndByRec p sep = map NEL.toList (sepEndBy1Rec p sep) <|> pure Nil - -- | Parse phrases delimited and optionally terminated by a separator, requiring at least one match. sepEndBy1 :: forall m s a sep. ParserT s m a -> ParserT s m sep -> ParserT s m (NonEmptyList a) sepEndBy1 p sep = do - a <- p - ( do - _ <- sep - as <- sepEndBy p sep - pure (NEL.cons' a as) - ) <|> pure (NEL.singleton a) - --- | Parse phrases delimited and optionally terminated by a separator, requiring at least one match. --- | --- | Stack-safe version of `sepEndBy1` at the expense of a `MonadRec` constraint. -sepEndBy1Rec :: forall m s a sep. ParserT s m a -> ParserT s m sep -> ParserT s m (NonEmptyList a) -sepEndBy1Rec p sep = do a <- p (NEL.cons' a <$> tailRecM go Nil) <|> pure (NEL.singleton a) where @@ -304,72 +255,28 @@ sepEndBy1Rec p sep = do endBy1 :: forall m s a sep. ParserT s m a -> ParserT s m sep -> ParserT s m (NonEmptyList a) endBy1 p sep = many1 $ p <* sep --- | Parse phrases delimited and terminated by a separator, requiring at least one match. --- | --- | Stack-safe version of `endBy1` at the expense of a `MonadRec` constraint. -endBy1Rec :: forall m s a sep. ParserT s m a -> ParserT s m sep -> ParserT s m (NonEmptyList a) -endBy1Rec p sep = many1Rec $ p <* sep - -- | Parse phrases delimited and terminated by a separator. endBy :: forall m s a sep. ParserT s m a -> ParserT s m sep -> ParserT s m (List a) -endBy p sep = many $ p <* sep +endBy p sep = List.manyRec $ p <* sep --- | Parse phrases delimited and terminated by a separator. +-- | `chainl p f` parses one or more occurrences of `p`, separated by operator `f`. -- | --- | Stack-safe version of `endBy` at the expense of a `MonadRec` constraint. -endByRec :: forall m s a sep. ParserT s m a -> ParserT s m sep -> ParserT s m (List a) -endByRec p sep = manyRec $ p <* sep - --- | Parse phrases delimited by a right-associative operator. --- | --- | For example: --- | --- | ```purescript --- | chainr digit (string "+" $> add) 0 --- | ``` -chainr :: forall m s a. ParserT s m a -> ParserT s m (a -> a -> a) -> a -> ParserT s m a -chainr p f a = chainr1 p f <|> pure a - --- | Parse phrases delimited by a right-associative operator. --- | --- | Stack-safe version of `chainr` at the expense of a `MonadRec` constraint. -chainrRec :: forall m s a. ParserT s m a -> ParserT s m (a -> a -> a) -> a -> ParserT s m a -chainrRec p f a = chainr1Rec p f <|> pure a - --- | Parse phrases delimited by a left-associative operator. +-- | Returns a value +-- | obtained by a left-associative application of the functions returned by +-- | `f` to the values returned by `p`. This combinator can be used to +-- | eliminate left-recursion in expression grammars. -- | -- | For example: -- | -- | ```purescript --- | chainr digit (string "+" $> add) 0 +-- | chainl digit (string "+" $> add) 0 -- | ``` chainl :: forall m s a. ParserT s m a -> ParserT s m (a -> a -> a) -> a -> ParserT s m a chainl p f a = chainl1 p f <|> pure a --- | Parse phrases delimited by a left-associative operator. --- | --- | Stack-safe version of `chainl` at the expense of a `MonadRec` constraint. -chainlRec :: forall m s a. ParserT s m a -> ParserT s m (a -> a -> a) -> a -> ParserT s m a -chainlRec p f a = chainl1Rec p f <|> pure a - --- | Parse phrases delimited by a left-associative operator, requiring at least one match. +-- | `chainl` requiring at least one match. chainl1 :: forall m s a. ParserT s m a -> ParserT s m (a -> a -> a) -> ParserT s m a chainl1 p f = do - a <- p - chainl1' a - where - chainl1' a = - ( do - f' <- f - a' <- p - chainl1' (f' a a') - ) <|> pure a - --- | Parse phrases delimited by a left-associative operator, requiring at least one match. --- | --- | Stack-safe version of `chainl1` at the expense of a `MonadRec` constraint. -chainl1Rec :: forall m s a. ParserT s m a -> ParserT s m (a -> a -> a) -> ParserT s m a -chainl1Rec p f = do a <- p tailRecM go a where @@ -382,24 +289,24 @@ chainl1Rec p f = do ) <|> pure (Done a) --- | Parse phrases delimited by a right-associative operator, requiring at least one match. +-- | `chainr p f` parses one or more occurrences of `p`, separated by operator `f`. +-- | +-- | Returns a value +-- | obtained by a right-associative application of the functions returned by +-- | `f` to the values returned by `p`. This combinator can be used to +-- | eliminate right-recursion in expression grammars. +-- | +-- | For example: +-- | +-- | ```purescript +-- | chainr digit (string "+" $> add) 0 +-- | ``` +chainr :: forall m s a. ParserT s m a -> ParserT s m (a -> a -> a) -> a -> ParserT s m a +chainr p f a = chainr1 p f <|> pure a + +-- | `chainr` requiring at least one match. chainr1 :: forall m s a. ParserT s m a -> ParserT s m (a -> a -> a) -> ParserT s m a chainr1 p f = do - a <- p - chainr1' a - where - chainr1' a = - ( do - f' <- f - a' <- chainr1 p f - pure $ f' a a' - ) <|> pure a - --- | Parse phrases delimited by a right-associative operator, requiring at least one match. --- | --- | Stack-safe version of `chainr1` at the expense of a `MonadRec` constraint. -chainr1Rec :: forall m s a. ParserT s m a -> ParserT s m (a -> a -> a) -> ParserT s m a -chainr1Rec p f = do a <- p tailRecM go { last: a, init: Nil } where @@ -435,7 +342,7 @@ chainr1Rec p f = do a <- p pure $ Loop { last: a, init: (last /\ op) : init } ) - <|> pure (Done $ foldl apply last init) + <|> defer \_ -> pure (Done $ foldl apply last init) apply :: a -> (a /\ (a -> a -> a)) -> a apply y (x /\ op) = x `op` y @@ -452,24 +359,9 @@ choice = fromMaybe empty <<< foldr go Nothing skipMany :: forall s a m. ParserT s m a -> ParserT s m Unit skipMany p = skipMany1 p <|> pure unit --- | Skip many instances of a phrase. --- | --- | Stack-safe version of `skipMany` at the expense of a `MonadRec` constraint. -skipManyRec :: forall s a m. ParserT s m a -> ParserT s m Unit -skipManyRec p = skipMany1Rec p <|> pure unit - -- | Skip at least one instance of a phrase. skipMany1 :: forall s a m. ParserT s m a -> ParserT s m Unit -skipMany1 p = do - _ <- p - _ <- skipMany p - pure unit - --- | Skip at least one instance of a phrase. --- | --- | Stack-safe version of `skipMany1` at the expense of a `MonadRec` constraint. -skipMany1Rec :: forall s a m. ParserT s m a -> ParserT s m Unit -skipMany1Rec p = p *> tailRecM go unit +skipMany1 p = p *> tailRecM go unit where go _ = (p $> Loop unit) <|> pure (Done unit) @@ -481,18 +373,7 @@ notFollowedBy p = try $ (try p *> fail "Negated parser succeeded") <|> pure unit -- | Parse many phrases until the terminator phrase matches. manyTill :: forall s a m e. ParserT s m a -> ParserT s m e -> ParserT s m (List a) -manyTill p end = scan - where - scan = (end $> Nil) <|> do - x <- p - xs <- scan - pure (x : xs) - --- | Parse many phrases until the terminator phrase matches. --- | --- | Stack-safe version of `manyTill` at the expense of a `MonadRec` constraint. -manyTillRec :: forall s a m e. ParserT s m a -> ParserT s m e -> ParserT s m (List a) -manyTillRec p end = tailRecM go Nil +manyTill p end = tailRecM go Nil where go :: List a -> ParserT s m (Step (List a) (List a)) go acc = @@ -501,16 +382,15 @@ manyTillRec p end = tailRecM go Nil -- | Parse at least one phrase until the terminator phrase matches. many1Till :: forall s a m e. ParserT s m a -> ParserT s m e -> ParserT s m (NonEmptyList a) -many1Till p end = do - x <- p - xs <- manyTill p end - pure (NEL.cons' x xs) +many1Till p end = NEL.cons' <$> p <*> manyTill p end --- | Parse at least one phrase until the terminator phrase matches. --- | --- | Stack-safe version of `many1Till` at the expense of a `MonadRec` constraint. -many1TillRec :: forall s a m e. ParserT s m a -> ParserT s m e -> ParserT s m (NonEmptyList a) -many1TillRec p end = NEL.cons' <$> p <*> manyTillRec p end +-- | Parse many phrases until the terminator phrase matches, requiring at least one match. +-- | Returns the list of phrases and the terminator phrase. +many1Till_ :: forall s a m e. ParserT s m a -> ParserT s m e -> ParserT s m (Tuple (NonEmptyList a) e) +many1Till_ p end = do + x <- p + Tuple xs t <- manyTill_ p end + pure $ Tuple (cons' x xs) t -- | Parse many phrases until the terminator phrase matches. -- | Returns the list of phrases and the terminator phrase. @@ -548,32 +428,7 @@ many1TillRec p end = NEL.cons' <$> p <*> manyTillRec p end -- | (Tuple ('a' : 'a' : Nil) 'b') -- | ``` manyTill_ :: forall s a m e. ParserT s m a -> ParserT s m e -> ParserT s m (Tuple (List a) e) -manyTill_ p end = scan - where - scan = - do - t <- end - pure $ Tuple Nil t - <|> - do - x <- p - Tuple xs t <- scan - pure $ Tuple (x : xs) t - --- | Parse many phrases until the terminator phrase matches, requiring at least one match. --- | Returns the list of phrases and the terminator phrase. -many1Till_ :: forall s a m e. ParserT s m a -> ParserT s m e -> ParserT s m (Tuple (NonEmptyList a) e) -many1Till_ p end = do - x <- p - Tuple xs t <- manyTill_ p end - pure $ Tuple (cons' x xs) t - --- | Parse many phrases until the terminator phrase matches. --- | Returns the list of phrases and the terminator phrase. --- | --- | Stack-safe version of `manyTill_` at the expense of a `MonadRec` constraint. -manyTillRec_ :: forall s a m e. ParserT s m a -> ParserT s m e -> ParserT s m (Tuple (List a) e) -manyTillRec_ p end = tailRecM go Nil +manyTill_ p end = tailRecM go Nil where go :: List a -> ParserT s m (Step (List a) (Tuple (List a) e)) go xs = @@ -584,13 +439,3 @@ manyTillRec_ p end = tailRecM go Nil do x <- p pure (Loop (x : xs)) - --- | Parse many phrases until the terminator phrase matches, requiring at least one match. --- | Returns the list of phrases and the terminator phrase. --- | --- | Stack-safe version of `many1Till_` at the expense of a `MonadRec` constraint. -many1TillRec_ :: forall s a m e. ParserT s m a -> ParserT s m e -> ParserT s m (Tuple (NonEmptyList a) e) -many1TillRec_ p end = do - x <- p - Tuple xs t <- manyTillRec_ p end - pure $ Tuple (cons' x xs) t diff --git a/test/Main.purs b/test/Main.purs index bd9ebb1..f8a5ac2 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -25,10 +25,8 @@ import Data.String.Regex.Flags (RegexFlags, ignoreCase, noFlags) import Data.Tuple (Tuple(..)) import Effect (Effect) import Effect.Console (log, logShow) -import Partial.Unsafe (unsafePartial) -import Test.Assert (assert') import Parsing (ParseError(..), Parser, ParserT, fail, parseErrorMessage, parseErrorPosition, position, region, runParser) -import Parsing.Combinators (between, chainl, chainl1Rec, chainlRec, chainr1Rec, chainrRec, choice, endBy1, endBy1Rec, endByRec, many1Rec, many1TillRec, many1TillRec_, many1Till_, manyTillRec, manyTillRec_, manyTill_, notFollowedBy, optionMaybe, sepBy1, sepBy1Rec, sepByRec, sepEndBy1Rec, sepEndByRec, skipMany1Rec, skipManyRec, try, (), (), (<~?>)) +import Parsing.Combinators (between, chainl, chainl1, chainr, chainr1, choice, endBy, endBy1, many1, many1Till, many1Till_, manyTill, manyTill_, notFollowedBy, optionMaybe, sepBy, sepBy1, sepEndBy, sepEndBy1, skipMany, skipMany1, try, (), (), (<~?>)) import Parsing.Expr (Assoc(..), Operator(..), buildExprParser) import Parsing.Language (haskellDef, haskellStyle, javaStyle) import Parsing.Pos (Position(..), initialPos) @@ -36,6 +34,8 @@ import Parsing.String (anyChar, anyCodePoint, char, eof, regex, noneOfCodePoints import Parsing.String.Basic (intDecimal, number, letter) import Parsing.Token (TokenParser, makeTokenParser, match, token, when) import Parsing.Token as Parser.Token +import Partial.Unsafe (unsafePartial) +import Test.Assert (assert') parens :: forall m a. ParserT String m a -> ParserT String m a parens = between (string "(") (string ")") @@ -106,8 +106,6 @@ mkRegexTest input expected pattern flags pars = Left err -> assert' ("error: " <> show err) false Right p -> parseTest input expected $ pars p --- TODO everything is stack-safe now. --- -- This test doesn't test the actual stack safety of these combinators, mainly -- because I don't know how to come up with an example guaranteed to be large -- enough to overflow the stack. But thankfully, their stack safety is more or @@ -119,112 +117,112 @@ mkRegexTest input expected pattern flags pars = stackSafeLoopsTest :: TestM stackSafeLoopsTest = do parseTest "aaabaa" (toUnfoldable [ "a", "a", "a" ]) $ - manyTillRec (string "a") (string "b") + manyTill (string "a") (string "b") parseTest "baa" Nil $ - manyTillRec (string "a") (string "b") + manyTill (string "a") (string "b") parseTest "aaabaa" (NE.cons' "a" $ toUnfoldable [ "a", "a" ]) $ - many1TillRec (string "a") (string "b") + many1Till (string "a") (string "b") parseErrorTestPosition - (many1TillRec (string "a") (string "b")) + (many1Till (string "a") (string "b")) "baa" (Position { line: 1, column: 1 }) parseTest "a,a,a,b,a,a" (toUnfoldable [ "a", "a", "a" ]) $ - sepEndByRec (string "a") (string ",") + sepEndBy (string "a") (string ",") parseTest "a,a,abaa" (toUnfoldable [ "a", "a", "a" ]) $ - sepEndByRec (string "a") (string ",") + sepEndBy (string "a") (string ",") parseTest "b,a,a" Nil $ - sepEndByRec (string "a") (string ",") + sepEndBy (string "a") (string ",") parseTest "a,a,a,b,a,a" (NE.cons' "a" $ toUnfoldable [ "a", "a" ]) $ - sepEndBy1Rec (string "a") (string ",") + sepEndBy1 (string "a") (string ",") parseTest "a,a,abaa" (NE.cons' "a" $ toUnfoldable [ "a", "a" ]) $ - sepEndBy1Rec (string "a") (string ",") + sepEndBy1 (string "a") (string ",") parseErrorTestPosition - (sepEndBy1Rec (string "a") (string ",")) + (sepEndBy1 (string "a") (string ",")) "b,a,a" (Position { line: 1, column: 1 }) -- 8 `div` (8 `div` 2) == 2 parseTest "8x8x2" 2 $ - chainrRec digit (string "x" $> div) 42 + chainr digit (string "x" $> div) 42 parseTest "" 42 $ - chainrRec digit (string "x" $> div) 42 + chainr digit (string "x" $> div) 42 parseTest "8x8x2" 2 $ - chainr1Rec digit (string "x" $> div) + chainr1 digit (string "x" $> div) parseErrorTestPosition - (chainr1Rec digit (string "x" $> div)) + (chainr1 digit (string "x" $> div)) "" (Position { line: 1, column: 1 }) -- (8 `div` 2) `div` 2 == 2 parseTest "8x2x2" 2 $ - chainlRec digit (string "x" $> div) 42 + chainl digit (string "x" $> div) 42 parseTest "" 42 $ - chainlRec digit (string "x" $> div) 42 + chainl digit (string "x" $> div) 42 parseTest "8x2x2" 2 $ - chainl1Rec digit (string "x" $> div) + chainl1 digit (string "x" $> div) parseErrorTestPosition - (chainl1Rec digit (string "x" $> div)) + (chainl1 digit (string "x" $> div)) "" (Position { line: 1, column: 1 }) parseTest "aaaabcd" "b" - $ skipMany1Rec (string "a") + $ skipMany1 (string "a") *> string "b" parseErrorTestPosition - (skipMany1Rec (string "a")) + (skipMany1 (string "a")) "bcd" (Position { line: 1, column: 1 }) parseTest "aaaabcd" "b" - $ skipManyRec (string "a") + $ skipMany (string "a") *> string "b" parseTest "bcd" "b" - $ skipManyRec (string "a") + $ skipMany (string "a") *> string "b" parseTest "aaa" (NE.cons' "a" $ toUnfoldable [ "a", "a" ]) $ - many1Rec (string "a") + many1 (string "a") parseErrorTestPosition - (many1Rec (string "a")) + (many1 (string "a")) "" (Position { line: 1, column: 1 }) parseTest "a,a,ab" (toUnfoldable [ "a", "a", "a" ]) - $ sepByRec (string "a") (string ",") + $ sepBy (string "a") (string ",") <* string "b" parseTest "b" Nil - $ sepByRec (string "a") (string ",") + $ sepBy (string "a") (string ",") <* string "b" parseTest "a,a,ab" (NE.cons' "a" $ toUnfoldable [ "a", "a" ]) - $ sepBy1Rec (string "a") (string ",") + $ sepBy1 (string "a") (string ",") <* string "b" parseErrorTestPosition - (sepBy1Rec (string "a") (string ",")) + (sepBy1 (string "a") (string ",")) "" (Position { line: 1, column: 1 }) parseErrorTestPosition - (sepBy1Rec (string "a") (string ",")) + (sepBy1 (string "a") (string ",")) "a," (Position { line: 1, column: 3 }) parseTest "a,a,a,b" (toUnfoldable [ "a", "a", "a" ]) - $ endByRec (string "a") (string ",") + $ endBy (string "a") (string ",") <* string "b" parseTest "b" Nil - $ endByRec (string "a") (string ",") + $ endBy (string "a") (string ",") <* string "b" parseTest "a,a,a,b" (NE.cons' "a" $ toUnfoldable [ "a", "a" ]) - $ endBy1Rec (string "a") (string ",") + $ endBy1 (string "a") (string ",") <* string "b" parseErrorTestPosition - (endBy1Rec (string "a") (string ",")) + (endBy1 (string "a") (string ",")) "" (Position { line: 1, column: 1 }) parseErrorTestPosition - (endBy1Rec (string "a") (string ",")) + (endBy1 (string "a") (string ",")) "a,a" (Position { line: 1, column: 4 }) @@ -666,8 +664,6 @@ main = do parseTest "aabb" (Tuple (fromFoldable [ 'a', 'a' ]) 'b') (manyTill_ (char 'a') (char 'b')) parseTest "aabb" (Tuple (unsafePartial $ fromJust (NE.fromFoldable [ 'a', 'a' ])) 'b') (many1Till_ (char 'a') (char 'b')) - parseTest "aabb" (Tuple (fromFoldable [ 'a', 'a' ]) 'b') (manyTillRec_ (char 'a') (char 'b')) - parseTest "aabb" (Tuple (unsafePartial $ fromJust (NE.fromFoldable [ 'a', 'a' ])) 'b') (many1TillRec_ (char 'a') (char 'b')) parseTest "aab" (Tuple (fromFoldable [ 'a', 'a' ]) 'b') do Tuple a b <- manyTill_ letter do