streamly-core-0.3.0: src/Streamly/Internal/Data/Producer/Source.hs
-- |
-- Module : Streamly.Internal.Data.Producer.Source
-- Copyright : (c) 2021 Composewell Technologies
-- License : BSD-3-Clause
-- Maintainer : streamly@composewell.com
-- Stability : experimental
-- Portability : GHC
--
-- A 'Source' is a seed that can be unfolded to a stream with a buffer. Allows
-- to 'unread' data i.e. push unused data back to the source buffer. This is
-- useful in parsing applications with backtracking.
--
module Streamly.Internal.Data.Producer.Source
( Source
-- * Creation
, source
-- * Transformation
, unread
-- * Consumption
, isEmpty
, producer
-- * Parsing
, parse
, parseMany
, parseManyD
)
where
#include "inline.hs"
import Control.Exception (assert)
import GHC.Exts (SpecConstrAnnotation(..))
import GHC.Types (SPEC(..))
import Streamly.Internal.Data.Parser
(ParseError(..), ParseErrorPos(..), Step(..), Final(..))
import Streamly.Internal.Data.Producer.Type (Producer(..))
import Streamly.Internal.Data.Stream.Step (Step(..))
import qualified Streamly.Internal.Data.Parser as ParserD
-- import qualified Streamly.Internal.Data.Parser.ParserK.Type as ParserK
import Prelude hiding (read)
-- | A seed with a buffer. It allows us to 'unread' or return some data
-- after reading it. Useful in backtracked parsing.
--
data Source a b = Source [b] (Maybe a)
-- | Make a source from a seed value. The buffer would start as empty.
--
-- /Pre-release/
source :: Maybe a -> Source a b
source = Source []
-- | Return some unused data back to the source. The data is prepended (or
-- consed) to the source.
--
-- /Pre-release/
unread :: [b] -> Source a b -> Source a b
unread xs (Source ys seed) = Source (xs ++ ys) seed
-- | Determine if the source is empty.
isEmpty :: Source a b -> Bool
isEmpty (Source [] Nothing) = True
isEmpty _ = False
-- | Convert a producer to a producer from a buffered source. Any buffered data
-- is read first and then the seed is unfolded.
--
-- /Pre-release/
{-# INLINE_NORMAL producer #-}
producer :: Monad m => Producer m a b -> Producer m (Source a b) b
producer (Producer step1 inject1 extract1) = Producer step inject extract
where
inject (Source [] (Just a)) = do
s <- inject1 a
return $ Left s
inject (Source xs a) = return $ Right (xs, a)
{-# INLINE_LATE step #-}
step (Left s) = do
r <- step1 s
return $ case r of
Yield x s1 -> Yield x (Left s1)
Skip s1 -> Skip (Left s1)
Stop -> Stop
step (Right ([], Nothing)) = return Stop
step (Right ([], Just _)) = error "Bug: unreachable"
step (Right (x:[], Just a)) = do
s <- inject1 a
return $ Yield x (Left s)
step (Right (x:xs, a)) = return $ Yield x (Right (xs, a))
extract (Left s) = Source [] . Just <$> extract1 s
extract (Right (xs, a)) = return $ Source xs a
-------------------------------------------------------------------------------
-- Parsing
-------------------------------------------------------------------------------
-- GHC parser does not accept {-# ANN type [] NoSpecConstr #-}, so we need
-- to make a newtype.
{-# ANN type List NoSpecConstr #-}
newtype List a = List {getList :: [a]}
{-# INLINE_NORMAL parse #-}
parse
:: Monad m =>
ParserD.Parser a m b
-> Producer m (Source s a) a
-> Source s a
-> m (Either ParseErrorPos b, Source s a)
parse
(ParserD.Parser pstep initial extract)
(Producer ustep uinject uextract)
seed = do
res <- initial
case res of
ParserD.IPartial s -> do
state <- uinject seed
go SPEC state (List []) s 0
ParserD.IDone b -> return (Right b, seed)
ParserD.IError err -> return (Left (ParseErrorPos 0 err), seed)
where
-- XXX currently we are using a dumb list based approach for backtracking
-- buffer. This can be replaced by a sliding/ring buffer using Data.Array.
-- That will allow us more efficient random back and forth movement.
go !_ st buf !pst i = do
r <- ustep st
case r of
Yield x s -> do
pRes <- pstep pst x
case pRes of
SPartial 1 pst1 -> go SPEC s (List []) pst1 i
SPartial m pst1 -> do
let n = 1 - m
assert (n <= length (x:getList buf)) (return ())
let src0 = Prelude.take n (x:getList buf)
src = Prelude.reverse src0
gobuf SPEC s (List []) (List src) pst1 (i + 1 - n)
SContinue 1 pst1 -> go SPEC s (List (x:getList buf)) pst1 (i + 1)
SContinue m pst1 -> do
let n = 1 - m
assert (n <= length (x:getList buf)) (return ())
let (src0, buf1) = splitAt n (x:getList buf)
src = Prelude.reverse src0
gobuf SPEC s (List buf1) (List src) pst1 (i + 1 - n)
SDone m b -> do
let n = 1 - m
assert (n <= length (x:getList buf)) (return ())
let src0 = Prelude.take n (x:getList buf)
src = Prelude.reverse src0
s1 <- uextract s
return (Right b, unread src s1)
SError err -> do
s1 <- uextract s
let src = Prelude.reverse (getList buf)
return
( Left (ParseErrorPos (i + 1) err)
, unread (src ++ [x]) s1
)
Skip s -> go SPEC s buf pst i
Stop -> goStop buf pst i
gobuf !_ s buf (List []) !pst i = go SPEC s buf pst i
gobuf !_ s buf (List (x:xs)) !pst i = do
pRes <- pstep pst x
case pRes of
SPartial 1 pst1 ->
gobuf SPEC s (List []) (List xs) pst1 (i + 1)
SPartial m pst1 -> do
let n = 1 - m
assert (n <= length (x:getList buf)) (return ())
let src0 = Prelude.take n (x:getList buf)
src = Prelude.reverse src0 ++ xs
gobuf SPEC s (List []) (List src) pst1 (i + 1 - n)
SContinue 1 pst1 ->
gobuf SPEC s (List (x:getList buf)) (List xs) pst1 (i + 1)
SContinue m pst1 -> do
let n = 1 - m
assert (n <= length (x:getList buf)) (return ())
let (src0, buf1) = splitAt n (x:getList buf)
src = Prelude.reverse src0 ++ xs
gobuf SPEC s (List buf1) (List src) pst1 (i + 1 - n)
SDone m b -> do
let n = 1 - m
assert (n <= length (x:getList buf)) (return ())
let src0 = Prelude.take n (x:getList buf)
src = Prelude.reverse src0
s1 <- uextract s
return (Right b, unread src s1)
SError err -> do
s1 <- uextract s
let src = Prelude.reverse (getList buf)
return
( Left (ParseErrorPos (i + 1) err)
, unread (src ++ (x:xs)) s1
)
-- This is a simplified gobuf
goExtract !_ buf (List []) !pst i = goStop buf pst i
goExtract !_ buf (List (x:xs)) !pst i = do
pRes <- pstep pst x
case pRes of
SPartial 1 pst1 ->
goExtract SPEC (List []) (List xs) pst1 (i + 1)
SPartial m pst1 -> do
let n = 1 - m
assert (n <= length (x:getList buf)) (return ())
let src0 = Prelude.take n (x:getList buf)
src = Prelude.reverse src0 ++ xs
goExtract SPEC (List []) (List src) pst1 (i + 1 - n)
SContinue 1 pst1 ->
goExtract SPEC (List (x:getList buf)) (List xs) pst1 (i + 1)
SContinue m pst1 -> do
let n = 1 - m
assert (n <= length (x:getList buf)) (return ())
let (src0, buf1) = splitAt n (x:getList buf)
src = Prelude.reverse src0 ++ xs
goExtract SPEC (List buf1) (List src) pst1 (i + 1 - n)
SDone m b -> do
let n = 1 - m
assert (n <= length (x:getList buf)) (return ())
let src0 = Prelude.take n (x:getList buf)
src = Prelude.reverse src0
return (Right b, unread src (source Nothing))
SError err -> do
let src = Prelude.reverse (getList buf)
return
( Left (ParseErrorPos (i + 1) err)
, unread (src ++ (x:xs)) (source Nothing)
)
-- This is a simplified goExtract
{-# INLINE goStop #-}
goStop buf pst i = do
pRes <- extract pst
case pRes of
FContinue 0 pst1 ->
goStop buf pst1 i
FContinue m pst1 -> do
let n = (- m)
assert (n <= length (getList buf)) (return ())
let (src0, buf1) = splitAt n (getList buf)
src = Prelude.reverse src0
goExtract SPEC (List buf1) (List src) pst1 (i - n)
FDone 0 b -> return (Right b, source Nothing)
FDone m b -> do
let n = (- m)
assert (n <= length (getList buf)) (return ())
let src0 = Prelude.take n (getList buf)
src = Prelude.reverse src0
return (Right b, unread src (source Nothing))
FError err -> do
let src = Prelude.reverse (getList buf)
return (Left (ParseErrorPos i err), unread src (source Nothing))
{-
-- | Parse a buffered source using a parser, returning the parsed value and the
-- remaining source.
--
-- /Pre-release/
{-# INLINE [3] parseK #-}
parseK :: Monad m =>
ParserK.Parser a m b
-> Producer m (Source s a) a
-> Source s a
-> m (Either ParseError b, Source s a)
parseK = parse . ParserK.toParser
-}
-------------------------------------------------------------------------------
-- Nested parsing
-------------------------------------------------------------------------------
{-# INLINE parseManyD #-}
parseManyD :: Monad m =>
ParserD.Parser a m b
-> Producer m (Source x a) a
-> Producer m (Source x a) (Either ParseError b)
parseManyD parser reader = Producer step return return
where
{-# INLINE_LATE step #-}
step src = do
if isEmpty src
then return Stop
else do
(b, s1) <- parse parser reader src
case b of
Right b1 -> return $ Yield (Right b1) s1
Left _ -> return Stop
-- | Apply a parser repeatedly on a buffered source producer to generate a
-- producer of parsed values.
--
-- /Pre-release/
{-# INLINE parseMany #-}
parseMany :: Monad m =>
ParserD.Parser a m b
-> Producer m (Source x a) a
-> Producer m (Source x a) (Either ParseError b)
parseMany = parseManyD