@@ -20,31 +20,98 @@
2020
2121module Streamly.Internal.Data.Parser.ParserK.Types
2222 (
23− Parser (..)
23+ Parse (..)
24+ , Driver (..)
25+ , Parser (..)
26+ , extractParse
2427 , yield
2528 , die
29+
30+ -- * Parsing
31+ , parse
2632 )
2733where
2834
29−import Control.Monad (MonadPlus(..), ap)
3035import Control.Applicative (Alternative(..))
31−import Streamly.Internal.Data.Zipper (Zipper)
32−import qualified Streamly.Internal.Data.Zipper as Z
33−
36+import Control.Exception (assert, Exception(..))
37+import Control.Monad (MonadPlus(..), ap)
38+import Control.Monad.Catch (MonadCatch, MonadThrow(..), try)
3439#if MIN_VERSION_base(4,9,0)
3540import qualified Control.Monad.Fail as Fail
3641#endif
42+#if !(MIN_VERSION_base(4,10,0))
43+import Data.Semigroup ((<>))
44+#endif
45+import Streamly.Internal.Data.Zipper (Zipper (..))
46+import Streamly.Internal.Data.SVar (defState)
47+import Prelude hiding (splitAt)
48+
49+import qualified Streamly.Internal.Data.Zipper as Z
50+import qualified Streamly.Internal.Data.Parser.ParserD.Types as PD
51+import qualified Streamly.Internal.Data.Stream.StreamK as K
3752
38−newtype Parser m a b =
39− MkParser { runParser :: forall r.
40− Zipper m a -> ((Zipper m a, Either String b) -> m r) -> m r }
53+-- | The parse driver result. The driver may stop with a final result, pause
54+-- with a continuation to resume, or fail with an error.
55+--
56+-- /Internal/
57+--
58+data Driver m a r =
59+ Stop r
60+ -- XXX we can use a "resume" and a "stop" continuations instead of Maybe.
61+ -- measure if that works any better.
62+ | Pause (Maybe a -> m (Driver m a r))
63+ | Failed String
64+
65+instance Functor m => Functor (Driver m a) where
66+ fmap f (Stop r) = Stop (f r)
67+ fmap f (Pause yld) = Pause (fmap (fmap f) . yld)
68+ fmap _ (Failed e) = Failed e
69+
70+-- The parser's result.
71+--
72+-- /Internal/
73+--
74+data Parse b =
75+ Done !b -- Done, no more input needed
76+ | Continue -- No result, need more input
77+ | Error !String -- Failed
78+
79+instance Functor Parse where
80+ fmap f (Done b) = Done (f b)
81+ fmap _ Continue = Continue
82+ fmap _ (Error e) = Error e
83+
84+-- | A continuation passing style parser representation. The parser is supplied
85+-- with a 'Zipper' with an initial input, and a continuation to consume the
86+-- parse result. The Zipper is threaded around as a state and maintains the
87+-- parser backtracking buffer.
88+--
89+newtype Parser m a b = MkParser
90+ { runParser :: forall r.
91+ Zipper m a
92+ -> (Zipper m a -> Parse b -> m (Driver m a r))
93+ -> m (Driver m a r)
94+ }
4195
42−-- | Maps a function over the output of the fold.
96+-- | When there is no more input to feed, extract the result from the Parser.
97+--
98+-- /Internal/
99+--
100+extractParse :: MonadThrow m => (Maybe a -> m (Driver m a b)) -> m b
101+extractParse cont = do
102+ r <- cont Nothing
103+ case r of
104+ Stop b -> return b
105+ Pause _ -> error "Bug: extractParse got Pause"
106+ Failed e -> throwM $ PD.ParseError e
107+
108+-- | Maps a function over the output of the parser.
43109--
44110instance Functor m => Functor (Parser m a) where
45111 {-# INLINE fmap #-}
46− fmap f parser =
47− MkParser $ \inp yieldk -> runParser parser inp (yieldk . fmap (fmap f))
112+ fmap f parser = MkParser $ \zipper yieldk ->
113+ let yld z res = yieldk z (fmap f res)
114+ in runParser parser zipper yld
48115
49116-- | See 'Streamly.Internal.Data.Parser.yield'.
50117--
@@ -52,7 +119,7 @@ instance Functor m => Functor (Parser m a) where
52119--
53120{-# INLINE yield #-}
54121yield :: b -> Parser m a b
55−yield b = MkParser (\inp yieldk -> yieldk (inp, Right b))
122+yield b = MkParser (\zipper yieldk -> yieldk zipper (Done b))
56123
57124-------------------------------------------------------------------------------
58125-- Sequential applicative
@@ -70,18 +137,19 @@ instance Monad m => Applicative (Parser m a) where
70137 (<*>) = ap
71138
72139 {-# INLINE (*>) #-}
73− m1 *> m2 = MkParser $ \inp yieldk ->
74− let yield1 (z, b) = case b of
75− Right _ -> runParser m2 z yieldk
76− Left err -> runParser (die err) z yieldk
77− in runParser m1 inp yield1
140+ m1 *> m2 = MkParser $ \zipper yieldk ->
141+ let yield1 z (Done _) = runParser m2 z yieldk
142+ yield1 z Continue = yieldk z Continue
143+ yield1 z (Error e) = yieldk z (Error e)
144+ in runParser m1 zipper yield1
78145
79146 {-# INLINE (<*) #-}
80− m1 <* m2 = MkParser $ \inp yieldk ->
81− let yield1 (z, b) = case b of
82− Right _ -> runParser m2 z (\(z1, _) -> yieldk (z1, b))
83− Left err -> runParser (die err) z yieldk
84− in runParser m1 inp yield1
147+ m1 <* m2 = MkParser $ \zipper yieldk ->
148+ let
149+ yield1 z (Done b) = runParser m2 z $ \z1 _ -> yieldk z1 (Done b)
150+ yield1 z Continue = yieldk z Continue
151+ yield1 z (Error e) = yieldk z (Error e)
152+ in runParser m1 zipper yield1
85153
86154-- | See 'Streamly.Internal.Data.Parser.die'.
87155--
@@ -89,7 +157,7 @@ instance Monad m => Applicative (Parser m a) where
89157--
90158{-# INLINE die #-}
91159die :: String -> Parser m a b
92−die err = MkParser (\z yieldk -> yieldk (z, Left err))
160+die err = MkParser (\z yieldk -> yieldk z (Error err))
93161
94162-- | Monad composition can be used for lookbehind parsers, we can make the
95163-- future parses depend on the previously parsed values.
@@ -138,11 +206,12 @@ instance Monad m => Monad (Parser m a) where
138206 return = pure
139207
140208 {-# INLINE (>>=) #-}
141− m >>= k = MkParser $ \inp yieldk ->
142− let yield1 (z, b) = case b of
143− Right x -> runParser (k x) z yieldk
144− Left err -> runParser (die err) z yieldk
145− in runParser m inp yield1
209+ m >>= k = MkParser $ \zipper yieldk ->
210+ let
211+ yield1 z (Done b) = runParser (k b) z yieldk
212+ yield1 z Continue = yieldk z Continue
213+ yield1 z (Error e) = yieldk z (Error e)
214+ in runParser m zipper yield1
146215
147216#if !(MIN_VERSION_base(4,13,0))
148217 -- This is redefined instead of just being Fail.fail to be
@@ -175,11 +244,11 @@ instance Monad m => Alternative (Parser m a) where
175244 empty = die "empty"
176245
177246 {-# INLINE (<|>) #-}
178− m1 <|> m2 = MkParser $ \inp yieldk ->
179− let yield1 (z, b) = case b of
180− Right _ -> yieldk (Z.release z, b)
181− Left _ -> runParser m2 (Z.restore z) yieldk
182− in runParser m1 (Z.checkpoint inp) yield1
247+ m1 <|> m2 = MkParser $ \zipper yieldk ->
248+ let yield1 z (Done b) = yieldk (Z.release z) (Done b)
249+ yield1 z Continue = yieldk z Continue
250+ yield1 z (Error _) = runParser m2 (Z.restore z) yieldk
251+ in runParser m1 (Z.checkpoint zipper) yield1
183252
184253 -- some and many are implemented here instead of using default definitions
185254 -- so that we can use INLINE on them. It gives 50% performance improvement.
@@ -211,3 +280,190 @@ instance Monad m => MonadPlus (Parser m a) where
211280
212281 {-# INLINE mplus #-}
213282 mplus = (<|>)
283+
284+-------------------------------------------------------------------------------
285+-- Parse driver for a Zipper
286+-------------------------------------------------------------------------------
287+
288+-- Inlined definition. Without the inline "serially/parser/take" benchmark
289+-- degrades and splitParse does not fuse. Even using "inline" at the callsite
290+-- does not help.
291+{-# INLINE splitAt #-}
292+splitAt :: Int -> [a] -> ([a],[a])
293+splitAt n ls
294+ | n <= 0 = ([], ls)
295+ | otherwise = splitAt' n ls
296+ where
297+ splitAt' :: Int -> [a] -> ([a], [a])
298+ splitAt' _ [] = ([], [])
299+ splitAt' 1 (x:xs) = ([x], xs)
300+ splitAt' m (x:xs) = (x:xs', xs'')
301+ where
302+ (xs', xs'') = splitAt' (m - 1) xs
303+
304+-- | Parse a stream zipper using a direct style parser's @step@, @initial@ and
305+-- @extract@ functions.
306+--
307+{-# INLINE_NORMAL parse #-}
308+parse
309+ :: MonadCatch m
310+ => (s -> a -> m (PD.Step s b))
311+ -> m s
312+ -> (s -> m b)
313+ -> Zipper m a
314+ -> (Zipper m a -> Parse b -> m (Driver m a r))
315+ -> m (Driver m a r)
316+
317+-- The case when no checkpoints exist
318+parse pstep initial extract (Zipper [] backward forward stream) cont =
319+ case forward of
320+ -- Stop if stream is nil
321+ [] -> goStream stream backward initial
322+ _ -> goBuf stream backward forward initial
323+
324+ where
325+
326+ -- Pauses if no input was generated by the stream and returns a
327+ -- continuation. If the continuation is called with Nothing then it stops
328+ -- and returns the result.
329+ {-# INLINE goStream #-}
330+ goStream st back !acc =
331+ -- XXX We do not need to wrap the element in a stream we can process it
332+ -- directly.
333+ let parseCont (Just x) = goStream (K.yield x) back acc
334+ parseCont Nothing = do
335+ pst <- acc
336+ r <- try $ extract pst
337+ case r of
338+ Left (e :: PD.ParseError) ->
339+ cont Z.nil (Error (displayException e))
340+ Right b -> cont Z.nil (Done b)
341+ stop = return $ Pause parseCont
342+ single x = yieldk x K.nil
343+ yieldk x r = do
344+ acc1 <- acc >>= \b -> pstep b x
345+ case acc1 of
346+ PD.Partial 0 pst1 -> goStream r [] (return pst1)
347+ PD.Partial n pst1 -> do
348+ assert (n <= length (x:back)) (return ())
349+ let src0 = Prelude.take n (x:back)
350+ src = Prelude.reverse src0
351+ goBuf r [] src (return pst1)
352+ PD.Continue 0 pst1 -> goStream r (x:back) (return pst1)
353+ PD.Continue n pst1 -> do
354+ assert (n <= length (x:back)) (return ())
355+ let (src0, buf1) = splitAt n (x:back)
356+ src = Prelude.reverse src0
357+ goBuf r buf1 src (return pst1)
358+ PD.Done n b -> do
359+ assert (n <= length (x:back)) (return ())
360+ let (src0, buf1) = splitAt n (x:back)
361+ src = Prelude.reverse src0
362+ cont (Zipper [] buf1 src r) (Done b)
363+ PD.Error err -> cont (Zipper [] (x:back) [] r) (Error err)
364+ in K.foldStream defState yieldk single stop st
365+
366+ goBuf s back [] !pst = goStream s back pst
367+ goBuf s back (x:xs) !pst = do
368+ r <- pst
369+ pRes <- pstep r x
370+ case pRes of
371+ PD.Partial 0 pst1 ->
372+ goBuf s [] xs (return pst1)
373+ PD.Partial n pst1 -> do
374+ assert (n <= length (x:back)) (return ())
375+ let src0 = Prelude.take n (x:back)
376+ src = Prelude.reverse src0
377+ goBuf s [] (src ++ xs) (return pst1)
378+ PD.Continue 0 pst1 -> goBuf s (x:back) xs (return pst1)
379+ PD.Continue n pst1 -> do
380+ assert (n <= length (x:back)) (return ())
381+ let (src0, buf1) = splitAt n (x:back)
382+ src = Prelude.reverse src0 ++ xs
383+ goBuf s buf1 src (return pst1)
384+ PD.Done n b -> do
385+ assert (n <= length (x:back)) (return ())
386+ let (src0, buf1) = splitAt n (x:back)
387+ src = Prelude.reverse src0 ++ xs
388+ cont (Zipper [] buf1 src s) (Done b)
389+ PD.Error err -> cont (Zipper [] (x:back) xs s) (Error err)
390+
391+-- The case when checkpoints exist
392+-- XXX code duplication alert!
393+parse pstep initial extract (Zipper (cp:cps) backward forward stream) cont =
394+ case forward of
395+ [] -> goStream 0 stream backward initial
396+ _ -> goBuf 0 stream backward forward initial
397+
398+ where
399+
400+ {-# INLINE goStream #-}
401+ goStream cnt st back !acc =
402+ let parseCont (Just x) = goStream cnt (K.yield x) back acc
403+ parseCont Nothing = do
404+ pst <- acc
405+ r <- try $ extract pst
406+ case r of
407+ Left (e :: PD.ParseError) ->
408+ cont Z.nil (Error (displayException e))
409+ Right b -> cont Z.nil (Done b)
410+ stop = return $ Pause parseCont
411+ single x = yieldk x K.nil
412+ yieldk x r = do
413+ acc1 <- acc >>= \b -> pstep b x
414+ let cnt1 = cnt + 1
415+ case acc1 of
416+ PD.Partial 0 pst1 ->
417+ goStream cnt1 r [] (return pst1)
418+ PD.Partial n pst1 -> do
419+ assert (n <= length (x:back)) (return ())
420+ let src0 = Prelude.take n (x:back)
421+ src = Prelude.reverse src0
422+ goBuf (cnt1 - n) r [] src (return pst1)
423+ PD.Continue 0 pst1 -> goStream cnt1 r (x:back) (return pst1)
424+ PD.Continue n pst1 -> do
425+ assert (n <= length (x:back)) (return ())
426+ let (src0, buf1) = splitAt n (x:back)
427+ src = Prelude.reverse src0
428+ assert (cnt1 - n >= 0) (return ())
429+ goBuf (cnt1 - n) r buf1 src (return pst1)
430+ PD.Done n b -> do
431+ assert (n <= length (x:back)) (return ())
432+ let (src0, buf1) = splitAt n (x:back)
433+ src = Prelude.reverse src0
434+ assert (cp + cnt1 - n >= 0) (return ())
435+ cont (Zipper (cp + cnt1 - n : cps) buf1 src r)
436+ (Done b)
437+ PD.Error err ->
438+ cont (Zipper (cp + cnt1 : cps) (x:back) [] r)
439+ (Error err)
440+ in K.foldStream defState yieldk single stop st
441+
442+ goBuf cnt s back [] !pst = goStream cnt s back pst
443+ goBuf cnt s back (x:xs) !pst = do
444+ r <- pst
445+ pRes <- pstep r x
446+ let cnt1 = cnt + 1
447+ case pRes of
448+ PD.Partial 0 pst1 ->
449+ goBuf cnt1 s [] xs (return pst1)
450+ PD.Partial n pst1 -> do
451+ assert (n <= length (x:back)) (return ())
452+ let src0 = Prelude.take n (x:back)
453+ src = Prelude.reverse src0
454+ goBuf (cnt1 - n) s [] (src ++ xs) (return pst1)
455+ PD.Continue 0 pst1 -> goBuf cnt1 s (x:back) xs (return pst1)
456+ PD.Continue n pst1 -> do
457+ assert (n <= length (x:back)) (return ())
458+ let (src0, buf1) = splitAt n (x:back)
459+ src = Prelude.reverse src0 ++ xs
460+ assert (cnt1 - n >= 0) (return ())
461+ goBuf (cnt1 - n) s buf1 src (return pst1)
462+ PD.Done n b -> do
463+ assert (n <= length (x:back)) (return ())
464+ let (src0, buf1) = splitAt n (x:back)
465+ src = Prelude.reverse src0 ++ xs
466+ assert (cp + cnt1 - n >= 0) (return ())
467+ cont (Zipper (cp + cnt1 - n : cps) buf1 src s) (Done b)
468+ PD.Error err ->
469+ cont (Zipper (cp + cnt1 : cps) (x:back) xs s) (Error err)