git.iko.soy/streamly
on defafa6 help sign in
streamly/core/src/Streamly/Internal/Data/Producer/Source.hs
303 lines 11 kB history raw
1-- |
2-- Module : Streamly.Internal.Data.Producer.Source
3-- Copyright : (c) 2021 Composewell Technologies
4-- License : BSD-3-Clause
5-- Maintainer : streamly@composewell.com
6-- Stability : experimental
7-- Portability : GHC
8--
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
11-- useful in parsing applications with backtracking.
12--
14module Streamly.Internal.Data.Producer.Source
15 ( Source
17 -- * Creation
18 , source
20 -- * Transformation
21 , unread
23 -- * Consumption
24 , isEmpty
25 , producer
27 -- * Parsing
28 , parse
29 , parseMany
30 , parseManyD
31 )
32where
34#include "inline.hs"
36import Control.Exception (assert)
37import GHC.Exts (SpecConstrAnnotation(..))
38import GHC.Types (SPEC(..))
39import Streamly.Internal.Data.Parser (ParseError(..), Step(..))
40import Streamly.Internal.Data.Producer.Type (Producer(..))
41import Streamly.Internal.Data.Stream.Step (Step(..))
43import qualified Streamly.Internal.Data.Parser as ParserD
44-- import qualified Streamly.Internal.Data.Parser.ParserK.Type as ParserK
46import Prelude hiding (read)
48-- | A seed with a buffer. It allows us to 'unread' or return some data
49-- after reading it. Useful in backtracked parsing.
50--
51data Source a b = Source [b] (Maybe a)
53-- | Make a source from a seed value. The buffer would start as empty.
54--
55-- /Pre-release/
56source :: Maybe a -> Source a b
57source = Source []
59-- | Return some unused data back to the source. The data is prepended (or
60-- consed) to the source.
61--
62-- /Pre-release/
63unread :: [b] -> Source a b -> Source a b
64unread xs (Source ys seed) = Source (xs ++ ys) seed
66-- | Determine if the source is empty.
67isEmpty :: Source a b -> Bool
68isEmpty (Source [] Nothing) = True
69isEmpty _ = False
71-- | Convert a producer to a producer from a buffered source. Any buffered data
72-- is read first and then the seed is unfolded.
73--
74-- /Pre-release/
75{-# INLINE_NORMAL producer #-}
76producer :: Monad m => Producer m a b -> Producer m (Source a b) b
77producer (Producer step1 inject1 extract1) = Producer step inject extract
79 where
81 inject (Source [] (Just a)) = do
82 s <- inject1 a
83 return $ Left s
84 inject (Source xs a) = return $ Right (xs, a)
86 {-# INLINE_LATE step #-}
87 step (Left s) = do
88 r <- step1 s
89 return $ case r of
90 Yield x s1 -> Yield x (Left s1)
91 Skip s1 -> Skip (Left s1)
92 Stop -> Stop
93 step (Right ([], Nothing)) = return Stop
94 step (Right ([], Just _)) = error "Bug: unreachable"
95 step (Right (x:[], Just a)) = do
96 s <- inject1 a
97 return $ Yield x (Left s)
98 step (Right (x:xs, a)) = return $ Yield x (Right (xs, a))
100 extract (Left s) = Source [] . Just <$> extract1 s
101 extract (Right (xs, a)) = return $ Source xs a
103-------------------------------------------------------------------------------
104-- Parsing
105-------------------------------------------------------------------------------
107-- GHC parser does not accept {-# ANN type [] NoSpecConstr #-}, so we need
108-- to make a newtype.
109{-# ANN type List NoSpecConstr #-}
110newtype List a = List {getList :: [a]}
112{-# INLINE_NORMAL parse #-}
113parse
114 :: Monad m =>
115 ParserD.Parser a m b
116 -> Producer m (Source s a) a
117 -> Source s a
118 -> m (Either ParseError b, Source s a)
119parse
120 (ParserD.Parser pstep initial extract)
121 (Producer ustep uinject uextract)
122 seed = do
124 res <- initial
125 case res of
126 ParserD.IPartial s -> do
127 state <- uinject seed
128 go SPEC state (List []) s
129 ParserD.IDone b -> return (Right b, seed)
130 ParserD.IError err -> return (Left (ParseError err), seed)
132 where
134 -- XXX currently we are using a dumb list based approach for backtracking
135 -- buffer. This can be replaced by a sliding/ring buffer using Data.Array.
136 -- That will allow us more efficient random back and forth movement.
137 go !_ st buf !pst = do
138 r <- ustep st
139 case r of
140 Yield x s -> do
141 pRes <- pstep pst x
142 case pRes of
143 Partial 0 pst1 -> go SPEC s (List []) pst1
144 Partial n pst1 -> do
145 assert (n <= length (x:getList buf)) (return ())
146 let src0 = Prelude.take n (x:getList buf)
147 src = Prelude.reverse src0
148 gobuf SPEC s (List []) (List src) pst1
149 Continue 0 pst1 -> go SPEC s (List (x:getList buf)) pst1
150 Continue n pst1 -> do
151 assert (n <= length (x:getList buf)) (return ())
152 let (src0, buf1) = splitAt n (x:getList buf)
153 src = Prelude.reverse src0
154 gobuf SPEC s (List buf1) (List src) pst1
155 Done n b -> do
156 assert (n <= length (x:getList buf)) (return ())
157 let src0 = Prelude.take n (x:getList buf)
158 src = Prelude.reverse src0
159 s1 <- uextract s
160 return (Right b, unread src s1)
161 Error err -> do
162 s1 <- uextract s
163 let src = Prelude.reverse (getList buf)
164 return
165 ( Left (ParseError err)
166 , unread (src ++ [x]) s1
167 )
168 Skip s -> go SPEC s buf pst
169 Stop -> goStop buf pst
171 gobuf !_ s buf (List []) !pst = go SPEC s buf pst
172 gobuf !_ s buf (List (x:xs)) !pst = do
173 pRes <- pstep pst x
174 case pRes of
175 Partial 0 pst1 ->
176 gobuf SPEC s (List []) (List xs) pst1
177 Partial n pst1 -> do
178 assert (n <= length (x:getList buf)) (return ())
179 let src0 = Prelude.take n (x:getList buf)
180 src = Prelude.reverse src0 ++ xs
181 gobuf SPEC s (List []) (List src) pst1
182 Continue 0 pst1 ->
183 gobuf SPEC s (List (x:getList buf)) (List xs) pst1
184 Continue n pst1 -> do
185 assert (n <= length (x:getList buf)) (return ())
186 let (src0, buf1) = splitAt n (x:getList buf)
187 src = Prelude.reverse src0 ++ xs
188 gobuf SPEC s (List buf1) (List src) pst1
189 Done n b -> do
190 assert (n <= length (x:getList buf)) (return ())
191 let src0 = Prelude.take n (x:getList buf)
192 src = Prelude.reverse src0
193 s1 <- uextract s
194 return (Right b, unread src s1)
195 Error err -> do
196 s1 <- uextract s
197 let src = Prelude.reverse (getList buf)
198 return
199 ( Left (ParseError err)
200 , unread (src ++ (x:xs)) s1
201 )
203 -- This is a simplified gobuf
204 goExtract !_ buf (List []) !pst = goStop buf pst
205 goExtract !_ buf (List (x:xs)) !pst = do
206 pRes <- pstep pst x
207 case pRes of
208 Partial 0 pst1 ->
209 goExtract SPEC (List []) (List xs) pst1
210 Partial n pst1 -> do
211 assert (n <= length (x:getList buf)) (return ())
212 let src0 = Prelude.take n (x:getList buf)
213 src = Prelude.reverse src0 ++ xs
214 goExtract SPEC (List []) (List src) pst1
215 Continue 0 pst1 ->
216 goExtract SPEC (List (x:getList buf)) (List xs) pst1
217 Continue n pst1 -> do
218 assert (n <= length (x:getList buf)) (return ())
219 let (src0, buf1) = splitAt n (x:getList buf)
220 src = Prelude.reverse src0 ++ xs
221 goExtract SPEC (List buf1) (List src) pst1
222 Done n b -> do
223 assert (n <= length (x:getList buf)) (return ())
224 let src0 = Prelude.take n (x:getList buf)
225 src = Prelude.reverse src0
226 return (Right b, unread src (source Nothing))
227 Error err -> do
228 let src = Prelude.reverse (getList buf)
229 return
230 ( Left (ParseError err)
231 , unread (src ++ (x:xs)) (source Nothing)
232 )
234 -- This is a simplified goExtract
235 {-# INLINE goStop #-}
236 goStop buf pst = do
237 pRes <- extract pst
238 case pRes of
239 Partial _ _ -> error "Bug: parseD: Partial in extract"
240 Continue 0 pst1 ->
241 goStop buf pst1
242 Continue n pst1 -> do
243 assert (n <= length (getList buf)) (return ())
244 let (src0, buf1) = splitAt n (getList buf)
245 src = Prelude.reverse src0
246 goExtract SPEC (List buf1) (List src) pst1
247 Done 0 b -> return (Right b, source Nothing)
248 Done n b -> do
249 assert (n <= length (getList buf)) (return ())
250 let src0 = Prelude.take n (getList buf)
251 src = Prelude.reverse src0
252 return (Right b, unread src (source Nothing))
253 Error err -> do
254 let src = Prelude.reverse (getList buf)
255 return (Left (ParseError err), unread src (source Nothing))
257{-
258-- | Parse a buffered source using a parser, returning the parsed value and the
259-- remaining source.
260--
261-- /Pre-release/
262{-# INLINE [3] parseK #-}
263parseK :: Monad m =>
264 ParserK.Parser a m b
265 -> Producer m (Source s a) a
266 -> Source s a
267 -> m (Either ParseError b, Source s a)
268parseK = parse . ParserK.toParser
269-}
271-------------------------------------------------------------------------------
272-- Nested parsing
273-------------------------------------------------------------------------------
275{-# INLINE parseManyD #-}
276parseManyD :: Monad m =>
277 ParserD.Parser a m b
278 -> Producer m (Source x a) a
279 -> Producer m (Source x a) (Either ParseError b)
280parseManyD parser reader = Producer step return return
282 where
284 {-# INLINE_LATE step #-}
285 step src = do
286 if isEmpty src
287 then return Stop
288 else do
289 (b, s1) <- parse parser reader src
290 case b of
291 Right b1 -> return $ Yield (Right b1) s1
292 Left _ -> return Stop
294-- | Apply a parser repeatedly on a buffered source producer to generate a
295-- producer of parsed values.
296--
297-- /Pre-release/
298{-# INLINE parseMany #-}
299parseMany :: Monad m =>
300 ParserD.Parser a m b
301 -> Producer m (Source x a) a
302 -> Producer m (Source x a) (Either ParseError b)
303parseMany = parseManyD