@@ -37,10 +37,10 @@ import Control.Monad.Catch (MonadCatch, MonadThrow(..), try)
3737#if MIN_VERSION_base(4,9,0)
3838import qualified Control.Monad.Fail as Fail
3939#endif
40−import Streamly.Internal.Data.Zipper (Zipper (..))
41−import Prelude hiding (splitAt)
40+#if !(MIN_VERSION_base(4,10,0))
41+import Data.Semigroup ((<>))
42+#endif
4243
43−import qualified Streamly.Internal.Data.Zipper as Z
4444import qualified Streamly.Internal.Data.Parser.ParserD.Types as D
4545
4646-- | The parse driver result. The driver may stop with a final result, pause
@@ -52,14 +52,14 @@ data Driver m a r =
5252 Stop !Int r
5353 -- XXX we can use a "resume" and a "stop" continuations instead of Maybe.
5454 -- measure if that works any better.
55− | Partial (Maybe a -> m (Driver m a r))
56− | Continue (Maybe a -> m (Driver m a r))
55+ | Partial !Int (Maybe a -> m (Driver m a r))
56+ | Continue !Int (Maybe a -> m (Driver m a r))
5757 | Failed String
5858
5959instance Functor m => Functor (Driver m a) where
6060 fmap f (Stop n r) = Stop n (f r)
61− fmap f (Partial yld) = Partial (fmap (fmap f) . yld)
62− fmap f (Continue yld) = Continue (fmap (fmap f) . yld)
61+ fmap f (Partial n yld) = Partial n (fmap (fmap f) . yld)
62+ fmap f (Continue n yld) = Continue n (fmap (fmap f) . yld)
6363 fmap _ (Failed e) = Failed e
6464
6565-- The parser's result.
@@ -67,22 +67,19 @@ instance Functor m => Functor (Driver m a) where
6767-- /Internal/
6868--
6969data Parse b =
70− Done !b -- Done, no more input needed
70+ Done !Int !b -- Done, no more input needed
7171 | Error !String -- Failed
7272
7373instance Functor Parse where
74− fmap f (Done b) = Done (f b)
74+ fmap f (Done n b) = Done n (f b)
7575 fmap _ (Error e) = Error e
7676
77−-- | A continuation passing style parser representation. The parser is supplied
78−-- with a 'Zipper' with an initial input, and a continuation to consume the
79−-- parse result. The Zipper is threaded around as a state and maintains the
80−-- parser backtracking buffer.
81−--
77+-- | A continuation passing style parser representation.
8278newtype Parser m a b = MkParser
8379 { runParser :: forall r.
84− Zipper a
85− -> (Zipper a -> Parse b -> m (Driver m a r))
80+ Int -- leftover elements
81+ -> (Int, Int) -- (nesting level in Alternative, used element count)
82+ -> ((Int, Int) -> Parse b -> m (Driver m a r))
8683 -> m (Driver m a r)
8784 }
8885
@@ -90,199 +87,83 @@ newtype Parser m a b = MkParser
9087-- Convert direct style 'D.Parser' to CPS style 'Parser'
9188-------------------------------------------------------------------------------
9289
93−-- Inlined definition. Without the inline "serially/parser/take" benchmark
94−-- degrades and splitParse does not fuse. Even using "inline" at the callsite
95−-- does not help.
96−{-# INLINE splitAt #-}
97−splitAt :: Int -> [a] -> ([a],[a])
98−splitAt n ls
99− | n <= 0 = ([], ls)
100− | otherwise = splitAt' n ls
101− where
102− splitAt' :: Int -> [a] -> ([a], [a])
103− splitAt' _ [] = ([], [])
104− splitAt' 1 (x:xs) = ([x], xs)
105− splitAt' m (x:xs) = (x:xs', xs'')
106− where
107− (xs', xs'') = splitAt' (m - 1) xs
108−
10990-- XXX Unlike the direct style folds/parsers, the initial action in CPS parsers
11091-- is not performed when the fold is initialized. It is performed when the
11192-- first element is processed by the fold or if no elements are processed then
11293-- at the extraction. We should either make the direct folds like this or make
11394-- the CPS folds behavior also like the direct ones.
11495--
115−-- | Parse a stream zipper using a direct style parser's @step@, @initial@ and
116−-- @extract@ functions.
96+-- | Convert a direct style parser to a CPS style parser.
11797--
118−{-# INLINE_NORMAL parse #-}
119−parse
98+{-# INLINE_NORMAL parseDToK #-}
99+parseDToK
120100 :: MonadCatch m
121101 => (s -> a -> m (D.Step s b))
122102 -> m s
123103 -> (s -> m b)
124− -> Zipper a
125− -> (Zipper a -> Parse b -> m (Driver m a r))
104+ -> Int
105+ -> (Int, Int)
106+ -> ((Int, Int) -> Parse b -> m (Driver m a r))
126107 -> m (Driver m a r)
127108
128−-- The case when no checkpoints exist
129−parse pstep initial extract (Zipper [] backward forward) cont =
130− case forward of
131− [] -> return $ Continue (parseCont backward initial)
132− _ -> goBuf backward forward initial
109+parseDToK pstep initial extract leftover (0, _) cont =
110+ return $ Continue leftover (parseCont initial)
133111
134112 where
135113
136− parseCont back acc (Just x) = goSingle back x acc
137− parseCont back acc Nothing = do
138− pst <- acc
139− r <- try $ extract pst
140− -- NOTE: Any data held in the backtrack buffer is considered as unused
141− -- data if we extract the parser result without the parser finishing.
142− let z = Zipper [] back []
143− case r of
144− Left (e :: D.ParseError) ->
145− cont z (Error (displayException e))
146− Right b -> cont z (Done b)
147−
148− {-# INLINE goSingle #-}
149− goSingle back x !pst = do
114+ parseCont pst (Just x) = do
150115 r <- pst
151116 pRes <- pstep r x
152117 case pRes of
153− D.Done n b -> do
154− assert (n <= length (x:back)) (return ())
155− let fwd0 = Prelude.take n (x:back)
156− fwd = Prelude.reverse fwd0
157− cont (Zipper [] [] fwd) (Done b)
158− D.Partial 0 pst1 ->
159− return $ Partial (parseCont [] (return pst1))
160− D.Partial n pst1 -> do
161− assert (n <= length (x:back)) (return ())
162− let fwd0 = Prelude.take n (x:back)
163− fwd = Prelude.reverse fwd0
164− goBuf [] fwd (return pst1)
165− D.Continue 0 pst1 ->
166− return $ Continue (parseCont (x:back) (return pst1))
167− D.Continue n pst1 -> do
168− assert (n <= length (x:back)) (return ())
169− let (fwd0, bwd) = splitAt n (x:back)
170− fwd = Prelude.reverse fwd0
171− goBuf bwd fwd (return pst1)
172− D.Error err ->
173− cont (Zipper [] (x:back) []) (Error err)
174−
175− goBuf back [] !acc = return $ Continue (parseCont back acc)
176− goBuf back (x:xs) !pst = do
177− r <- pst
178− pRes <- pstep r x
179− case pRes of
180− D.Done n b -> do
181− assert (n <= length (x:back)) (return ())
182− let fwd0 = Prelude.take n (x:back)
183− fwd = Prelude.reverse fwd0
184− cont (Zipper [] [] (fwd ++ xs)) (Done b)
185− D.Partial 0 pst1 ->
186− goBuf [] xs (return pst1)
187− D.Partial n pst1 -> do
188− assert (n <= length (x:back)) (return ())
189− let fwd0 = Prelude.take n (x:back)
190− fwd = Prelude.reverse fwd0
191− goBuf [] (fwd ++ xs) (return pst1)
192− D.Continue 0 pst1 -> goBuf (x:back) xs (return pst1)
193− D.Continue n pst1 -> do
194− assert (n <= length (x:back)) (return ())
195− let (fwd0, bwd) = splitAt n (x:back)
196− fwd = Prelude.reverse fwd0
197− goBuf bwd (fwd ++ xs) (return pst1)
198− D.Error err -> cont (Zipper [] (x:back) xs) (Error err)
199−
200−-- The case when checkpoints exist
201−-- XXX code duplication alert!
202−parse pstep initial extract (Zipper (cp:cps) backward forward) cont =
203− case forward of
204− [] -> return $ Continue (parseCont 0 backward initial)
205− _ -> goBuf 0 backward forward initial
118+ D.Done n b -> cont (0,0) (Done n b)
119+ D.Error err -> cont (0,0) (Error err)
120+ D.Partial n pst1 -> return $ Partial n (parseCont (return pst1))
121+ D.Continue n pst1 -> return $ Continue n (parseCont (return pst1))
206122
207− where
208−
209− parseCont cnt back acc (Just x) = goSingle cnt back x acc
210− parseCont cnt back acc Nothing = do
123+ parseCont acc Nothing = do
211124 pst <- acc
212125 r <- try $ extract pst
213− let z = Zipper (cp + cnt : cps) back []
214126 case r of
215− Left (e :: D.ParseError) ->
216− cont z (Error (displayException e))
217− Right b -> cont z (Done b)
127+ Left (e :: D.ParseError) -> cont (0,0) (Error (displayException e))
128+ Right b -> cont (0,0) (Done 0 b)
218129
219− {-# INLINE goSingle #-}
220− goSingle cnt back x !pst = do
221− r <- pst
222− pRes <- pstep r x
223− let cnt1 = cnt + 1
224− case pRes of
225− D.Done n b -> do
226− assert (n <= length (x:back)) (return ())
227− let fwd0 = Prelude.take n (x:back)
228− fwd = Prelude.reverse fwd0
229− assert (cp + cnt1 - n >= 0) (return ())
230− cont (Zipper (cp + cnt1 - n : cps) [] fwd) (Done b)
231− D.Partial 0 pst1 ->
232− return $ Partial (parseCont cnt1 [] (return pst1))
233− D.Partial n pst1 -> do
234− assert (n <= length (x:back)) (return ())
235− let fwd0 = Prelude.take n (x:back)
236− fwd = Prelude.reverse fwd0
237− goBuf (cnt1 - n) [] fwd (return pst1)
238− D.Continue 0 pst1 ->
239− return $ Continue (parseCont cnt1 (x:back) (return pst1))
240− D.Continue n pst1 -> do
241− assert (n <= length (x:back)) (return ())
242− let (fwd0, bwd) = splitAt n (x:back)
243− fwd = Prelude.reverse fwd0
244− assert (cnt1 - n >= 0) (return ())
245− goBuf (cnt1 - n) bwd fwd (return pst1)
246− D.Error err ->
247− cont (Zipper (cp + cnt1 : cps) (x:back) []) (Error err)
130+parseDToK pstep initial extract leftover (level, count) cont =
131+ return $ Continue leftover (parseCont count initial)
248132
249− goBuf cnt back [] !acc = return $ Continue (parseCont cnt back acc)
250− goBuf cnt back (x:xs) !pst = do
133+ where
134+
135+ parseCont !cnt pst (Just x) = do
136+ let !cnt1 = cnt + 1
251137 r <- pst
252138 pRes <- pstep r x
253− let cnt1 = cnt + 1
254139 case pRes of
255140 D.Done n b -> do
256− assert (n <= length (x:back)) (return ())
257− let fwd0 = Prelude.take n (x:back)
258− fwd = Prelude.reverse fwd0
259− assert (cp + cnt1 - n >= 0) (return ())
260− cont (Zipper (cp + cnt1 - n : cps) [] (fwd ++ xs)) (Done b)
261− D.Partial 0 pst1 ->
262− goBuf cnt1 [] xs (return pst1)
141+ assert (n <= cnt1) (return ())
142+ cont (level, cnt1 - n) (Done n b)
143+ D.Error err ->
144+ cont (level, cnt1) (Error err)
263145 D.Partial n pst1 -> do
264− assert (n <= length (x:back)) (return ())
265− let fwd0 = Prelude.take n (x:back)
266− fwd = Prelude.reverse fwd0
267− goBuf (cnt1 - n) [] (fwd ++ xs) (return pst1)
268− D.Continue 0 pst1 -> goBuf cnt1 (x:back) xs (return pst1)
146+ assert (n <= cnt1) (return ())
147+ return $ Partial n (parseCont (cnt1 - n) (return pst1))
269148 D.Continue n pst1 -> do
270− assert (n <= length (x:back)) (return ())
271− let (fwd0, bwd) = splitAt n (x:back)
272− fwd = Prelude.reverse fwd0 ++ xs
273− assert (cnt1 - n >= 0) (return ())
274− goBuf (cnt1 - n) bwd fwd (return pst1)
275− D.Error err ->
276− cont (Zipper (cp + cnt1 : cps) (x:back) xs) (Error err)
149+ assert (n <= cnt1) (return ())
150+ return $ Continue n (parseCont (cnt1 - n) (return pst1))
151+ parseCont cnt acc Nothing = do
152+ pst <- acc
153+ r <- try $ extract pst
154+ let s = (level, cnt)
155+ case r of
156+ Left (e :: D.ParseError) -> cont s (Error (displayException e))
157+ Right b -> cont s (Done 0 b)
277158
278−-- | Convert a direct style 'Parser' to a CPS style 'K.Parser'.
159+-- | Convert a direct style 'D.Parser' to a CPS style 'Parser'.
279160--
280161-- /Internal/
281162--
282163{-# INLINE_LATE toParserK #-}
283164toParserK :: MonadCatch m => D.Parser m a b -> Parser m a b
284165toParserK (D.Parser step initial extract) =
285− MkParser $ parse step initial extract
166+ MkParser $ parseDToK step initial extract
286167
287168-------------------------------------------------------------------------------
288169-- Convert CPS style 'Parser' to direct style 'D.Parser'
@@ -290,16 +171,10 @@ toParserK (D.Parser step initial extract) =
290171
291172-- | A continuation to extract the result when a CPS parser is done.
292173{-# INLINE parserDone #-}
293−parserDone :: Monad m => Zipper a -> Parse b -> m (Driver m a b)
294−parserDone (Z.Zipper [] bwd fwd) (Done b) =
295− -- When the parser is Done, we consider the data in the
296− -- backtracking buffer as well as in the forward buffer as
297− -- unconsumed input.
298− -- XXX Will it be more efficient/worth it to maintain a count
299− -- in the Zipper?
300− return $ Stop (length bwd + length fwd) b
301−parserDone (Z.Zipper cps _ _) (Done _) =
302− error $ "Bug: fromParserK: when checkpoints exist: " ++ show cps
174+parserDone :: Monad m => (Int, Int) -> Parse b -> m (Driver m a b)
175+parserDone (0,_) (Done n b) = return $ Stop n b
176+parserDone st (Done _ _) =
177+ error $ "Bug: fromParserK: inside alternative: " ++ show st
303178parserDone _ (Error e) = return $ Failed e
304179
305180-- | When there is no more input to feed, extract the result from the Parser.
@@ -311,21 +186,11 @@ extractParse cont = do
311186 r <- cont Nothing
312187 case r of
313188 Stop _ b -> return b
314− Partial _ -> error "Bug: extractParse got Partial"
315− Continue _ -> error "Bug: extractParse got Continue"
189+ Partial _ _ -> error "Bug: extractParse got Partial"
190+ Continue _ _ -> error "Bug: extractParse got Continue"
316191 Failed e -> throwM $ D.ParseError e
317192
318−-- XXX The CPS style parsers use a zipper buffering the data, if a parserD is
319−-- driving the parserK then it would also be buffering the same data. For
320−-- ParserD, instead of maintaining the buffer in the common driver, each parser
321−-- can have its own buffering and we can return the unconsumed buffer in the
322−-- end. That way the zipper is maintained by the parser. If the parser fails
323−-- then it has to return all of the input. It is anyway maintained by
324−-- intermediate level parsers in a composition, so the only difference would be
325−-- that even the leaf levels parsers would do it. If we abstract the zipper
326−-- maintainance then it may not be too unwieldy.
327−
328−data FromParserK b e c = FPKDone !b | FPKError !e | FPKCont c
193+data FromParserK b e c = FPKDone !Int !b | FPKError !e | FPKCont c
329194
330195-- | Convert a CPS style 'Parser' to a direct style 'D.Parser'.
331196--
@@ -338,25 +203,24 @@ fromParserK parser = D.Parser step initial extract
338203 where
339204
340205 initial = do
341− r <- runParser parser Z.nil parserDone
206+ r <- runParser parser 0 (0,0) parserDone
342207 return $ case r of
343− Stop 0 b -> FPKDone b
344− Stop _ _ -> error "Bug: fromParserK: Stop n in initial"
208+ Stop n b -> FPKDone n b
345209 Failed e -> FPKError e
346− Partial cont -> FPKCont cont -- XXX can we get this?
347− Continue cont -> FPKCont cont
210+ Partial _ cont -> FPKCont cont -- XXX can we get this?
211+ Continue _ cont -> FPKCont cont
348212
349− step (FPKDone b) _ = return $ D.Done 1 b
213+ step (FPKDone n b) _ = return $ D.Done (n + 1) b
350214 step (FPKError e) _ = return $ D.Error e
351215 step (FPKCont cont) a = do
352216 r <- cont (Just a)
353217 return $ case r of
354218 Stop n b -> D.Done n b
355219 Failed e -> D.Error e
356− Partial cont1 -> D.Partial 0 (FPKCont cont1)
357− Continue cont1 -> D.Continue 0 (FPKCont cont1)
220+ Partial n cont1 -> D.Partial n (FPKCont cont1)
221+ Continue n cont1 -> D.Continue n (FPKCont cont1)
358222
359− extract (FPKDone b) = return b
223+ extract (FPKDone _ b) = return b
360224 extract (FPKError e) = throwM $ D.ParseError e
361225 extract (FPKCont cont) = extractParse cont
362226
@@ -375,9 +239,9 @@ fromParserK parser = D.Parser step initial extract
375239--
376240instance Functor m => Functor (Parser m a) where
377241 {-# INLINE fmap #-}
378− fmap f parser = MkParser $ \zipper yieldk ->
379− let yld z res = yieldk z (fmap f res)
380− in runParser parser zipper yld
242+ fmap f parser = MkParser $ \lo st yieldk ->
243+ let yld s res = yieldk s (fmap f res)
244+ in runParser parser lo st yld
381245
382246-------------------------------------------------------------------------------
383247-- Sequential applicative
@@ -391,7 +255,7 @@ instance Functor m => Functor (Parser m a) where
391255--
392256{-# INLINE yield #-}
393257yield :: b -> Parser m a b
394−yield b = MkParser (\zipper yieldk -> yieldk zipper (Done b))
258+yield b = MkParser (\lo st yieldk -> yieldk st (Done (lo + 1) b))
395259
396260-- | 'Applicative' form of 'Streamly.Internal.Data.Parser.splitWith'. Note that
397261-- this operation does not fuse, use 'Streamly.Internal.Data.Parser.splitWith'
@@ -405,17 +269,19 @@ instance Monad m => Applicative (Parser m a) where
405269 (<*>) = ap
406270
407271 {-# INLINE (*>) #-}
408− m1 *> m2 = MkParser $ \zipper yieldk ->
409− let yield1 z (Done _) = runParser m2 z yieldk
410− yield1 z (Error e) = yieldk z (Error e)
411− in runParser m1 zipper yield1
272+ m1 *> m2 = MkParser $ \lo st yieldk ->
273+ let yield1 s (Done n _) = runParser m2 n s yieldk
274+ yield1 s (Error e) = yieldk s (Error e)
275+ in runParser m1 lo st yield1
412276
413277 {-# INLINE (<*) #-}
414− m1 <* m2 = MkParser $ \zipper yieldk ->
415− let
416− yield1 z (Done b) = runParser m2 z $ \z1 _ -> yieldk z1 (Done b)
417− yield1 z (Error e) = yieldk z (Error e)
418− in runParser m1 zipper yield1
278+ m1 <* m2 = MkParser $ \lo st yieldk ->
279+ let yield1 s (Done n b) =
280+ let yield2 s1 (Done n1 _) = yieldk s1 (Done n1 b)
281+ yield2 s1 (Error e) = yieldk s1 (Error e)
282+ in runParser m2 n s yield2
283+ yield1 s (Error e) = yieldk s (Error e)
284+ in runParser m1 lo st yield1
419285
420286-------------------------------------------------------------------------------
421287-- Monad
@@ -430,7 +296,7 @@ instance Monad m => Applicative (Parser m a) where
430296--
431297{-# INLINE die #-}
432298die :: String -> Parser m a b
433−die err = MkParser (\z yieldk -> yieldk z (Error err))
299+die err = MkParser (\_ st yieldk -> yieldk st (Error err))
434300
435301-- | Monad composition can be used for lookbehind parsers, we can make the
436302-- future parses depend on the previously parsed values.
@@ -479,11 +345,13 @@ instance Monad m => Monad (Parser m a) where
479345 return = pure
480346
481347 {-# INLINE (>>=) #-}
482− m >>= k = MkParser $ \zipper yieldk ->
483− let
484− yield1 z (Done b) = runParser (k b) z yieldk
485− yield1 z (Error e) = yieldk z (Error e)
486− in runParser m zipper yield1
348+ m >>= k = MkParser $ \lo st yieldk ->
349+ let yield1 s (Done n b) = runParser (k b) n s yieldk
350+ yield1 s (Error e) = yieldk s (Error e)
351+ in runParser m lo st yield1
352+
353+ {-# INLINE (>>) #-}
354+ (>>) = (*>)
487355
488356#if !(MIN_VERSION_base(4,13,0))
489357 -- This is redefined instead of just being Fail.fail to be
@@ -502,13 +370,6 @@ instance Monad m => Fail.MonadFail (Parser m a) where
502370-- Alternative
503371-------------------------------------------------------------------------------
504372
505−-- XXX one way to backtrack is to ask the input driver to create and release
506−-- checkpoints, like we do in the zipper. The other way is to pass around the
507−-- zipper itself. Currently in the direct style code we manage the checkpoints
508−-- manually by counting the input. We need to unify the CPS and direct style
509−-- code by either using a zipper in both or by using checkpointing commands for
510−-- the driver.
511−--
512373-- | 'Alternative' form of 'Streamly.Internal.Data.Parser.alt'. Backtrack and
513374-- run the second parser if the first one fails.
514375--
@@ -527,10 +388,11 @@ instance Monad m => Alternative (Parser m a) where
527388 empty = die "empty"
528389
529390 {-# INLINE (<|>) #-}
530− m1 <|> m2 = MkParser $ \zipper yieldk ->
531− let yield1 z (Done b) = yieldk (Z.release z) (Done b)
532− yield1 z (Error _) = runParser m2 (Z.restore z) yieldk
533− in runParser m1 (Z.checkpoint zipper) yield1
391+ m1 <|> m2 = MkParser $ \lo (level, _) yieldk ->
392+ let yield1 (0, _) _ = error "0 nest level in Alternative"
393+ yield1 (lvl, _) (Done n b) = yieldk (lvl - 1, 0) (Done n b)
394+ yield1 (lvl, cnt) (Error _) = runParser m2 cnt (lvl - 1, 0) yieldk
395+ in runParser m1 lo (level + 1, 0) yield1
534396
535397 -- some and many are implemented here instead of using default definitions
536398 -- so that we can use INLINE on them. It gives 50% performance improvement.