@@ -20,15 +20,13 @@
2020
2121module Streamly.Internal.Data.Parser.ParserK.Types
2222 (
23− Parse (..)
24− , Driver (..)
25− , Parser (..)
26− , extractParse
23+ Parser (..)
2724 , yield
2825 , die
2926
30− -- * Parsing
31− , parse
27+ -- * Conversion
28+ , toParserK
29+ , fromParserK
3230 )
3331where
3432
@@ -46,7 +44,7 @@ import Streamly.Internal.Data.Zipper (Zipper (..))
4644import Prelude hiding (splitAt)
4745
4846import qualified Streamly.Internal.Data.Zipper as Z
49−import qualified Streamly.Internal.Data.Parser.ParserD.Types as PD
47+import qualified Streamly.Internal.Data.Parser.ParserD.Types as D
5048
5149-- | The parse driver result. The driver may stop with a final result, pause
5250-- with a continuation to resume, or fail with an error.
@@ -54,15 +52,17 @@ import qualified Streamly.Internal.Data.Parser.ParserD.Types as PD
5452-- /Internal/
5553--
5654data Driver m a r =
57− Stop r
55+ Stop !Int r
5856 -- XXX we can use a "resume" and a "stop" continuations instead of Maybe.
5957 -- measure if that works any better.
6058 | Partial (Maybe a -> m (Driver m a r))
59+ | Continue (Maybe a -> m (Driver m a r))
6160 | Failed String
6261
6362instance Functor m => Functor (Driver m a) where
64− fmap f (Stop r) = Stop (f r)
63+ fmap f (Stop n r) = Stop n (f r)
6564 fmap f (Partial yld) = Partial (fmap (fmap f) . yld)
65+ fmap f (Continue yld) = Continue (fmap (fmap f) . yld)
6666 fmap _ (Failed e) = Failed e
6767
6868-- The parser's result.
@@ -89,6 +89,220 @@ newtype Parser m a b = MkParser
8989 -> m (Driver m a r)
9090 }
9191
92+-------------------------------------------------------------------------------
93+-- Convert direct style 'D.Parser' to CPS style 'Parser'
94+-------------------------------------------------------------------------------
95+
96+-- Inlined definition. Without the inline "serially/parser/take" benchmark
97+-- degrades and splitParse does not fuse. Even using "inline" at the callsite
98+-- does not help.
99+{-# INLINE splitAt #-}
100+splitAt :: Int -> [a] -> ([a],[a])
101+splitAt n ls
102+ | n <= 0 = ([], ls)
103+ | otherwise = splitAt' n ls
104+ where
105+ splitAt' :: Int -> [a] -> ([a], [a])
106+ splitAt' _ [] = ([], [])
107+ splitAt' 1 (x:xs) = ([x], xs)
108+ splitAt' m (x:xs) = (x:xs', xs'')
109+ where
110+ (xs', xs'') = splitAt' (m - 1) xs
111+
112+-- XXX Unlike the direct style folds/parsers, the initial action in CPS parsers
113+-- is not performed when the fold is initialized. It is performed when the
114+-- first element is processed by the fold or if no elements are processed then
115+-- at the extraction. We should either make the direct folds like this or make
116+-- the CPS folds behavior also like the direct ones.
117+--
118+-- | Parse a stream zipper using a direct style parser's @step@, @initial@ and
119+-- @extract@ functions.
120+--
121+{-# INLINE_NORMAL parse #-}
122+parse
123+ :: MonadCatch m
124+ => (s -> a -> m (D.Step s b))
125+ -> m s
126+ -> (s -> m b)
127+ -> Zipper a
128+ -> (Zipper a -> Parse b -> m (Driver m a r))
129+ -> m (Driver m a r)
130+
131+-- The case when no checkpoints exist
132+parse pstep initial extract (Zipper [] backward forward) cont =
133+ case forward of
134+ [] -> return $ Continue (parseCont backward initial)
135+ _ -> goBuf backward forward initial
136+
137+ where
138+
139+ parseCont back acc (Just x) = goSingle back x acc
140+ parseCont back acc Nothing = do
141+ pst <- acc
142+ r <- try $ extract pst
143+ -- NOTE: Any data held in the backtrack buffer is considered as unused
144+ -- data if we extract the parser result without the parser finishing.
145+ let z = Zipper [] back []
146+ case r of
147+ Left (e :: D.ParseError) ->
148+ cont z (Error (displayException e))
149+ Right b -> cont z (Done b)
150+
151+ {-# INLINE goSingle #-}
152+ goSingle back x !pst = do
153+ r <- pst
154+ pRes <- pstep r x
155+ case pRes of
156+ D.Partial 0 pst1 -> return $ Partial (parseCont [] (return pst1))
157+ D.Partial n pst1 -> do
158+ assert (n <= length (x:back)) (return ())
159+ let src0 = Prelude.take n (x:back)
160+ src = Prelude.reverse src0
161+ goBuf [] src (return pst1)
162+ D.Continue 0 pst1 ->
163+ return $ Continue (parseCont (x:back) (return pst1))
164+ D.Continue n pst1 -> do
165+ assert (n <= length (x:back)) (return ())
166+ let (src0, buf1) = splitAt n (x:back)
167+ src = Prelude.reverse src0
168+ goBuf buf1 src (return pst1)
169+ D.Done n b -> do
170+ assert (n <= length (x:back)) (return ())
171+ let (src0, buf1) = splitAt n (x:back)
172+ src = Prelude.reverse src0
173+ cont (Zipper [] buf1 src) (Done b)
174+ D.Error err -> cont (Zipper [] (x:back) []) (Error err)
175+
176+ goBuf back [] !acc = return $ Continue (parseCont back acc)
177+ goBuf back (x:xs) !pst = do
178+ r <- pst
179+ pRes <- pstep r x
180+ case pRes of
181+ D.Partial 0 pst1 ->
182+ goBuf [] xs (return pst1)
183+ D.Partial n pst1 -> do
184+ assert (n <= length (x:back)) (return ())
185+ let src0 = Prelude.take n (x:back)
186+ src = Prelude.reverse src0
187+ goBuf [] (src ++ xs) (return pst1)
188+ D.Continue 0 pst1 -> goBuf (x:back) xs (return pst1)
189+ D.Continue n pst1 -> do
190+ assert (n <= length (x:back)) (return ())
191+ let (src0, buf1) = splitAt n (x:back)
192+ src = Prelude.reverse src0 ++ xs
193+ goBuf buf1 src (return pst1)
194+ D.Done n b -> do
195+ assert (n <= length (x:back)) (return ())
196+ let (src0, buf1) = splitAt n (x:back)
197+ src = Prelude.reverse src0 ++ xs
198+ cont (Zipper [] buf1 src) (Done b)
199+ D.Error err -> cont (Zipper [] (x:back) xs) (Error err)
200+
201+-- The case when checkpoints exist
202+-- XXX code duplication alert!
203+parse pstep initial extract (Zipper (cp:cps) backward forward) cont =
204+ case forward of
205+ [] -> return $ Continue (parseCont 0 backward initial)
206+ _ -> goBuf 0 backward forward initial
207+
208+ where
209+
210+ parseCont cnt back acc (Just x) = goSingle cnt back x acc
211+ parseCont cnt back acc Nothing = do
212+ pst <- acc
213+ r <- try $ extract pst
214+ let z = Zipper (cp + cnt : cps) back []
215+ case r of
216+ Left (e :: D.ParseError) ->
217+ cont z (Error (displayException e))
218+ Right b -> cont z (Done b)
219+
220+ {-# INLINE goSingle #-}
221+ goSingle cnt back x !pst = do
222+ r <- pst
223+ pRes <- pstep r x
224+ let cnt1 = cnt + 1
225+ case pRes of
226+ D.Partial 0 pst1 ->
227+ return $ Partial (parseCont cnt1 [] (return pst1))
228+ D.Partial n pst1 -> do
229+ assert (n <= length (x:back)) (return ())
230+ let src0 = Prelude.take n (x:back)
231+ src = Prelude.reverse src0
232+ goBuf (cnt1 - n) [] src (return pst1)
233+ D.Continue 0 pst1 ->
234+ return $ Continue (parseCont cnt1 (x:back) (return pst1))
235+ D.Continue n pst1 -> do
236+ assert (n <= length (x:back)) (return ())
237+ let (src0, buf1) = splitAt n (x:back)
238+ src = Prelude.reverse src0
239+ assert (cnt1 - n >= 0) (return ())
240+ goBuf (cnt1 - n) buf1 src (return pst1)
241+ D.Done n b -> do
242+ assert (n <= length (x:back)) (return ())
243+ let (src0, buf1) = splitAt n (x:back)
244+ src = Prelude.reverse src0
245+ assert (cp + cnt1 - n >= 0) (return ())
246+ cont (Zipper (cp + cnt1 - n : cps) buf1 src) (Done b)
247+ D.Error err ->
248+ cont (Zipper (cp + cnt1 : cps) (x:back) []) (Error err)
249+
250+ goBuf cnt back [] !acc = return $ Continue (parseCont cnt back acc)
251+ goBuf cnt back (x:xs) !pst = do
252+ r <- pst
253+ pRes <- pstep r x
254+ let cnt1 = cnt + 1
255+ case pRes of
256+ D.Partial 0 pst1 ->
257+ goBuf cnt1 [] xs (return pst1)
258+ D.Partial n pst1 -> do
259+ assert (n <= length (x:back)) (return ())
260+ let src0 = Prelude.take n (x:back)
261+ src = Prelude.reverse src0
262+ goBuf (cnt1 - n) [] (src ++ xs) (return pst1)
263+ D.Continue 0 pst1 -> goBuf cnt1 (x:back) xs (return pst1)
264+ D.Continue n pst1 -> do
265+ assert (n <= length (x:back)) (return ())
266+ let (src0, buf1) = splitAt n (x:back)
267+ src = Prelude.reverse src0 ++ xs
268+ assert (cnt1 - n >= 0) (return ())
269+ goBuf (cnt1 - n) buf1 src (return pst1)
270+ D.Done n b -> do
271+ assert (n <= length (x:back)) (return ())
272+ let (src0, buf1) = splitAt n (x:back)
273+ src = Prelude.reverse src0 ++ xs
274+ assert (cp + cnt1 - n >= 0) (return ())
275+ cont (Zipper (cp + cnt1 - n : cps) buf1 src) (Done b)
276+ D.Error err ->
277+ cont (Zipper (cp + cnt1 : cps) (x:back) xs) (Error err)
278+
279+-- | Convert a direct style 'Parser' to a CPS style 'K.Parser'.
280+--
281+-- /Internal/
282+--
283+{-# INLINE_LATE toParserK #-}
284+toParserK :: MonadCatch m => D.Parser m a b -> Parser m a b
285+toParserK (D.Parser step initial extract) =
286+ MkParser $ parse step initial extract
287+
288+-------------------------------------------------------------------------------
289+-- Convert CPS style 'Parser' to direct style 'D.Parser'
290+-------------------------------------------------------------------------------
291+
292+-- | A continuation to extract the result when a CPS parser is done.
293+{-# INLINE parserDone #-}
294+parserDone :: Monad m => Zipper a -> Parse b -> m (Driver m a b)
295+parserDone (Z.Zipper [] bwd fwd) (Done b) =
296+ -- When the parser is Done, we consider the data in the
297+ -- backtracking buffer as well as in the forward buffer as
298+ -- unconsumed input.
299+ -- XXX Will it be more efficient/worth it to maintain a count
300+ -- in the Zipper?
301+ return $ Stop (length bwd + length fwd) b
302+parserDone (Z.Zipper cps _ _) (Done _) =
303+ error $ "Bug: fromParserK: when checkpoints exist: " ++ show cps
304+parserDone _ (Error e) = return $ Failed e
305+
92306-- | When there is no more input to feed, extract the result from the Parser.
93307--
94308-- /Internal/
@@ -97,9 +311,66 @@ extractParse :: MonadThrow m => (Maybe a -> m (Driver m a b)) -> m b
97311extractParse cont = do
98312 r <- cont Nothing
99313 case r of
100− Stop b -> return b
314+ Stop _ b -> return b
101315 Partial _ -> error "Bug: extractParse got Partial"
102− Failed e -> throwM $ PD.ParseError e
316+ Continue _ -> error "Bug: extractParse got Continue"
317+ Failed e -> throwM $ D.ParseError e
318+
319+-- XXX The CPS style parsers use a zipper buffering the data, if a parserD is
320+-- driving the parserK then it would also be buffering the same data. For
321+-- ParserD, instead of maintaining the buffer in the common driver, each parser
322+-- can have its own buffering and we can return the unconsumed buffer in the
323+-- end. That way the zipper is maintained by the parser. If the parser fails
324+-- then it has to return all of the input. It is anyway maintained by
325+-- intermediate level parsers in a composition, so the only difference would be
326+-- that even the leaf levels parsers would do it. If we abstract the zipper
327+-- maintainance then it may not be too unwieldy.
328+
329+data FromParserK b e c = FPKDone !b | FPKError !e | FPKCont c
330+
331+-- | Convert a CPS style 'Parser' to a direct style 'D.Parser'.
332+--
333+-- /Internal/
334+--
335+{-# INLINE_LATE fromParserK #-}
336+fromParserK :: MonadThrow m => Parser m a b -> D.Parser m a b
337+fromParserK parser = D.Parser step initial extract
338+
339+ where
340+
341+ initial = do
342+ r <- runParser parser Z.nil parserDone
343+ return $ case r of
344+ Stop 0 b -> FPKDone b
345+ Stop _ _ -> error "Bug: fromParserK: Stop n in initial"
346+ Failed e -> FPKError e
347+ Partial cont -> FPKCont cont -- XXX can we get this?
348+ Continue cont -> FPKCont cont
349+
350+ step (FPKDone b) _ = return $ D.Done 1 b
351+ step (FPKError e) _ = return $ D.Error e
352+ step (FPKCont cont) a = do
353+ r <- cont (Just a)
354+ return $ case r of
355+ Stop n b -> D.Done n b
356+ Failed e -> D.Error e
357+ Partial cont1 -> D.Partial 0 (FPKCont cont1)
358+ Continue cont1 -> D.Continue 0 (FPKCont cont1)
359+
360+ extract (FPKDone b) = return b
361+ extract (FPKError e) = throwM $ D.ParseError e
362+ extract (FPKCont cont) = extractParse cont
363+
364+#ifndef DISABLE_FUSION
365+{-# RULES "fromParserK/toParserK fusion" [2]
366+ forall s. toParserK (fromParserK s) = s #-}
367+{-# RULES "toParserK/fromParserK fusion" [2]
368+ forall s. fromParserK (toParserK s) = s #-}
369+#endif
370+
371+-------------------------------------------------------------------------------
372+-- Functor
373+-------------------------------------------------------------------------------
103374
104375-- | Maps a function over the output of the parser.
105376--
@@ -109,7 +380,13 @@ instance Functor m => Functor (Parser m a) where
109380 let yld z res = yieldk z (fmap f res)
110381 in runParser parser zipper yld
111382
112−-- | See 'Streamly.Internal.Data.Parser.yield'.
383+-------------------------------------------------------------------------------
384+-- Sequential applicative
385+-------------------------------------------------------------------------------
386+
387+-- This is the dual of stream "yield".
388+--
389+-- | A parser that always yields a pure value without consuming any input.
113390--
114391-- /Internal/
115392--
@@ -117,10 +394,6 @@ instance Functor m => Functor (Parser m a) where
117394yield :: b -> Parser m a b
118395yield b = MkParser (\zipper yieldk -> yieldk zipper (Done b))
119396
120−-------------------------------------------------------------------------------
121−-- Sequential applicative
122−-------------------------------------------------------------------------------
123−
124397-- | 'Applicative' form of 'Streamly.Internal.Data.Parser.splitWith'. Note that
125398-- this operation does not fuse, use 'Streamly.Internal.Data.Parser.splitWith'
126399-- when fusion is important.
@@ -145,7 +418,14 @@ instance Monad m => Applicative (Parser m a) where
145418 yield1 z (Error e) = yieldk z (Error e)
146419 in runParser m1 zipper yield1
147420
148−-- | See 'Streamly.Internal.Data.Parser.die'.
421+-------------------------------------------------------------------------------
422+-- Monad
423+-------------------------------------------------------------------------------
424+
425+-- This is the dual of "nil".
426+--
427+-- | A parser that always fails with an error message without consuming
428+-- any input.
149429--
150430-- /Internal/
151431--
@@ -219,6 +499,10 @@ instance Monad m => Fail.MonadFail (Parser m a) where
219499 fail = die
220500#endif
221501
502+-------------------------------------------------------------------------------
503+-- Alternative
504+-------------------------------------------------------------------------------
505+
222506-- XXX one way to backtrack is to ask the input driver to create and release
223507-- checkpoints, like we do in the zipper. The other way is to pass around the
224508-- zipper itself. Currently in the direct style code we manage the checkpoints
@@ -279,184 +563,3 @@ instance Monad m => MonadPlus (Parser m a) where
279563
280564 {-# INLINE mplus #-}
281565 mplus = (<|>)
282−
283−-------------------------------------------------------------------------------
284−-- Parse driver for a Zipper
285−-------------------------------------------------------------------------------
286−
287−-- Inlined definition. Without the inline "serially/parser/take" benchmark
288−-- degrades and splitParse does not fuse. Even using "inline" at the callsite
289−-- does not help.
290−{-# INLINE splitAt #-}
291−splitAt :: Int -> [a] -> ([a],[a])
292−splitAt n ls
293− | n <= 0 = ([], ls)
294− | otherwise = splitAt' n ls
295− where
296− splitAt' :: Int -> [a] -> ([a], [a])
297− splitAt' _ [] = ([], [])
298− splitAt' 1 (x:xs) = ([x], xs)
299− splitAt' m (x:xs) = (x:xs', xs'')
300− where
301− (xs', xs'') = splitAt' (m - 1) xs
302−
303−-- | Parse a stream zipper using a direct style parser's @step@, @initial@ and
304−-- @extract@ functions.
305−--
306−{-# INLINE_NORMAL parse #-}
307−parse
308− :: MonadCatch m
309− => (s -> a -> m (PD.Step s b))
310− -> m s
311− -> (s -> m b)
312− -> Zipper a
313− -> (Zipper a -> Parse b -> m (Driver m a r))
314− -> m (Driver m a r)
315−
316−-- The case when no checkpoints exist
317−parse pstep initial extract (Zipper [] backward forward) cont =
318− case forward of
319− [] -> return $ Partial (parseCont backward initial)
320− _ -> goBuf backward forward initial
321−
322− where
323−
324− parseCont back acc (Just x) = goSingle back x acc
325− parseCont back acc Nothing = do
326− pst <- acc
327− r <- try $ extract pst
328− let z = Zipper [] back []
329− case r of
330− Left (e :: PD.ParseError) ->
331− cont z (Error (displayException e))
332− Right b -> cont z (Done b)
333−
334− {-# INLINE goSingle #-}
335− goSingle back x !pst = do
336− r <- pst
337− pRes <- pstep r x
338− case pRes of
339− -- XXX return Partial pause
340− PD.Partial 0 pst1 -> return $ Partial (parseCont [] (return pst1))
341− PD.Partial n pst1 -> do
342− assert (n <= length (x:back)) (return ())
343− let src0 = Prelude.take n (x:back)
344− src = Prelude.reverse src0
345− goBuf [] src (return pst1)
346− PD.Continue 0 pst1 ->
347− return $ Partial (parseCont (x:back) (return pst1))
348− PD.Continue n pst1 -> do
349− assert (n <= length (x:back)) (return ())
350− let (src0, buf1) = splitAt n (x:back)
351− src = Prelude.reverse src0
352− goBuf buf1 src (return pst1)
353− PD.Done n b -> do
354− assert (n <= length (x:back)) (return ())
355− let (src0, buf1) = splitAt n (x:back)
356− src = Prelude.reverse src0
357− cont (Zipper [] buf1 src) (Done b)
358− PD.Error err -> cont (Zipper [] (x:back) []) (Error err)
359−
360− goBuf back [] !acc = return $ Partial (parseCont back acc)
361− goBuf back (x:xs) !pst = do
362− r <- pst
363− pRes <- pstep r x
364− case pRes of
365− PD.Partial 0 pst1 ->
366− goBuf [] xs (return pst1)
367− PD.Partial n pst1 -> do
368− assert (n <= length (x:back)) (return ())
369− let src0 = Prelude.take n (x:back)
370− src = Prelude.reverse src0
371− goBuf [] (src ++ xs) (return pst1)
372− PD.Continue 0 pst1 -> goBuf (x:back) xs (return pst1)
373− PD.Continue n pst1 -> do
374− assert (n <= length (x:back)) (return ())
375− let (src0, buf1) = splitAt n (x:back)
376− src = Prelude.reverse src0 ++ xs
377− goBuf buf1 src (return pst1)
378− PD.Done n b -> do
379− assert (n <= length (x:back)) (return ())
380− let (src0, buf1) = splitAt n (x:back)
381− src = Prelude.reverse src0 ++ xs
382− cont (Zipper [] buf1 src) (Done b)
383− PD.Error err -> cont (Zipper [] (x:back) xs) (Error err)
384−
385−-- The case when checkpoints exist
386−-- XXX code duplication alert!
387−parse pstep initial extract (Zipper (cp:cps) backward forward) cont =
388− case forward of
389− [] -> return $ Partial (parseCont 0 backward initial)
390− _ -> goBuf 0 backward forward initial
391−
392− where
393−
394− parseCont cnt back acc (Just x) = goSingle cnt back x acc
395− parseCont _ back acc Nothing = do
396− pst <- acc
397− r <- try $ extract pst
398− let z = Zipper [] back []
399− case r of
400− Left (e :: PD.ParseError) ->
401− cont z (Error (displayException e))
402− Right b -> cont z (Done b)
403−
404− {-# INLINE goSingle #-}
405− goSingle cnt back x !pst = do
406− r <- pst
407− pRes <- pstep r x
408− let cnt1 = cnt + 1
409− case pRes of
410− -- XXX return Partial pause
411− PD.Partial 0 pst1 ->
412− return $ Partial (parseCont cnt1 [] (return pst1))
413− PD.Partial n pst1 -> do
414− assert (n <= length (x:back)) (return ())
415− let src0 = Prelude.take n (x:back)
416− src = Prelude.reverse src0
417− goBuf (cnt1 - n) [] src (return pst1)
418− PD.Continue 0 pst1 ->
419− return $ Partial (parseCont cnt1 (x:back) (return pst1))
420− PD.Continue n pst1 -> do
421− assert (n <= length (x:back)) (return ())
422− let (src0, buf1) = splitAt n (x:back)
423− src = Prelude.reverse src0
424− assert (cnt1 - n >= 0) (return ())
425− goBuf (cnt1 - n) buf1 src (return pst1)
426− PD.Done n b -> do
427− assert (n <= length (x:back)) (return ())
428− let (src0, buf1) = splitAt n (x:back)
429− src = Prelude.reverse src0
430− assert (cp + cnt1 - n >= 0) (return ())
431− cont (Zipper (cp + cnt1 - n : cps) buf1 src) (Done b)
432− PD.Error err ->
433− cont (Zipper (cp + cnt1 : cps) (x:back) []) (Error err)
434−
435− goBuf cnt back [] !acc = return $ Partial (parseCont cnt back acc)
436− goBuf cnt back (x:xs) !pst = do
437− r <- pst
438− pRes <- pstep r x
439− let cnt1 = cnt + 1
440− case pRes of
441− PD.Partial 0 pst1 ->
442− goBuf cnt1 [] xs (return pst1)
443− PD.Partial n pst1 -> do
444− assert (n <= length (x:back)) (return ())
445− let src0 = Prelude.take n (x:back)
446− src = Prelude.reverse src0
447− goBuf (cnt1 - n) [] (src ++ xs) (return pst1)
448− PD.Continue 0 pst1 -> goBuf cnt1 (x:back) xs (return pst1)
449− PD.Continue n pst1 -> do
450− assert (n <= length (x:back)) (return ())
451− let (src0, buf1) = splitAt n (x:back)
452− src = Prelude.reverse src0 ++ xs
453− assert (cnt1 - n >= 0) (return ())
454− goBuf (cnt1 - n) buf1 src (return pst1)
455− PD.Done n b -> do
456− assert (n <= length (x:back)) (return ())
457− let (src0, buf1) = splitAt n (x:back)
458− src = Prelude.reverse src0 ++ xs
459− assert (cp + cnt1 - n >= 0) (return ())
460− cont (Zipper (cp + cnt1 - n : cps) buf1 src) (Done b)
461− PD.Error err ->
462− cont (Zipper (cp + cnt1 : cps) (x:back) xs) (Error err)