Skip to content

Commit 22829f5

Browse files
authored
Merge pull request #131 from fsoikin/rec-combinators
More stack-safe combinators
2 parents a2d8a60 + fe33540 commit 22829f5

File tree

3 files changed

+205
-21
lines changed

3 files changed

+205
-21
lines changed

CHANGELOG.md

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,13 @@ Notable changes to this project are documented in this file. The format is based
44

55
## [Unreleased]
66

7+
New features:
8+
9+
- Added more stack-safe (at the expense of `MonadRec` constraint) combinators
10+
`many1Rec`, `sepByRec`, `sepBy1Rec`, `endByRec`, `endBy1Rec`, `chainrRec`,
11+
`chainr1Rec`, `chainlRec`, `chainl1Rec`, `skipManyRec`, and `skipMany1Rec`.
12+
(#131 by @fsoikin)
13+
714
## [v7.2.0](https://github.com/purescript-contrib/purescript-parsing/releases/tag/v7.2.0) - 2022-01-07
815

916
New features:

src/Text/Parsing/Parser/Combinators.purs

Lines changed: 124 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -31,12 +31,13 @@ import Control.Monad.State (StateT(..), runStateT)
3131
import Control.Plus (empty, (<|>))
3232
import Data.Either (Either(..))
3333
import Data.Foldable (class Foldable, foldl)
34-
import Data.List (List(..), many, reverse, (:))
34+
import Data.List (List(..), many, manyRec, reverse, (:))
3535
import Data.List.NonEmpty (NonEmptyList)
3636
import Data.List.NonEmpty as NEL
3737
import Data.Maybe (Maybe(..))
3838
import Data.Newtype (unwrap)
3939
import Data.Tuple (Tuple(..))
40+
import Data.Tuple.Nested (type (/\), (/\))
4041
import Text.Parsing.Parser (ParseError(..), ParseState(..), ParserT(..), fail)
4142

4243
-- | Provide an error message in the case of failure.
@@ -112,6 +113,10 @@ lookAhead p = (ParserT <<< ExceptT <<< StateT) \s -> do
112113
many1 :: forall m s a. Monad m => ParserT s m a -> ParserT s m (NonEmptyList a)
113114
many1 p = NEL.cons' <$> p <*> many p
114115

116+
-- | Stack-safe version of `many1` at the expense of `MonadRec` constraint
117+
many1Rec :: forall m s a. MonadRec m => ParserT s m a -> ParserT s m (NonEmptyList a)
118+
many1Rec p = NEL.cons' <$> p <*> manyRec p
119+
115120
-- | Parse phrases delimited by a separator.
116121
-- |
117122
-- | For example:
@@ -122,13 +127,24 @@ many1 p = NEL.cons' <$> p <*> many p
122127
sepBy :: forall m s a sep. Monad m => ParserT s m a -> ParserT s m sep -> ParserT s m (List a)
123128
sepBy p sep = map NEL.toList (sepBy1 p sep) <|> pure Nil
124129

130+
-- | Stack-safe version of `sepBy` at the expense of `MonadRec` constraint
131+
sepByRec :: forall m s a sep. MonadRec m => ParserT s m a -> ParserT s m sep -> ParserT s m (List a)
132+
sepByRec p sep = map NEL.toList (sepBy1Rec p sep) <|> pure Nil
133+
125134
-- | Parse phrases delimited by a separator, requiring at least one match.
126135
sepBy1 :: forall m s a sep. Monad m => ParserT s m a -> ParserT s m sep -> ParserT s m (NonEmptyList a)
127136
sepBy1 p sep = do
128137
a <- p
129138
as <- many $ sep *> p
130139
pure (NEL.cons' a as)
131140

141+
-- | Stack-safe version of `sepBy1` at the expense of `MonadRec` constraint
142+
sepBy1Rec :: forall m s a sep. MonadRec m => ParserT s m a -> ParserT s m sep -> ParserT s m (NonEmptyList a)
143+
sepBy1Rec p sep = do
144+
a <- p
145+
as <- manyRec $ sep *> p
146+
pure (NEL.cons' a as)
147+
132148
-- | Parse phrases delimited and optionally terminated by a separator.
133149
sepEndBy :: forall m s a sep. Monad m => ParserT s m a -> ParserT s m sep -> ParserT s m (List a)
134150
sepEndBy p sep = map NEL.toList (sepEndBy1 p sep) <|> pure Nil
@@ -168,51 +184,129 @@ sepEndBy1Rec p sep = do
168184
endBy1 :: forall m s a sep. Monad m => ParserT s m a -> ParserT s m sep -> ParserT s m (NonEmptyList a)
169185
endBy1 p sep = many1 $ p <* sep
170186

187+
-- | Stack-safe version of `endBy1` at the expense of `MonadRec` constraint
188+
endBy1Rec :: forall m s a sep. MonadRec m => ParserT s m a -> ParserT s m sep -> ParserT s m (NonEmptyList a)
189+
endBy1Rec p sep = many1Rec $ p <* sep
190+
171191
-- | Parse phrases delimited and terminated by a separator.
172192
endBy :: forall m s a sep. Monad m => ParserT s m a -> ParserT s m sep -> ParserT s m (List a)
173193
endBy p sep = many $ p <* sep
174194

195+
-- | Stack-safe version of `endBy` at the expense of `MonadRec` constraint
196+
endByRec :: forall m s a sep. MonadRec m => ParserT s m a -> ParserT s m sep -> ParserT s m (List a)
197+
endByRec p sep = manyRec $ p <* sep
198+
175199
-- | Parse phrases delimited by a right-associative operator.
176200
-- |
177201
-- | For example:
178202
-- |
179203
-- | ```purescript
180-
-- | chainr digit (string "+" *> add) 0
204+
-- | chainr digit (string "+" $> add) 0
181205
-- | ```
182206
chainr :: forall m s a. Monad m => ParserT s m a -> ParserT s m (a -> a -> a) -> a -> ParserT s m a
183207
chainr p f a = chainr1 p f <|> pure a
184208

209+
-- | Stack-safe version of `chainr` at the expense of `MonadRec` constraint.
210+
chainrRec :: forall m s a. MonadRec m => ParserT s m a -> ParserT s m (a -> a -> a) -> a -> ParserT s m a
211+
chainrRec p f a = chainr1Rec p f <|> pure a
212+
185213
-- | Parse phrases delimited by a left-associative operator.
214+
-- |
215+
-- | For example:
216+
-- |
217+
-- | ```purescript
218+
-- | chainr digit (string "+" $> add) 0
219+
-- | ```
186220
chainl :: forall m s a. Monad m => ParserT s m a -> ParserT s m (a -> a -> a) -> a -> ParserT s m a
187221
chainl p f a = chainl1 p f <|> pure a
188222

223+
-- | Stack-safe version of `chainl` at the expense of `MonadRec` constraint.
224+
chainlRec :: forall m s a. MonadRec m => ParserT s m a -> ParserT s m (a -> a -> a) -> a -> ParserT s m a
225+
chainlRec p f a = chainl1Rec p f <|> pure a
226+
189227
-- | Parse phrases delimited by a left-associative operator, requiring at least one match.
190228
chainl1 :: forall m s a. Monad m => ParserT s m a -> ParserT s m (a -> a -> a) -> ParserT s m a
191229
chainl1 p f = do
192230
a <- p
193-
chainl1' p f a
194-
195-
chainl1' :: forall m s a. Monad m => ParserT s m a -> ParserT s m (a -> a -> a) -> a -> ParserT s m a
196-
chainl1' p f a =
197-
( do
198-
f' <- f
199-
a' <- p
200-
chainl1' p f (f' a a')
201-
) <|> pure a
231+
chainl1' a
232+
where
233+
chainl1' a =
234+
( do
235+
f' <- f
236+
a' <- p
237+
chainl1' (f' a a')
238+
) <|> pure a
239+
240+
-- | Stack-safe version of `chainl1` at the expense of `MonadRec` constraint.
241+
chainl1Rec :: forall m s a. MonadRec m => ParserT s m a -> ParserT s m (a -> a -> a) -> ParserT s m a
242+
chainl1Rec p f = do
243+
a <- p
244+
tailRecM go a
245+
where
246+
go :: a -> ParserT s m (Step a a)
247+
go a =
248+
( do
249+
op <- f
250+
a' <- p
251+
pure $ Loop $ op a a'
252+
)
253+
<|> pure (Done a)
202254

203255
-- | Parse phrases delimited by a right-associative operator, requiring at least one match.
204256
chainr1 :: forall m s a. Monad m => ParserT s m a -> ParserT s m (a -> a -> a) -> ParserT s m a
205257
chainr1 p f = do
206258
a <- p
207-
chainr1' p f a
208-
209-
chainr1' :: forall m s a. Monad m => ParserT s m a -> ParserT s m (a -> a -> a) -> a -> ParserT s m a
210-
chainr1' p f a =
211-
( do
212-
f' <- f
213-
a' <- chainr1 p f
214-
pure $ f' a a'
215-
) <|> pure a
259+
chainr1' a
260+
where
261+
chainr1' a =
262+
( do
263+
f' <- f
264+
a' <- chainr1 p f
265+
pure $ f' a a'
266+
) <|> pure a
267+
268+
-- | Stack-safe version of `chainr1` at the expense of `MonadRec` constraint.
269+
chainr1Rec :: forall m s a. MonadRec m => ParserT s m a -> ParserT s m (a -> a -> a) -> ParserT s m a
270+
chainr1Rec p f = do
271+
a <- p
272+
tailRecM go { last: a, init: Nil }
273+
where
274+
-- This looks scary at first glance, so I'm leaving a comment in a vain
275+
-- attempt to explain how it works.
276+
--
277+
-- The loop state is a record {init, last}, where `last` is the last (i.e.
278+
-- rightmost) `a` value that has been parsed so far, and `init` is a list of
279+
-- (value + operator) pairs that have been parsed before that.
280+
--
281+
-- The very first value is parsed at top level, and it becomes the initial
282+
-- value of `last`, while the initial value of `init` is just `Nil`,
283+
-- indicating that no pairs of (value + operator) have been parsed yet.
284+
--
285+
-- At every step, we parse an operator and a value, and then the newly parsed
286+
-- value becomes `last` (because, well, it's been parsed last), and the pair
287+
-- of (previous last + operator) is prepended to `init`.
288+
--
289+
-- After we can no longer parse a pair of (value + operation), we're done. At
290+
-- that point, we have a list of (value + operation) pairs in reverse order
291+
-- (since we prepend each pair as we go) and the very last value. All that's
292+
-- left is combine them all via `foldl`.
293+
go
294+
:: { init :: List (a /\ (a -> a -> a)), last :: a }
295+
-> ParserT s m
296+
( Step
297+
{ init :: List (a /\ (a -> a -> a)), last :: a }
298+
a
299+
)
300+
go { last, init } =
301+
( do
302+
op <- f
303+
a <- p
304+
pure $ Loop { last: a, init: (last /\ op) : init }
305+
)
306+
<|> pure (Done $ foldl apply last init)
307+
308+
apply :: a -> (a /\ (a -> a -> a)) -> a
309+
apply y (x /\ op) = x `op` y
216310

217311
-- | Parse one of a set of alternatives.
218312
choice :: forall f m s a. Foldable f => Monad m => f (ParserT s m a) -> ParserT s m a
@@ -222,13 +316,23 @@ choice = foldl (<|>) empty
222316
skipMany :: forall s a m. Monad m => ParserT s m a -> ParserT s m Unit
223317
skipMany p = skipMany1 p <|> pure unit
224318

319+
-- | Stack-safe version of `skipMany` at the expense of `MonadRec` constraint.
320+
skipManyRec :: forall s a m. MonadRec m => ParserT s m a -> ParserT s m Unit
321+
skipManyRec p = skipMany1Rec p <|> pure unit
322+
225323
-- | Skip at least one instance of a phrase.
226324
skipMany1 :: forall s a m. Monad m => ParserT s m a -> ParserT s m Unit
227325
skipMany1 p = do
228326
_ <- p
229327
_ <- skipMany p
230328
pure unit
231329

330+
-- | Stack-safe version of `skipMany1` at the expense of `MonadRec` constraint.
331+
skipMany1Rec :: forall s a m. MonadRec m => ParserT s m a -> ParserT s m Unit
332+
skipMany1Rec p = p *> tailRecM go unit
333+
where
334+
go _ = (p $> Loop unit) <|> pure (Done unit)
335+
232336
-- | Fail if the specified parser matches.
233337
notFollowedBy :: forall s a m. Monad m => ParserT s m a -> ParserT s m Unit
234338
notFollowedBy p = try $ (try p *> fail "Negated parser succeeded") <|> pure unit

test/Main.purs

Lines changed: 74 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -19,7 +19,7 @@ import Effect (Effect)
1919
import Effect.Console (logShow)
2020
import Test.Assert (assert')
2121
import Text.Parsing.Parser (ParseError(..), Parser, ParserT, parseErrorMessage, parseErrorPosition, region, runParser)
22-
import Text.Parsing.Parser.Combinators (between, chainl, endBy1, many1TillRec, manyTillRec, optionMaybe, sepBy1, sepEndBy1Rec, sepEndByRec, try)
22+
import Text.Parsing.Parser.Combinators (between, chainl, chainl1Rec, chainlRec, chainr1Rec, chainrRec, endBy1, endBy1Rec, endByRec, many1Rec, many1TillRec, manyTillRec, optionMaybe, sepBy1, sepBy1Rec, sepByRec, sepEndBy1Rec, sepEndByRec, skipMany1Rec, skipManyRec, try)
2323
import Text.Parsing.Parser.Expr (Assoc(..), Operator(..), buildExprParser)
2424
import Text.Parsing.Parser.Language (haskellDef, haskellStyle, javaStyle)
2525
import Text.Parsing.Parser.Pos (Position(..), initialPos)
@@ -127,6 +127,79 @@ stackSafeLoopsTest = do
127127
"b,a,a"
128128
(Position { line: 1, column: 1 })
129129

130+
-- 8 `div` (8 `div` 2) == 2
131+
parseTest "8x8x2" 2 $
132+
chainrRec digit (string "x" $> div) 42
133+
parseTest "" 42 $
134+
chainrRec digit (string "x" $> div) 42
135+
parseTest "8x8x2" 2 $
136+
chainr1Rec digit (string "x" $> div)
137+
parseErrorTestPosition
138+
(chainr1Rec digit (string "x" $> div))
139+
""
140+
(Position { line: 1, column: 1 })
141+
142+
-- (8 `div` 2) `div` 2 == 2
143+
parseTest "8x2x2" 2 $
144+
chainlRec digit (string "x" $> div) 42
145+
parseTest "" 42 $
146+
chainlRec digit (string "x" $> div) 42
147+
parseTest "8x2x2" 2 $
148+
chainl1Rec digit (string "x" $> div)
149+
parseErrorTestPosition
150+
(chainl1Rec digit (string "x" $> div))
151+
""
152+
(Position { line: 1, column: 1 })
153+
154+
parseTest "aaaabcd" "b" $
155+
skipMany1Rec (string "a") *> string "b"
156+
parseErrorTestPosition
157+
(skipMany1Rec (string "a"))
158+
"bcd"
159+
(Position { line: 1, column: 1 })
160+
161+
parseTest "aaaabcd" "b" $
162+
skipManyRec (string "a") *> string "b"
163+
parseTest "bcd" "b" $
164+
skipManyRec (string "a") *> string "b"
165+
166+
parseTest "aaa" (NE.cons' "a" $ toUnfoldable [ "a", "a" ]) $
167+
many1Rec (string "a")
168+
parseErrorTestPosition
169+
(many1Rec (string "a"))
170+
""
171+
(Position { line: 1, column: 1 })
172+
173+
parseTest "a,a,ab" (toUnfoldable [ "a", "a", "a" ]) $
174+
sepByRec (string "a") (string ",") <* string "b"
175+
parseTest "b" Nil $
176+
sepByRec (string "a") (string ",") <* string "b"
177+
parseTest "a,a,ab" (NE.cons' "a" $ toUnfoldable [ "a", "a" ]) $
178+
sepBy1Rec (string "a") (string ",") <* string "b"
179+
parseErrorTestPosition
180+
(sepBy1Rec (string "a") (string ","))
181+
""
182+
(Position { line: 1, column: 1 })
183+
parseErrorTestPosition
184+
(sepBy1Rec (string "a") (string ","))
185+
"a,"
186+
(Position { line: 1, column: 3 })
187+
188+
parseTest "a,a,a,b" (toUnfoldable [ "a", "a", "a" ]) $
189+
endByRec (string "a") (string ",") <* string "b"
190+
parseTest "b" Nil $
191+
endByRec (string "a") (string ",") <* string "b"
192+
parseTest "a,a,a,b" (NE.cons' "a" $ toUnfoldable [ "a", "a" ]) $
193+
endBy1Rec (string "a") (string ",") <* string "b"
194+
parseErrorTestPosition
195+
(endBy1Rec (string "a") (string ","))
196+
""
197+
(Position { line: 1, column: 1 })
198+
parseErrorTestPosition
199+
(endBy1Rec (string "a") (string ","))
200+
"a,a"
201+
(Position { line: 1, column: 4 })
202+
130203
data TestToken = A | B
131204

132205
instance showTestTokens :: Show TestToken where

0 commit comments

Comments
 (0)