@@ -6,8 +6,8 @@
66-- Stability : experimental
77-- Portability : GHC
88--
9−-- A stream source which can be unfolded with some possibly buffered data.
10−-- Allows to 'unread' data i.e. push unused data back to the source. This is
9+-- A 'Source' is a seed that can be unfolded to a stream with a buffer. Allows
10+-- to 'unread' data i.e. push unused data back to the source buffer. This is
1111-- useful in parsing applications with backtracking.
1212--
1313
@@ -23,25 +23,35 @@ module Streamly.Internal.Data.Producer.Source
2323 -- * Consumption
2424 , isEmpty
2525 , producer
26+
27+ -- * Parsing
28+ , parse
29+ , parseMany
30+ , parseManyD
2631 )
2732where
2833
2934#include "inline.hs"
3035
31−import Streamly.Internal.Data.Stream.StreamD.Step (Step(..))
36+import Control.Exception (assert)
37+import Control.Monad.Catch (MonadThrow, throwM)
38+import GHC.Exts (SpecConstrAnnotation(..))
39+import GHC.Types (SPEC(..))
40+import Streamly.Internal.Data.Parser.ParserD (ParseError(..), Step(..))
3241import Streamly.Internal.Data.Producer.Type (Producer(..))
42+import Streamly.Internal.Data.Stream.StreamD.Step (Step(..))
43+
44+import qualified Streamly.Internal.Data.Parser.ParserD as ParserD
45+import qualified Streamly.Internal.Data.Parser.ParserK.Types as ParserK
46+
3347import Prelude hiding (read)
3448
35−-- XXX instead of a seed should we wrap a Producer in a source? Then we won't
36−-- have to supply a Producer for read.
37−--
38−-- | An unfold seed with some buffered data. It allows us to 'unread' or return
39−-- some data after reading it. Useful in backtracked parsing.
49+-- | A seed with a buffer. It allows us to 'unread' or return some data
50+-- after reading it. Useful in backtracked parsing.
4051--
4152data Source a b = Source [b] (Maybe a)
4253
43−-- | Make a source from a seed value. The buffer would start as empty. You can
44−-- use 'unread' to add to the buffer.
54+-- | Make a source from a seed value. The buffer would start as empty.
4555--
4656-- /Internal/
4757source :: Maybe a -> Source a b
@@ -54,12 +64,13 @@ source = Source []
5464unread :: [b] -> Source a b -> Source a b
5565unread xs (Source ys seed) = Source (xs ++ ys) seed
5666
67+-- | Determine if the source is empty.
5768isEmpty :: Source a b -> Bool
5869isEmpty (Source [] Nothing) = True
5970isEmpty _ = False
6071
61−-- | An unfold to read from a 'Source'. If the buffer has data then it is read
62−-- first and then the seed is unfolded using the supplied unfold.
72+-- | Convert a producer to a producer from a buffered source. Any buffered data
73+-- is read first and then the seed is unfolded.
6374--
6475-- /Internal/
6576{-# INLINE_NORMAL producer #-}
@@ -89,3 +100,134 @@ producer (Producer step1 inject1 extract1) = Producer step inject extract
89100
90101 extract (Left s) = Source [] . Just <$> extract1 s
91102 extract (Right (xs, a)) = return $ Source xs a
103+
104+-------------------------------------------------------------------------------
105+-- Parsing
106+-------------------------------------------------------------------------------
107+
108+-- GHC parser does not accept {-# ANN type [] NoSpecConstr #-}, so we need
109+-- to make a newtype.
110+{-# ANN type List NoSpecConstr #-}
111+newtype List a = List {getList :: [a]}
112+
113+{-# INLINE_NORMAL parseD #-}
114+parseD
115+ :: MonadThrow m
116+ => ParserD.Parser m a b
117+ -> Producer m (Source s a) a
118+ -> Source s a
119+ -> m (b, Source s a)
120+parseD
121+ (ParserD.Parser pstep initial extract)
122+ (Producer ustep uinject uextract)
123+ seed = do
124+
125+ state <- uinject seed
126+ initial >>= go SPEC state (List [])
127+
128+ where
129+
130+ -- XXX currently we are using a dumb list based approach for backtracking
131+ -- buffer. This can be replaced by a sliding/ring buffer using Data.Array.
132+ -- That will allow us more efficient random back and forth movement.
133+ {-# INLINE go #-}
134+ go !_ st buf !pst = do
135+ r <- ustep st
136+ case r of
137+ Yield x s -> do
138+ pRes <- pstep pst x
139+ case pRes of
140+ Partial 0 pst1 -> go SPEC s (List []) pst1
141+ Partial n pst1 -> do
142+ assert (n <= length (x:getList buf)) (return ())
143+ let src0 = Prelude.take n (x:getList buf)
144+ src = Prelude.reverse src0
145+ gobuf SPEC s (List []) (List src) pst1
146+ Continue 0 pst1 -> go SPEC s (List (x:getList buf)) pst1
147+ Continue n pst1 -> do
148+ assert (n <= length (x:getList buf)) (return ())
149+ let (src0, buf1) = splitAt n (x:getList buf)
150+ src = Prelude.reverse src0
151+ gobuf SPEC s (List buf1) (List src) pst1
152+ Done n b -> do
153+ assert (n <= length (x:getList buf)) (return ())
154+ let src0 = Prelude.take n (x:getList buf)
155+ src = Prelude.reverse src0
156+ s1 <- uextract s
157+ return (b, unread src s1)
158+ Error err -> throwM $ ParseError err
159+ Skip s -> go SPEC s buf pst
160+ Stop -> do
161+ b <- extract pst
162+ return (b, unread (reverse $ getList buf) (source Nothing))
163+
164+ gobuf !_ s buf (List []) !pst = go SPEC s buf pst
165+ gobuf !_ s buf (List (x:xs)) !pst = do
166+ pRes <- pstep pst x
167+ case pRes of
168+ Partial 0 pst1 ->
169+ gobuf SPEC s (List []) (List xs) pst1
170+ Partial n pst1 -> do
171+ assert (n <= length (x:getList buf)) (return ())
172+ let src0 = Prelude.take n (x:getList buf)
173+ src = Prelude.reverse src0 ++ xs
174+ gobuf SPEC s (List []) (List src) pst1
175+ Continue 0 pst1 ->
176+ gobuf SPEC s (List (x:getList buf)) (List xs) pst1
177+ Continue n pst1 -> do
178+ assert (n <= length (x:getList buf)) (return ())
179+ let (src0, buf1) = splitAt n (x:getList buf)
180+ src = Prelude.reverse src0 ++ xs
181+ gobuf SPEC s (List buf1) (List src) pst1
182+ Done n b -> do
183+ assert (n <= length (x:getList buf)) (return ())
184+ let src0 = Prelude.take n (x:getList buf)
185+ src = Prelude.reverse src0
186+ s1 <- uextract s
187+ return (b, unread src s1)
188+ Error err -> throwM $ ParseError err
189+
190+-- | Parse a buffered source using a parser, returning the parsed value and the
191+-- remaining source.
192+--
193+-- /Internal/
194+{-# INLINE [3] parse #-}
195+parse
196+ :: MonadThrow m
197+ => ParserK.Parser m a b
198+ -> Producer m (Source s a) a
199+ -> Source s a
200+ -> m (b, Source s a)
201+parse = parseD . ParserK.fromParserK
202+
203+-------------------------------------------------------------------------------
204+-- Nested parsing
205+-------------------------------------------------------------------------------
206+
207+{-# INLINE parseManyD #-}
208+parseManyD :: MonadThrow m =>
209+ ParserD.Parser m a b
210+ -> Producer m (Source x a) a
211+ -> Producer m (Source x a) b
212+parseManyD parser reader = Producer step return return
213+
214+ where
215+
216+ {-# INLINE_LATE step #-}
217+ step src = do
218+ if isEmpty src
219+ then return Stop
220+ else do
221+ (b, s1) <- parseD parser reader src
222+ return $ Yield b s1
223+
224+-- | Apply a parser repeatedly on a buffered source producer to generate a
225+-- producer of parsed values.
226+--
227+-- /Internal/
228+{-# INLINE parseMany #-}
229+parseMany :: MonadThrow m =>
230+ ParserK.Parser m a b
231+ -> Producer m (Source x a) a
232+ -> Producer m (Source x a) b
233+parseMany parser = parseManyD (ParserK.fromParserK parser)