git.iko.soy/streamly
on 43dda21 help sign in
streamly/core/src/Streamly/Internal/Data/Producer/Source.hs
237 lines 7.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 -> do
165 b <- extract pst
166 return (b, unread (reverse $ getList buf) (source Nothing))
168 gobuf !_ s buf (List []) !pst = go SPEC s buf pst
169 gobuf !_ s buf (List (x:xs)) !pst = do
170 pRes <- pstep pst x
171 case pRes of
172 Partial 0 pst1 ->
173 gobuf SPEC s (List []) (List xs) pst1
174 Partial n pst1 -> do
175 assert (n <= length (x:getList buf)) (return ())
176 let src0 = Prelude.take n (x:getList buf)
177 src = Prelude.reverse src0 ++ xs
178 gobuf SPEC s (List []) (List src) pst1
179 Continue 0 pst1 ->
180 gobuf SPEC s (List (x:getList buf)) (List xs) pst1
181 Continue n pst1 -> do
182 assert (n <= length (x:getList buf)) (return ())
183 let (src0, buf1) = splitAt n (x:getList buf)
184 src = Prelude.reverse src0 ++ xs
185 gobuf SPEC s (List buf1) (List src) pst1
186 Done n b -> do
187 assert (n <= length (x:getList buf)) (return ())
188 let src0 = Prelude.take n (x:getList buf)
189 src = Prelude.reverse src0
190 s1 <- uextract s
191 return (b, unread src s1)
192 Error err -> throwM $ ParseError err
194-- | Parse a buffered source using a parser, returning the parsed value and the
195-- remaining source.
196--
197-- /Pre-release/
198{-# INLINE [3] parse #-}
199parse
200 :: MonadThrow m
201 => ParserK.Parser m a b
202 -> Producer m (Source s a) a
203 -> Source s a
204 -> m (b, Source s a)
205parse = parseD . ParserD.fromParserK
207-------------------------------------------------------------------------------
208-- Nested parsing
209-------------------------------------------------------------------------------
211{-# INLINE parseManyD #-}
212parseManyD :: MonadThrow m =>
213 ParserD.Parser m a b
214 -> Producer m (Source x a) a
215 -> Producer m (Source x a) b
216parseManyD parser reader = Producer step return return
218 where
220 {-# INLINE_LATE step #-}
221 step src = do
222 if isEmpty src
223 then return Stop
224 else do
225 (b, s1) <- parseD parser reader src
226 return $ Yield b s1
228-- | Apply a parser repeatedly on a buffered source producer to generate a
229-- producer of parsed values.
230--
231-- /Pre-release/
232{-# INLINE parseMany #-}
233parseMany :: MonadThrow m =>
234 ParserK.Parser m a b
235 -> Producer m (Source x a) a
236 -> Producer m (Source x a) b
237parseMany parser = parseManyD (ParserD.fromParserK parser)