@@ -1,4 +1,5 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
23
34-- Somehow uni-pattern match using "let" produces better optimized code
45-- compared to using cases and using explicit "error" messages in unreachable
@@ -25,37 +26,52 @@
2526
2627module Streamly.Internal.Data.Parser.Tee
2728 (
28− -- Parallel parsers
29+ -- Parallel zipped
2930 teeWith
3031 , teeWithFst
3132 , teeWithMin
33+
34+ -- Parallel alternatives
35+ , shortest
36+ , longest
3237 )
3338where
3439
3540import Control.Exception (assert)
41+import Control.Monad.Catch (MonadCatch, try)
3642import Prelude
3743 hiding (any, all, takeWhile)
3844
3945import Fusion.Plugin.Types (Fuse(..))
40−import Streamly.Internal.Data.Parser.Types (Parser(..), Step(..))
46+import Streamly.Internal.Data.Parser.Types (Parser(..), Step(..), ParseError)
4147
4248-------------------------------------------------------------------------------
43−-- Distributing Parsers
49+-- Distribute input to two parsers and collect both results
4450-------------------------------------------------------------------------------
4551
4652data StepState s a = StepState s | StepResult a
4753
54+-- XXX Use a Zipper structure for buffering?
55+--
4856-- | State of the pair of parsers in a tee composition
4957-- Note: strictness annotation is important for fusing the constructors
5058{-# ANN type TeeState Fuse #-}
5159data TeeState sL sR x a b =
60+-- @TeePair (past buffer, parser state, future-buffer1, future-buffer2) ...@
5261 TeePair !([x], StepState sL a, [x], [x]) !([x], StepState sR b, [x], [x])
5362
54−data Res = Yld Int | Stp Int | Skp
63+data Res = Yld Int | Stp Int | Skp | Err String
5564
5665-- XXX: With the current "Step" semantics, it is hard to write, and not sure
5766-- how useful, an efficient teeWith that returns a correct unused input count.
5867--
68+-- XXX Teeing a parser with a Fold could be more useful and simpler to
69+-- implement. A fold never fails or backtracks so we do not need to buffer the
70+-- input for the fold. It can be useful in, for example, maintaining the line
71+-- and column number position to report for errors. We can always have the
72+-- line/column fold running in parallel with the main parser, whenever an error
73+-- occurs we can zip the error with the context fold.
74+--
5975-- | @teeWith f p1 p2@ distributes its input to both @p1@ and @p2@ until both
6076-- of them succeed or fail and combines their output using @f@. The parser
6177-- succeeds if both the parsers succeed.
@@ -104,6 +120,7 @@ teeWith zf (Parser stepL initialL extractL) (Parser stepR initialR extractR) =
104120 src = Prelude.reverse src0
105121 state = (buf2, StepState s, src ++ inp11, inp21)
106122 in assert (n <= length buf1) (return (state, Skp))
123+ Error err -> return (undefined, Err err)
107124
108125 {-# INLINE_LATE step #-}
109126 step (TeePair (bufL, StepState sL, inpL1, inpL2)
@@ -121,6 +138,8 @@ teeWith zf (Parser stepL initialL extractL) (Parser stepR initialR extractR) =
121138 let (_, StepResult rL, _, _) = l
122139 (_, StepResult rR, _, _) = r
123140 in Stop (min n1 n2) (zf rL rR)
141+ (Err err, _) -> Error err
142+ (_, Err err) -> Error err
124143 _ -> Skip 0 next
125144
126145 step (TeePair (bufL, StepState sL, inpL1, inpL2)
@@ -137,6 +156,7 @@ teeWith zf (Parser stepL initialL extractL) (Parser stepR initialR extractR) =
137156 let (_, StepResult rL, _, _) = l
138157 in Stop n (zf rL rR)
139158 Skp -> Skip 0 next
159+ Err err -> Error err
140160
141161 step (TeePair l@(_, StepResult rL, _, _)
142162 (bufR, StepState sR, inpR1, inpR2)) x = do
@@ -152,28 +172,25 @@ teeWith zf (Parser stepL initialL extractL) (Parser stepR initialR extractR) =
152172 let (_, StepResult rR, _, _) = r
153173 in Stop n (zf rL rR)
154174 Skp -> Skip 0 next
175+ Err err -> Error err
155176
156177 step _ _ = undefined
157178
158− {-# INLINE extractBoth #-}
159− extractBoth sL sR = do
160− rL <- extractL sL
161− rR <- extractR sR
162− return (zf rL rR)
163−
164179 {-# INLINE_LATE extract #-}
165180 extract st =
166181 case st of
167− TeePair (_, StepState sL, _, _) (_, StepState sR, _, _) ->
168− extractBoth sL sR
169− TeePair (_, StepState sL, _, _) (_, StepResult rR, _, _) -> do
170− rL <- extractL sL
171− return $ zf rL rR
172− TeePair (_, StepResult rL, _, _) (_, StepState sR, _, _) -> do
173− rR <- extractR sR
174− return $ zf rL rR
175− TeePair (_, StepResult rL, _, _) (_, StepResult rR, _, _) ->
176− return $ zf rL rR
182+ TeePair (_, StepState sL, _, _) (_, StepState sR, _, _) -> do
183+ rL <- extractL sL
184+ rR <- extractR sR
185+ return $ zf rL rR
186+ TeePair (_, StepState sL, _, _) (_, StepResult rR, _, _) -> do
187+ rL <- extractL sL
188+ return $ zf rL rR
189+ TeePair (_, StepResult rL, _, _) (_, StepState sR, _, _) -> do
190+ rR <- extractR sR
191+ return $ zf rL rR
192+ TeePair (_, StepResult rL, _, _) (_, StepResult rR, _, _) ->
193+ return $ zf rL rR
177194
178195-- | Like 'teeWith' but ends parsing and zips the results, if available,
179196-- whenever the first parser ends.
@@ -223,6 +240,7 @@ teeWithFst zf (Parser stepL initialL extractL)
223240 src = Prelude.reverse src0
224241 state = (buf2, StepState s, src ++ inp11, inp21)
225242 in assert (n <= length buf1) (return (state, Skp))
243+ Error err -> return (undefined, Err err)
226244
227245 {-# INLINE_LATE step #-}
228246 step (TeePair (bufL, StepState sL, inpL1, inpL2)
@@ -250,6 +268,8 @@ teeWithFst zf (Parser stepL initialL extractL)
250268 return $ Stop n1 (zf rL rR)
251269 (Yld n1, Yld n2) -> return $ Yield (min n1 n2) next
252270 (Yld n1, Stp n2) -> return $ Yield (min n1 n2) next
271+ (Err err, _) -> return $ Error err
272+ (_, Err err) -> return $ Error err
253273 _ -> return $ Skip 0 next
254274
255275 step (TeePair (bufL, StepState sL, inpL1, inpL2)
@@ -266,24 +286,21 @@ teeWithFst zf (Parser stepL initialL extractL)
266286 let (_, StepResult rL, _, _) = l
267287 in Stop n (zf rL rR)
268288 Skp -> Skip 0 next
289+ Err err -> Error err
269290
270291 step _ _ = undefined
271292
272− {-# INLINE extractBoth #-}
273− extractBoth sL sR = do
274− rL <- extractL sL
275− rR <- extractR sR
276− return (zf rL rR)
277−
278293 {-# INLINE_LATE extract #-}
279294 extract st =
280295 case st of
281− TeePair (_, StepState sL, _, _) (_, StepState sR, _, _) ->
282− extractBoth sL sR
283− TeePair (_, StepState sL, _, _) (_, StepResult rR, _, _) -> do
284− rL <- extractL sL
285− return $ zf rL rR
286− _ -> error "unreachable"
296+ TeePair (_, StepState sL, _, _) (_, StepState sR, _, _) -> do
297+ rL <- extractL sL
298+ rR <- extractR sR
299+ return $ zf rL rR
300+ TeePair (_, StepState sL, _, _) (_, StepResult rR, _, _) -> do
301+ rL <- extractL sL
302+ return $ zf rL rR
303+ _ -> error "unreachable"
287304
288305-- | Like 'teeWith' but ends parsing and zips the results, if available,
289306-- whenever any of the parsers ends or fails.
@@ -295,3 +312,211 @@ teeWithMin ::
295312 -- Monad m =>
296313 (a -> b -> c) -> Parser m x a -> Parser m x b -> Parser m x c
297314teeWithMin = undefined
315+
316+-------------------------------------------------------------------------------
317+-- Distribute input to two parsers and choose one result
318+-------------------------------------------------------------------------------
319+
320+-- | Shortest alternative. Apply both parsers in parallel but choose the result
321+-- from the one which consumed least input i.e. take the shortest succeeding
322+-- parse.
323+--
324+-- /Internal/
325+--
326+{-# INLINE shortest #-}
327+shortest :: Monad m => Parser m x a -> Parser m x a -> Parser m x a
328+shortest (Parser stepL initialL extractL) (Parser stepR initialR _) =
329+ Parser step initial extract
330+
331+ where
332+
333+ {-# INLINE_LATE initial #-}
334+ initial = do
335+ sL <- initialL
336+ sR <- initialR
337+ return $ TeePair ([], StepState sL, [], []) ([], StepState sR, [], [])
338+
339+ {-# INLINE consume #-}
340+ consume buf inp1 inp2 stp st y = do
341+ let (x, inp11, inp21) =
342+ case inp1 of
343+ [] -> (y, [], [])
344+ z : [] -> (z, reverse (x:inp2), [])
345+ z : zs -> (z, zs, x:inp2)
346+ r <- stp st x
347+ let buf1 = x:buf
348+ return (buf1, r, inp11, inp21)
349+
350+ -- consume one input item and return the next state of the fold
351+ {-# INLINE useStream #-}
352+ useStream buf inp1 inp2 stp st y = do
353+ (buf1, r, inp11, inp21) <- consume buf inp1 inp2 stp st y
354+ case r of
355+ Yield n s ->
356+ let state = (Prelude.take n buf1, StepState s, inp11, inp21)
357+ in assert (n <= length buf1) (return (state, Yld n))
358+ Stop n b ->
359+ let state = (Prelude.take n buf1, StepResult b, inp11, inp21)
360+ in assert (n <= length buf1) (return (state, Stp n))
361+ -- Skip 0 s -> (buf1, Right s, inp11, inp21)
362+ Skip n s ->
363+ let (src0, buf2) = splitAt n buf1
364+ src = Prelude.reverse src0
365+ state = (buf2, StepState s, src ++ inp11, inp21)
366+ in assert (n <= length buf1) (return (state, Skp))
367+ Error err -> return (undefined, Err err)
368+
369+ -- XXX Even if a parse finished earlier it may not be shortest if the other
370+ -- parser finishes later but returns a lot of unconsumed input. Our current
371+ -- criterion of shortest is whichever parse decided to stop earlier.
372+ {-# INLINE_LATE step #-}
373+ step (TeePair (bufL, StepState sL, inpL1, inpL2)
374+ (bufR, StepState sR, inpR1, inpR2)) x = do
375+ (l,stL) <- useStream bufL inpL1 inpL2 stepL sL x
376+ (r,stR) <- useStream bufR inpR1 inpR2 stepR sR x
377+ let next = TeePair l r
378+ return $ case (stL,stR) of
379+ (Stp n1, _) ->
380+ let (_, StepResult rL, _, _) = l
381+ in Stop n1 rL
382+ (_, Stp n2) ->
383+ let (_, StepResult rR, _, _) = r
384+ in Stop n2 rR
385+ (Yld n1, Yld n2) -> Yield (min n1 n2) next
386+ (Err err, _) -> Error err
387+ (_, Err err) -> Error err
388+ _ -> Skip 0 next
389+
390+ step _ _ = undefined
391+
392+ {-# INLINE_LATE extract #-}
393+ extract st =
394+ case st of
395+ TeePair (_, StepState sL, _, _) _ -> extractL sL
396+ _ -> error "unreachable"
397+
398+-- | Longest alternative. Apply both parsers in parallel but choose the result
399+-- from the one which consumed more input i.e. take the longest succeeding
400+-- parse.
401+--
402+-- /Internal/
403+--
404+{-# INLINE longest #-}
405+longest :: MonadCatch m => Parser m x a -> Parser m x a -> Parser m x a
406+longest (Parser stepL initialL extractL) (Parser stepR initialR extractR) =
407+ Parser step initial extract
408+
409+ where
410+
411+ {-# INLINE_LATE initial #-}
412+ initial = do
413+ sL <- initialL
414+ sR <- initialR
415+ return $ TeePair ([], StepState sL, [], []) ([], StepState sR, [], [])
416+
417+ {-# INLINE consume #-}
418+ consume buf inp1 inp2 stp st y = do
419+ let (x, inp11, inp21) =
420+ case inp1 of
421+ [] -> (y, [], [])
422+ z : [] -> (z, reverse (x:inp2), [])
423+ z : zs -> (z, zs, x:inp2)
424+ r <- stp st x
425+ let buf1 = x:buf
426+ return (buf1, r, inp11, inp21)
427+
428+ -- consume one input item and return the next state of the fold
429+ {-# INLINE useStream #-}
430+ useStream buf inp1 inp2 stp st y = do
431+ (buf1, r, inp11, inp21) <- consume buf inp1 inp2 stp st y
432+ case r of
433+ Yield n s ->
434+ let state = (Prelude.take n buf1, StepState s, inp11, inp21)
435+ in assert (n <= length buf1) (return (state, Yld n))
436+ Stop n b ->
437+ let state = (Prelude.take n buf1, StepResult b, inp11, inp21)
438+ in assert (n <= length buf1) (return (state, Stp n))
439+ -- Skip 0 s -> (buf1, Right s, inp11, inp21)
440+ Skip n s ->
441+ let (src0, buf2) = splitAt n buf1
442+ src = Prelude.reverse src0
443+ state = (buf2, StepState s, src ++ inp11, inp21)
444+ in assert (n <= length buf1) (return (state, Skp))
445+ Error err -> return (undefined, Err err)
446+
447+ {-# INLINE_LATE step #-}
448+ step (TeePair (bufL, StepState sL, inpL1, inpL2)
449+ (bufR, StepState sR, inpR1, inpR2)) x = do
450+ (l,stL) <- useStream bufL inpL1 inpL2 stepL sL x
451+ (r,stR) <- useStream bufR inpR1 inpR2 stepR sR x
452+ let next = TeePair l r
453+ return $ case (stL,stR) of
454+ (Yld n1, Yld n2) -> Yield (min n1 n2) next
455+ (Yld n1, Stp n2) -> Yield (min n1 n2) next
456+ (Stp n1, Yld n2) -> Yield (min n1 n2) next
457+ (Stp n1, Stp n2) ->
458+ let (_, StepResult rL, _, _) = l
459+ (_, StepResult rR, _, _) = r
460+ in Stop (max n1 n2) (if n1 >= n2 then rL else rR)
461+ (Err err, _) -> Error err
462+ (_, Err err) -> Error err
463+ _ -> Skip 0 next
464+
465+ -- XXX the parser that finishes last may not be the longest because it may
466+ -- return a lot of unused input which makes it shorter. Our current
467+ -- criterion of deciding longest is based on whoever decides to finish
468+ -- last and not whoever consumed more input.
469+ --
470+ -- To actually know who made more progress we need to keep an account of
471+ -- how many items are unconsumed since the last yield.
472+ --
473+ step (TeePair (bufL, StepState sL, inpL1, inpL2)
474+ r@(_, StepResult _, _, _)) x = do
475+ (l,stL) <- useStream bufL inpL1 inpL2 stepL sL x
476+ let next = TeePair l r
477+ return $ case stL of
478+ Yld n -> Yield n next
479+ Stp n ->
480+ let (_, StepResult rL, _, _) = l
481+ in Stop n rL
482+ Skp -> Skip 0 next
483+ Err err -> Error err
484+
485+ step (TeePair l@(_, StepResult _, _, _)
486+ (bufR, StepState sR, inpR1, inpR2)) x = do
487+ (r, stR) <- useStream bufR inpR1 inpR2 stepR sR x
488+ let next = TeePair l r
489+ return $ case stR of
490+ Yld n -> Yield n next
491+ Stp n ->
492+ let (_, StepResult rR, _, _) = r
493+ in Stop n rR
494+ Skp -> Skip 0 next
495+ Err err -> Error err
496+
497+ step _ _ = undefined
498+
499+ {-# INLINE_LATE extract #-}
500+ extract st =
501+ -- XXX When results are partial we may not be able to precisely compare
502+ -- which parser has made more progress till now. One way to do that is
503+ -- to figure out the actually consumed input up to the last yield.
504+ --
505+ case st of
506+ TeePair (_, StepState sL, _, _) (_, StepState sR, _, _) -> do
507+ r <- try $ extractL sL
508+ case r of
509+ Left (_ :: ParseError) -> extractR sR
510+ Right b -> return b
511+ TeePair (_, StepState sL, _, _) (_, StepResult rR, _, _) -> do
512+ r <- try $ extractL sL
513+ case r of
514+ Left (_ :: ParseError) -> return rR
515+ Right b -> return b
516+ TeePair (_, StepResult rL, _, _) (_, StepState sR, _, _) -> do
517+ r <- try $ extractR sR
518+ case r of
519+ Left (_ :: ParseError) -> return rL
520+ Right b -> return b
521+ TeePair (_, StepResult _, _, _) (_, StepResult _, _, _) ->
522+ error "unreachable"