git.iko.soy/streamly
on e856425 help sign in
streamly/core/src/Streamly/Internal/Data/Producer/Source.hs
282 lines 9.9 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 Control.Monad.Catch (MonadThrow, throwM)
38import GHC.Exts (SpecConstrAnnotation(..))
39import GHC.Types (SPEC(..))
40import Streamly.Internal.Data.Parser.ParserD (ParseError(..), Step(..))
41import Streamly.Internal.Data.Producer.Type (Producer(..))
42import Streamly.Internal.Data.Stream.StreamD.Step (Step(..))
44import qualified Streamly.Internal.Data.Parser.ParserD as ParserD
45import qualified Streamly.Internal.Data.Parser.ParserK.Type as ParserK
47import Prelude hiding (read)
49-- | A seed with a buffer. It allows us to 'unread' or return some data
50-- after reading it. Useful in backtracked parsing.
51--
52data Source a b = Source [b] (Maybe a)
54-- | Make a source from a seed value. The buffer would start as empty.
55--
56-- /Pre-release/
57source :: Maybe a -> Source a b
58source = Source []
60-- | Return some unused data back to the source. The data is prepended (or
61-- consed) to the source.
62--
63-- /Pre-release/
64unread :: [b] -> Source a b -> Source a b
65unread xs (Source ys seed) = Source (xs ++ ys) seed
67-- | Determine if the source is empty.
68isEmpty :: Source a b -> Bool
69isEmpty (Source [] Nothing) = True
70isEmpty _ = False
72-- | Convert a producer to a producer from a buffered source. Any buffered data
73-- is read first and then the seed is unfolded.
74--
75-- /Pre-release/
76{-# INLINE_NORMAL producer #-}
77producer :: Monad m => Producer m a b -> Producer m (Source a b) b
78producer (Producer step1 inject1 extract1) = Producer step inject extract
80 where
82 inject (Source [] (Just a)) = do
83 s <- inject1 a
84 return $ Left s
85 inject (Source xs a) = return $ Right (xs, a)
87 {-# INLINE_LATE step #-}
88 step (Left s) = do
89 r <- step1 s
90 return $ case r of
91 Yield x s1 -> Yield x (Left s1)
92 Skip s1 -> Skip (Left s1)
93 Stop -> Stop
94 step (Right ([], Nothing)) = return Stop
95 step (Right ([], Just _)) = error "Bug: unreachable"
96 step (Right (x:[], Just a)) = do
97 s <- inject1 a
98 return $ Yield x (Left s)
99 step (Right (x:xs, a)) = return $ Yield x (Right (xs, a))
101 extract (Left s) = Source [] . Just <$> extract1 s
102 extract (Right (xs, a)) = return $ Source xs a
104-------------------------------------------------------------------------------
105-- Parsing
106-------------------------------------------------------------------------------
108-- GHC parser does not accept {-# ANN type [] NoSpecConstr #-}, so we need
109-- to make a newtype.
110{-# ANN type List NoSpecConstr #-}
111newtype List a = List {getList :: [a]}
113{-# INLINE_NORMAL parseD #-}
114parseD
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)
120parseD
121 (ParserD.Parser pstep initial extract)
122 (Producer ustep uinject uextract)
123 seed = do
125 res <- initial
126 case res of
127 ParserD.IPartial s -> do
128 state <- uinject seed
129 go SPEC state (List []) s
130 ParserD.IDone b -> return (b, seed)
131 ParserD.IError err -> throwM $ ParseError err
133 where
135 -- XXX currently we are using a dumb list based approach for backtracking
136 -- buffer. This can be replaced by a sliding/ring buffer using Data.Array.
137 -- That will allow us more efficient random back and forth movement.
138 go !_ st buf !pst = do
139 r <- ustep st
140 case r of
141 Yield x s -> do
142 pRes <- pstep pst x
143 case pRes of
144 Partial 0 pst1 -> go SPEC s (List []) pst1
145 Partial n pst1 -> do
146 assert (n <= length (x:getList buf)) (return ())
147 let src0 = Prelude.take n (x:getList buf)
148 src = Prelude.reverse src0
149 gobuf SPEC s (List []) (List src) pst1
150 Continue 0 pst1 -> go SPEC s (List (x:getList buf)) pst1
151 Continue n pst1 -> do
152 assert (n <= length (x:getList buf)) (return ())
153 let (src0, buf1) = splitAt n (x:getList buf)
154 src = Prelude.reverse src0
155 gobuf SPEC s (List buf1) (List src) pst1
156 Done n b -> do
157 assert (n <= length (x:getList buf)) (return ())
158 let src0 = Prelude.take n (x:getList buf)
159 src = Prelude.reverse src0
160 s1 <- uextract s
161 return (b, unread src s1)
162 Error err -> throwM $ ParseError err
163 Skip s -> go SPEC s buf pst
164 Stop -> goStop buf pst
166 gobuf !_ s buf (List []) !pst = go SPEC s buf pst
167 gobuf !_ s buf (List (x:xs)) !pst = do
168 pRes <- pstep pst x
169 case pRes of
170 Partial 0 pst1 ->
171 gobuf SPEC s (List []) (List xs) pst1
172 Partial n pst1 -> do
173 assert (n <= length (x:getList buf)) (return ())
174 let src0 = Prelude.take n (x:getList buf)
175 src = Prelude.reverse src0 ++ xs
176 gobuf SPEC s (List []) (List src) pst1
177 Continue 0 pst1 ->
178 gobuf SPEC s (List (x:getList buf)) (List xs) pst1
179 Continue n pst1 -> do
180 assert (n <= length (x:getList buf)) (return ())
181 let (src0, buf1) = splitAt n (x:getList buf)
182 src = Prelude.reverse src0 ++ xs
183 gobuf SPEC s (List buf1) (List src) pst1
184 Done n b -> do
185 assert (n <= length (x:getList buf)) (return ())
186 let src0 = Prelude.take n (x:getList buf)
187 src = Prelude.reverse src0
188 s1 <- uextract s
189 return (b, unread src s1)
190 Error err -> throwM $ ParseError err
192 -- This is a simplified gobuf
193 goExtract !_ buf (List []) !pst = goStop buf pst
194 goExtract !_ buf (List (x:xs)) !pst = do
195 pRes <- pstep pst x
196 case pRes of
197 Partial 0 pst1 ->
198 goExtract SPEC (List []) (List xs) pst1
199 Partial n pst1 -> do
200 assert (n <= length (x:getList buf)) (return ())
201 let src0 = Prelude.take n (x:getList buf)
202 src = Prelude.reverse src0 ++ xs
203 goExtract SPEC (List []) (List src) pst1
204 Continue 0 pst1 ->
205 goExtract SPEC (List (x:getList buf)) (List xs) pst1
206 Continue n pst1 -> do
207 assert (n <= length (x:getList buf)) (return ())
208 let (src0, buf1) = splitAt n (x:getList buf)
209 src = Prelude.reverse src0 ++ xs
210 goExtract SPEC (List buf1) (List src) pst1
211 Done n b -> do
212 assert (n <= length (x:getList buf)) (return ())
213 let src0 = Prelude.take n (x:getList buf)
214 src = Prelude.reverse src0
215 return (b, unread src (source Nothing))
216 Error err -> throwM $ ParseError err
218 -- This is a simplified goExtract
219 {-# INLINE goStop #-}
220 goStop buf pst = do
221 pRes <- extract pst
222 case pRes of
223 Partial _ _ -> error "Bug: parseD: Partial in extract"
224 Continue 0 _ ->
225 error "parseD: extract, Continue 0 creates infinite loop"
226 Continue n pst1 -> do
227 assert (n <= length (getList buf)) (return ())
228 let (src0, buf1) = splitAt n (getList buf)
229 src = Prelude.reverse src0
230 goExtract SPEC (List buf1) (List src) pst1
231 Done 0 b -> return (b, source Nothing)
232 Done n b -> do
233 assert (n <= length (getList buf)) (return ())
234 let src0 = Prelude.take n (getList buf)
235 src = Prelude.reverse src0
236 return (b, unread src (source Nothing))
237 Error err -> throwM $ ParseError err
239-- | Parse a buffered source using a parser, returning the parsed value and the
240-- remaining source.
241--
242-- /Pre-release/
243{-# INLINE [3] parse #-}
244parse
245 :: MonadThrow m
246 => ParserK.Parser m a b
247 -> Producer m (Source s a) a
248 -> Source s a
249 -> m (b, Source s a)
250parse = parseD . ParserD.fromParserK
252-------------------------------------------------------------------------------
253-- Nested parsing
254-------------------------------------------------------------------------------
256{-# INLINE parseManyD #-}
257parseManyD :: MonadThrow m =>
258 ParserD.Parser m a b
259 -> Producer m (Source x a) a
260 -> Producer m (Source x a) b
261parseManyD parser reader = Producer step return return
263 where
265 {-# INLINE_LATE step #-}
266 step src = do
267 if isEmpty src
268 then return Stop
269 else do
270 (b, s1) <- parseD parser reader src
271 return $ Yield b s1
273-- | Apply a parser repeatedly on a buffered source producer to generate a
274-- producer of parsed values.
275--
276-- /Pre-release/
277{-# INLINE parseMany #-}
278parseMany :: MonadThrow m =>
279 ParserK.Parser m a b
280 -> Producer m (Source x a) a
281 -> Producer m (Source x a) b
282parseMany parser = parseManyD (ParserD.fromParserK parser)