git.iko.soy/streamly
on master help sign in
Add singular generic version of continuation parsing
commit4995dc181ffbba5f0a06d08df2e780935fee2036 authorAdithya Kumar <adithya@composewell.com> dateSun 6 Aug 2023, 13:45 (3 years ago) parent7e761ca
2 files changed+228
compare with master
unifiedsplit
core/src/Streamly/Internal/Data/Parser/ParserK/Type.hs+97 core/src/Streamly/Internal/Data/StreamK.hs+131
core/src/Streamly/Internal/Data/Parser/ParserK/Type.hs+97
@@ -28,6 +28,7 @@ module Streamly.Internal.Data.Parser.ParserK.Type
2828 , ParseResult (..)
2929 , ParserK (..)
3030 , fromParser
31+ , fromParserSingular
3132 -- , toParser
3233 , fromPure
3334 , fromEffect
@@ -503,6 +504,102 @@ fromParser :: (Monad m, Unbox a) => ParserD.Parser a m b -> ParserK (Array a) m
503504fromParser (ParserD.Parser step initial extract) =
504505 MkParser $ parseDToK step initial extract
505506
507+{-# INLINE parseDToKSingular #-}
508+parseDToKSingular
509+ :: forall m a s b r. (Monad m)
510+ => (s -> a -> m (ParserD.Step s b))
511+ -> m (ParserD.Initial s b)
512+ -> (s -> m (ParserD.Step s b))
513+ -> (ParseResult b -> Int -> Input a -> m (Step a m r))
514+ -> Int
515+ -> Int
516+ -> Input a
517+ -> m (Step a m r)
518+parseDToKSingular pstep initial extract cont !relPos !usedCount !input = do
519+ res <- initial
520+ case res of
521+ ParserD.IPartial pst -> do
522+ -- XXX can we come here with relPos 1?
523+ if relPos == 0
524+ then
525+ case input of
526+ Chunk arr -> parseContChunk usedCount pst arr
527+ None -> parseContNothing usedCount pst
528+ -- XXX Previous code was using Continue in this case
529+ else pure $ Partial relPos (parseCont usedCount pst)
530+ ParserD.IDone b -> cont (Success relPos b) usedCount input
531+ ParserD.IError err -> cont (Failure relPos err) usedCount input
532+
533+ where
534+
535+ -- XXX We can maintain an absolute position instead of relative that will
536+ -- help in reporting of error location in the stream.
537+ {-# NOINLINE parseContChunk #-}
538+ parseContChunk !count !state x = do
539+ go SPEC state
540+
541+ where
542+
543+ go !_ !pst = do
544+ pRes <- pstep pst x
545+ case pRes of
546+ ParserD.Done 0 b ->
547+ cont (Success 1 b) (count + 1) (Chunk x)
548+ ParserD.Done 1 b ->
549+ cont (Success 0 b) count (Chunk x)
550+ ParserD.Done n b ->
551+ cont (Success (1 - n) b) (count + 1 - n) (Chunk x)
552+ ParserD.Partial 0 pst1 ->
553+ pure $ Partial 1 (parseCont (count + 1) pst1)
554+ ParserD.Partial 1 pst1 ->
555+ -- XXX Since we got Partial, the driver should drop the
556+ -- buffer, we should call the driver here?
557+ go SPEC pst1
558+ ParserD.Partial n pst1 ->
559+ pure $ Partial (1 - n) (parseCont (count + 1 - n) pst1)
560+ ParserD.Continue 0 pst1 ->
561+ pure $ Continue 1 (parseCont (count + 1) pst1)
562+ ParserD.Continue 1 pst1 ->
563+ go SPEC pst1
564+ ParserD.Continue n pst1 ->
565+ pure $ Continue (1 - n) (parseCont (count + 1 - n) pst1)
566+ ParserD.Error err ->
567+ -- XXX fix undefined
568+ cont (Failure 0 err) count (Chunk x)
569+
570+ {-# NOINLINE parseContNothing #-}
571+ parseContNothing !count !pst = do
572+ r <- extract pst
573+ case r of
574+ -- IMPORTANT: the n here is from the byte stream parser, that means
575+ -- it is the backtrack element count and not the stream position
576+ -- index into the current input array.
577+ ParserD.Done n b ->
578+ assert (n >= 0)
579+ (cont (Success (- n) b) (count - n) None)
580+ ParserD.Continue n pst1 ->
581+ assert (n >= 0)
582+ (return $ Continue (- n) (parseCont (count - n) pst1))
583+ ParserD.Error err ->
584+ -- XXX It is called only when there is no input arr. So using 0
585+ -- as the position is correct?
586+ cont (Failure 0 err) count None
587+ ParserD.Partial _ _ -> error "Bug: parseDToK Partial unreachable"
588+
589+ -- XXX Maybe we can use two separate continuations instead of using
590+ -- Just/Nothing cases here. That may help in avoiding the parseContJust
591+ -- function call.
592+ {-# INLINE parseCont #-}
593+ parseCont !cnt !pst (Chunk arr) = parseContChunk cnt pst arr
594+ parseCont !cnt !pst None = parseContNothing cnt pst
595+
596+-- | Similar to "fromParser" but for singular elements.
597+--
598+{-# INLINE_LATE fromParserSingular #-}
599+fromParserSingular :: Monad m => ParserD.Parser a m b -> ParserK a m b
600+fromParserSingular (ParserD.Parser step initial extract) =
601+ MkParser $ parseDToKSingular step initial extract
602+
506603{-
507604-------------------------------------------------------------------------------
508605-- Convert CPS style 'Parser' to direct style 'D.Parser'
core/src/Streamly/Internal/Data/StreamK.hs+131
@@ -47,6 +47,8 @@ module Streamly.Internal.Data.StreamK
4747 , parseD
4848 , parseBreakChunks
4949 , parseChunks
50+ , parseBreakSingular
51+ , parseSingular
5052
5153 -- ** Specialized Folds
5254 , head
@@ -1424,6 +1426,135 @@ parseChunks :: (Monad m, Unbox a) =>
14241426 ParserK (Array a) m b -> StreamK m (Array a) -> m (Either ParseError b)
14251427parseChunks f = fmap fst . parseBreakChunks f
14261428
1429+-------------------------------------------------------------------------------
1430+-- Parsing using ParserK.Generic
1431+-------------------------------------------------------------------------------
1432+
1433+{-# INLINE backTrackSingular #-}
1434+backTrackSingular :: Int -> [a] -> StreamK m a -> (StreamK m a, [a])
1435+backTrackSingular = go
1436+
1437+ where
1438+
1439+ go _ [] stream = (stream, [])
1440+ go n xs stream | n <= 0 = (stream, xs)
1441+ go n xs stream =
1442+ let (appendBuf, newBTBuf) = splitAt n xs
1443+ in (append (fromList (Prelude.reverse appendBuf)) stream, newBTBuf)
1444+
1445+
1446+-- | Similar to 'parseBreak' but works on singular elements.
1447+--
1448+{-# INLINE_NORMAL parseBreakSingular #-}
1449+parseBreakSingular
1450+ :: forall m a b. Monad m
1451+ => ParserK.ParserK a m b
1452+ -> StreamK m a
1453+ -> m (Either ParseError b, StreamK m a)
1454+parseBreakSingular parser input = do
1455+ let parserk = ParserK.runParser parser parserDone 0 0
1456+ in go [] parserk input
1457+
1458+ where
1459+
1460+ {-# INLINE goStop #-}
1461+ goStop
1462+ :: [a]
1463+ -> (ParserK.Input a -> m (ParserK.Step a m b))
1464+ -> m (Either ParseError b, StreamK m a)
1465+ goStop backBuf parserk = do
1466+ pRes <- parserk ParserK.None
1467+ case pRes of
1468+ -- If we stop in an alternative, it will try calling the next
1469+ -- parser, the next parser may call initial returning Partial and
1470+ -- then immediately we have to call extract on it.
1471+ ParserK.Partial 0 cont1 ->
1472+ go [] cont1 nil
1473+ ParserK.Partial n cont1 -> do
1474+ let n1 = negate n
1475+ assertM(n1 >= 0 && n1 <= length backBuf)
1476+ let (s1, backBuf1) = backTrackSingular n1 backBuf nil
1477+ in go backBuf1 cont1 s1
1478+ ParserK.Continue 0 cont1 ->
1479+ go backBuf cont1 nil
1480+ ParserK.Continue n cont1 -> do
1481+ let n1 = negate n
1482+ assertM(n1 >= 0 && n1 <= length backBuf)
1483+ let (s1, backBuf1) = backTrackSingular n1 backBuf nil
1484+ in go backBuf1 cont1 s1
1485+ ParserK.Done 0 b ->
1486+ return (Right b, nil)
1487+ ParserK.Done n b -> do
1488+ let n1 = negate n
1489+ assertM(n1 >= 0 && n1 <= length backBuf)
1490+ let (s1, _) = backTrackSingular n1 backBuf nil
1491+ in return (Right b, s1)
1492+ ParserK.Error _ err -> return (Left (ParseError err), nil)
1493+
1494+ seekErr n =
1495+ error $ "parseBreakSingular: Partial: forward seek not implemented n = "
1496+ ++ show n
1497+
1498+ yieldk
1499+ :: [a]
1500+ -> (ParserK.Input a -> m (ParserK.Step a m b))
1501+ -> a
1502+ -> StreamK m a
1503+ -> m (Either ParseError b, StreamK m a)
1504+ yieldk backBuf parserk arr stream = do
1505+ pRes <- parserk (ParserK.Chunk arr)
1506+ case pRes of
1507+ ParserK.Partial 1 cont1 -> go [] cont1 stream
1508+ ParserK.Partial 0 cont1 -> go [] cont1 (cons arr stream)
1509+ ParserK.Partial n _ | n > 1 -> seekErr n
1510+ ParserK.Partial n cont1 -> do
1511+ let n1 = negate n
1512+ bufLen = length backBuf
1513+ s = cons arr stream
1514+ assertM(n1 >= 0 && n1 <= bufLen)
1515+ let (s1, _) = backTrackSingular n1 backBuf s
1516+ go [] cont1 s1
1517+ ParserK.Continue 1 cont1 -> go (arr:backBuf) cont1 stream
1518+ ParserK.Continue 0 cont1 ->
1519+ go backBuf cont1 (cons arr stream)
1520+ ParserK.Continue n _ | n > 1 -> seekErr n
1521+ ParserK.Continue n cont1 -> do
1522+ let n1 = negate n
1523+ bufLen = length backBuf
1524+ s = cons arr stream
1525+ assertM(n1 >= 0 && n1 <= bufLen)
1526+ let (s1, backBuf1) = backTrackSingular n1 backBuf s
1527+ go backBuf1 cont1 s1
1528+ ParserK.Done 1 b -> pure (Right b, stream)
1529+ ParserK.Done 0 b -> pure (Right b, cons arr stream)
1530+ ParserK.Done n _ | n > 1 -> seekErr n
1531+ ParserK.Done n b -> do
1532+ let n1 = negate n
1533+ bufLen = length backBuf
1534+ s = cons arr stream
1535+ assertM(n1 >= 0 && n1 <= bufLen)
1536+ let (s1, _) = backTrackSingular n1 backBuf s
1537+ pure (Right b, s1)
1538+ ParserK.Error _ err -> return (Left (ParseError err), nil)
1539+
1540+ go
1541+ :: [a]
1542+ -> (ParserK.Input a -> m (ParserK.Step a m b))
1543+ -> StreamK m a
1544+ -> m (Either ParseError b, StreamK m a)
1545+ go backBuf parserk stream = do
1546+ let stop = goStop backBuf parserk
1547+ single a = yieldk backBuf parserk a nil
1548+ in foldStream
1549+ defState (yieldk backBuf parserk) single stop stream
1550+
1551+-- | Run a 'ParserK' over a 'StreamK'. Please use 'parseChunks' where possible,
1552+-- for better performance.
1553+{-# INLINE parseSingular #-}
1554+parseSingular :: Monad m =>
1555+ ParserK.ParserK a m b -> StreamK m a -> m (Either ParseError b)
1556+parseSingular f = fmap fst . parseBreakSingular f
1557+
14271558-------------------------------------------------------------------------------
14281559-- Sorting
14291560-------------------------------------------------------------------------------