@@ -19,22 +19,36 @@
19module Streamly.Internal.Data.Parser.ParserK.Type
19module Streamly.Internal.Data.Parser.ParserK.Type
22− , Parse (..)
22+ , Input (..)
23− , Parser (..) -- XXX Stop exporting this
23+ , ParseResult (..)
25 , fromPure
28 , fromPure
26 , fromEffect
29 , fromEffect
34+#include "ArrayMacros.h"
31#include "inline.hs"
36#include "inline.hs"
33import Control.Applicative (Alternative(..), liftA2)
38import Control.Applicative (Alternative(..), liftA2)
34import Control.Monad (MonadPlus(..), ap)
39import Control.Monad (MonadPlus(..), ap)
35import Control.Monad.IO.Class (MonadIO, liftIO)
40import Control.Monad.IO.Class (MonadIO, liftIO)
36-- import Control.Monad.Trans.Class (MonadTrans(lift))
41-- import Control.Monad.Trans.Class (MonadTrans(lift))
42+import Data.Proxy (Proxy(..))
43+import GHC.Types (SPEC(..))
44+import Streamly.Internal.Data.Array.Type (Array(..))
45+import Streamly.Internal.Data.Unboxed (peekWith, sizeOf, Unbox)
37import qualified Control.Monad.Fail as Fail
47import qualified Control.Monad.Fail as Fail
48+import qualified Streamly.Internal.Data.Array.Type as Array
49+import qualified Streamly.Internal.Data.Parser.ParserD.Type as ParserD
51+data Input a = None | Single a | Chunk (Array a)
39-- | The intermediate result of running a parser step. The parser driver may
53-- | The intermediate result of running a parser step. The parser driver may
40-- stop with a final result, pause with a continuation to resume, or fail with
54-- stop with a final result, pause with a continuation to resume, or fail with
@@ -46,32 +60,45 @@ import qualified Control.Monad.Fail as Fail
47-- /Pre-release/
61-- /Pre-release/
49−data Step m a r =
63+data Step a m r =
64+ -- The Int is the current stream position index wrt to the start of the
50 Done !Int r
66 Done !Int r
51 -- XXX we can use a "resume" and a "stop" continuations instead of Maybe.
67 -- XXX we can use a "resume" and a "stop" continuations instead of Maybe.
52 -- measure if that works any better.
68 -- measure if that works any better.
69+ -- Array a -> m (Step a m r), m (Step a m r)
53− | Partial !Int (Maybe a -> m (Step m a r))
70+ | Partial !Int (Input a -> m (Step a m r))
54− | Continue !Int (Maybe a -> m (Step m a r))
71+ | Continue !Int (Input a -> m (Step a m r))
55− | Error String
72+ | Error !Int String
57−instance Functor m => Functor (Step m a) where
74+instance Functor m => Functor (Step a m) where
58 fmap f (Done n r) = Done n (f r)
75 fmap f (Done n r) = Done n (f r)
59 fmap f (Partial n k) = Partial n (fmap (fmap f) . k)
76 fmap f (Partial n k) = Partial n (fmap (fmap f) . k)
60 fmap f (Continue n k) = Continue n (fmap (fmap f) . k)
77 fmap f (Continue n k) = Continue n (fmap (fmap f) . k)
61− fmap _ (Error e) = Error e
78+ fmap _ (Error n e) = Error n e
63-- | The parser's result.
80-- | The parser's result.
82+-- Int is the position index into the current input array. Could be negative.
83+-- Cannot be beyond the input array max bound.
65-- /Pre-release/
85-- /Pre-release/
67−data Parse b =
87+data ParseResult b =
68− Success !Int !b -- Leftover count, result
88+ Success !Int !b -- Position index, result
69− | Failure !String -- Error
89+ | Failure !Int !String -- Position index, error
71-- | Map a function over 'Success'.
91-- | Map a function over 'Success'.
72−instance Functor Parse where
92+instance Functor ParseResult where
73 fmap f (Success n b) = Success n (f b)
93 fmap f (Success n b) = Success n (f b)
74− fmap _ (Failure e) = Failure e
94+ fmap _ (Failure n e) = Failure n e
96+-- XXX Change the type to the shape (a -> m r -> m r) -> (m r -> m r) -> m r
98+-- The parse continuation would be: Array a -> m (Step a m r) -> m (Step a m r)
99+-- The extract continuation would be: m (Step a m r) -> m (Step a m r)
101+-- Use Step itself in place of ParseResult.
76-- | A continuation passing style parser representation. A continuation of
103-- | A continuation passing style parser representation. A continuation of
77-- 'Step's, each step passes a state and a parse result to the next 'Step'. The
104-- 'Step's, each step passes a state and a parse result to the next 'Step'. The
@@ -82,24 +109,27 @@ instance Functor Parse where
83newtype Parser a m b = MkParser
110newtype Parser a m b = MkParser
84 { runParser :: forall r.
111 { runParser :: forall r.
85− -- leftover: the number of elements that were not used by the
112+ -- XXX Maintain and pass the original position in the stream. that
86− -- previous consumer and should be carried forward.
113+ -- way we can also report better errors. Use a Context structure for
114+ -- passing the state.
116+ -- Stream position index wrt to the current input array start. If
117+ -- negative then backtracking is required before using the array.
118+ -- The parser should use "Continue -n" in this case if it needs to
119+ -- consume input. Negative value cannot be beyond the current
120+ -- backtrack buffer. Positive value cannot be beyond array length.
121+ -- If the parser needs to advance beyond the array length it should
122+ -- use "Continue +n".
88− -- (alt nesting level, alt used elem count). Nesting level is
89− -- increased whenever we enter an Alternative composition and
90− -- decreased when it is done. The used element count is a count of
91− -- elements consumed by the Alternative. If the Alternative fails we
124+ -- used elem count, a count of elements consumed by the parser. If
92− -- need to backtrack by this amount.
125+ -- an Alternative fails we need to backtrack by this amount.
94− -- The nesting level is used in parseDToK to optimize the case when
95− -- we are not in an alternative, in that case we do not need to
96− -- maintain the element count for backtracking.
97− -> (Int, Int)
126+ -> Int
98− -- The first argument is the (nest level, used count) tuple as
127+ -- The second argument is the used count as described above. The
99− -- described above. The leftover element count is carried as part of
128+ -- current input position is carried as part of 'Success'
100− -- 'Success' constructor of 'Parse'.
129+ -- constructor of 'ParseResult'.
101− -> ((Int, Int) -> Parse b -> m (Step m a r))
130+ -> Input a
131+ -> (ParseResult b -> Int -> Input a -> m (Step a m r))
102− -> m (Step m a r)
132+ -> m (Step a m r)
105type ParserK = Parser
135type ParserK = Parser
@@ -113,9 +143,9 @@ type ParserK = Parser
114instance Functor m => Functor (Parser a m) where
144instance Functor m => Functor (Parser a m) where
115 {-# INLINE fmap #-}
145 {-# INLINE fmap #-}
116− fmap f parser = MkParser $ \n st k ->
146+ fmap f parser = MkParser $ \n st arr pk ->
117− let k1 s res = k s (fmap f res)
147+ let pk1 res = pk (fmap f res)
118− in runParser parser n st k1
148+ in runParser parser n st arr pk1
120-------------------------------------------------------------------------------
150-------------------------------------------------------------------------------
121-- Sequential applicative
151-- Sequential applicative
@@ -129,7 +159,7 @@ instance Functor m => Functor (Parser a m) where
130{-# INLINE fromPure #-}
160{-# INLINE fromPure #-}
131fromPure :: b -> Parser a m b
161fromPure :: b -> Parser a m b
132−fromPure b = MkParser $ \n st k -> k st (Success n b)
162+fromPure b = MkParser $ \n st arr pk -> pk (Success n b) st arr
134-- | See 'Streamly.Internal.Data.Parser.fromEffect'.
164-- | See 'Streamly.Internal.Data.Parser.fromEffect'.
@@ -137,7 +167,8 @@ fromPure b = MkParser $ \n st k -> k st (Success n b)
138{-# INLINE fromEffect #-}
168{-# INLINE fromEffect #-}
139fromEffect :: Monad m => m b -> Parser a m b
169fromEffect :: Monad m => m b -> Parser a m b
140−fromEffect eff = MkParser $ \n st k -> eff >>= \b -> k st (Success n b)
171+ MkParser $ \n st arr pk -> eff >>= \b -> pk (Success n b) st arr
142-- | 'Applicative' form of 'Streamly.Internal.Data.Parser.splitWith'. Note that
173-- | 'Applicative' form of 'Streamly.Internal.Data.Parser.splitWith'. Note that
143-- this operation does not fuse, use 'Streamly.Internal.Data.Parser.splitWith'
174-- this operation does not fuse, use 'Streamly.Internal.Data.Parser.splitWith'
@@ -151,19 +182,19 @@ instance Monad m => Applicative (Parser a m) where
151 (<*>) = ap
182 (<*>) = ap
153 {-# INLINE (*>) #-}
184 {-# INLINE (*>) #-}
154− p1 *> p2 = MkParser $ \n st k ->
185+ p1 *> p2 = MkParser $ \n st arr k ->
155− let k1 s (Success n1 _) = runParser p2 n1 s k
186+ let k1 (Success n1 _) s input = runParser p2 n1 s input k
156− k1 s (Failure e) = k s (Failure e)
187+ k1 (Failure n1 e) s input = k (Failure n1 e) s input
157− in runParser p1 n st k1
188+ in runParser p1 n st arr k1
159 {-# INLINE (<*) #-}
190 {-# INLINE (<*) #-}
160− p1 <* p2 = MkParser $ \n st k ->
191+ p1 <* p2 = MkParser $ \n st arr k ->
161− let k1 s1 (Success n1 b) =
192+ let k1 (Success n1 b) s1 input =
162− let k2 s2 (Success n2 _) = k s2 (Success n2 b)
193+ let k2 (Success n2 _) = k (Success n2 b)
163− k2 s2 (Failure e) = k s2 (Failure e)
194+ k2 (Failure n2 e) = k (Failure n2 e)
164− in runParser p2 n1 s1 k2
195+ in runParser p2 n1 s1 input k2
165− k1 s1 (Failure e) = k s1 (Failure e)
196+ k1 (Failure n1 e) s1 input = k (Failure n1 e) s1 input
166− in runParser p1 n st k1
197+ in runParser p1 n st arr k1
168 {-# INLINE liftA2 #-}
199 {-# INLINE liftA2 #-}
169 liftA2 f p = (<*>) (fmap f p)
200 liftA2 f p = (<*>) (fmap f p)
@@ -181,7 +212,7 @@ instance Monad m => Applicative (Parser a m) where
182{-# INLINE die #-}
213{-# INLINE die #-}
183die :: String -> Parser a m b
214die :: String -> Parser a m b
184−die err = MkParser (\_ st k -> k st (Failure err))
215+die err = MkParser (\n st arr pk -> pk (Failure n err) st arr)
186-- | Monad composition can be used for lookbehind parsers, we can make the
217-- | Monad composition can be used for lookbehind parsers, we can make the
187-- future parses depend on the previously parsed values.
218-- future parses depend on the previously parsed values.
@@ -230,10 +261,10 @@ instance Monad m => Monad (Parser a m) where
230 return = pure
261 return = pure
232 {-# INLINE (>>=) #-}
263 {-# INLINE (>>=) #-}
233− p >>= f = MkParser $ \n st k ->
264+ p >>= f = MkParser $ \n st arr pk ->
234− let k1 s1 (Success n1 b) = runParser (f b) n1 s1 k
265+ let pk1 (Success n1 b) s1 inp = runParser (f b) n1 s1 inp pk
235− k1 s1 (Failure e) = k s1 (Failure e)
266+ pk1 (Failure n1 e) s1 inp = pk (Failure n1 e) s1 inp
236− in runParser p n st k1
267+ in runParser p n st arr pk1
238 {-# INLINE (>>) #-}
269 {-# INLINE (>>) #-}
239 (>>) = (*>)
270 (>>) = (*>)
@@ -274,11 +305,11 @@ instance Monad m => Alternative (Parser a m) where
274 empty = die "empty"
305 empty = die "empty"
276 {-# INLINE (<|>) #-}
307 {-# INLINE (<|>) #-}
277− p1 <|> p2 = MkParser $ \n (level, _) k ->
308+ p1 <|> p2 = MkParser $ \n _ arr k ->
278− let k1 (0, _) _ = error "Bug: 0 nest level in Alternative"
309+ let
279− k1 (l1, n1) (Failure _) = runParser p2 n1 (l1 - 1, 0) k
310+ k1 (Failure pos _) used input = runParser p2 (pos - used) 0 input k
280− k1 (l1, _) success = k (l1 - 1, 0) success
311+ k1 success _ input = k success 0 input
281− in runParser p1 n (level + 1, 0) k1
312+ in runParser p1 n 0 arr k1
283 -- some and many are implemented here instead of using default definitions
314 -- some and many are implemented here instead of using default definitions
284 -- so that we can use INLINE on them. It gives 50% performance improvement.
315 -- so that we can use INLINE on them. It gives 50% performance improvement.
@@ -314,3 +345,207 @@ instance MonadTrans (Parser a) where
314 {-# INLINE lift #-}
345 {-# INLINE lift #-}
315 lift = fromEffect
346 lift = fromEffect
349+-------------------------------------------------------------------------------
350+-- Convert ParserD to ParserK
351+-------------------------------------------------------------------------------
353+data ChunkResult s b =
355+ | ChunkPartial !Int !s
356+ | ChunkContinue !Int !s
357+ | ChunkError !Int String
359+-- This is very similar to fromParserD in the Array/Unboxed/Fold module.
360+{-# INLINE parseChunk #-}
362+ :: forall m a s b. (MonadIO m, Unbox a)
363+ => (s -> a -> m (ParserD.Step s b))
367+ -> m (ChunkResult s b)
368+parseChunk pstep state (Array contents start end) offset = do
370+ then go SPEC (start + offset * SIZE_OF(a)) state
371+ else return $ ChunkContinue offset state
375+ {-# INLINE onBack #-}
376+ onBack offset1 elemSize constr pst = do
377+ let pos = offset1 - start
379+ then go SPEC offset1 pst
380+ else return $ constr (pos `div` elemSize) pst
382+ -- Note: div may be expensive but the alternative is to maintain an element
383+ -- offset in addition to a byte offset or just the element offset and use
384+ -- multiplication to get the byte offset every time, both these options
385+ -- turned out to be more expensive than using div.
386+ go !_ !cur !pst | cur >= end =
387+ return $ ChunkContinue ((end - start) `div` SIZE_OF(a)) pst
388+ go !_ !cur !pst = do
389+ x <- liftIO $ peekWith contents cur
391+ let elemSize = SIZE_OF(a)
392+ next = INDEX_NEXT(cur,a)
393+ back n = next - n * elemSize
394+ curOff = (cur - start) `div` elemSize
395+ nextOff = (next - start) `div` elemSize
398+ return $ ChunkDone nextOff b
400+ return $ ChunkDone curOff b
402+ return $ ChunkDone ((back n - start) `div` elemSize) b
403+ ParserD.Partial 0 pst1 ->
405+ ParserD.Partial 1 pst1 ->
407+ ParserD.Partial n pst1 ->
408+ onBack (back n) elemSize ChunkPartial pst1
409+ ParserD.Continue 0 pst1 ->
411+ ParserD.Continue 1 pst1 ->
413+ ParserD.Continue n pst1 ->
414+ onBack (back n) elemSize ChunkContinue pst1
415+ ParserD.Error err ->
416+ return $ ChunkError curOff err
418+{-# INLINE parseDToK #-}
420+ :: forall m a s b r. (MonadIO m, Unbox a)
421+ => (s -> a -> m (ParserD.Step s b))
422+ -> m (ParserD.Initial s b)
423+ -> (s -> m (ParserD.Step s b))
427+ -> (ParseResult b -> Int -> Input a -> m (Step a m r))
429+parseDToK pstep initial extract offset usedCount input cont = do
432+ ParserD.IPartial pst -> do
434+ Chunk arr -> parseContChunk usedCount offset pst arr
435+ Single x -> parseContSingle usedCount offset pst x
436+ None -> parseContNothing usedCount pst
437+ ParserD.IDone b -> cont (Success offset b) usedCount input
438+ ParserD.IError err -> cont (Failure offset err) usedCount input
442+ -- XXX We can maintain an absolute position instead of relative that will
443+ -- help in reporting of error location in the stream.
444+ {-# NOINLINE parseContChunk #-}
445+ parseContChunk count off pst arr = do
446+ pRes <- parseChunk pstep pst arr off
447+ -- The "n" here is stream position index wrt the array start, and not
448+ -- the backtrack count as returned by byte stream parsers.
451+ assert (n <= Array.length arr)
452+ (cont (Success n b) (count + n - off) (Chunk arr))
453+ ChunkPartial n pst1 ->
454+ assert (n < 0 || n >= Array.length arr)
455+ (return $ Partial n (parseCont (count + n - off) pst1))
456+ ChunkContinue n pst1 ->
457+ assert (n < 0 || n >= Array.length arr)
458+ (return $ Continue n (parseCont (count + n - off) pst1))
460+ cont (Failure n err) (count + n - off) (Chunk arr)
462+ -- XXX This is not yet finished
463+ {-# NOINLINE parseContSingle #-}
464+ parseContSingle _count off pst x = do
467+ ParserD.Done _n b -> do
468+ cont (Success (off + 1) b) undefined undefined
471+ {-# NOINLINE parseContNothing #-}
472+ parseContNothing count pst = do
475+ -- IMPORTANT: the n here is from the byte stream parser, that means
476+ -- it is the backtrack element count and not the stream position
477+ -- index into the current input array.
480+ (cont (Success (- n) b) (count - n) None)
481+ ParserD.Continue n pst1 ->
483+ (return $ Continue (- n) (parseCont (count - n) pst1))
484+ ParserD.Error err ->
485+ -- XXX It is called only when there is no input arr. So using 0
486+ -- as the position is correct?
487+ cont (Failure 0 err) count None
488+ ParserD.Partial _ _ -> error "Bug: parseDToK Partial unreachable"
490+ -- XXX Maybe we can use two separate continuations instead of using
491+ -- Just/Nothing cases here. That may help in avoiding the parseContJust
493+ {-# INLINE parseCont #-}
494+ parseCont cnt pst (Chunk arr) = parseContChunk cnt 0 pst arr
495+ parseCont cnt pst (Single x) = parseContSingle cnt 0 pst x
496+ parseCont cnt pst None = parseContNothing cnt pst
498+-- | Convert a raw byte 'Parser' to a chunked parser.
502+{-# INLINE_LATE fromParser #-}
503+fromParser :: (MonadIO m, Unbox a) => ParserD.Parser a m b -> ParserK a m b
504+fromParser (ParserD.Parser step initial extract) =
505+ MkParser $ parseDToK step initial extract
507+-------------------------------------------------------------------------------
508+-- Convert CPS style 'Parser' to direct style 'D.Parser'
509+-------------------------------------------------------------------------------
511+-- | A continuation to extract the result when a CPS parser is done.
512+{-# INLINE parserDone #-}
513+parserDone :: Monad m => ParseResult b -> Int -> Input a -> m (Step a m b)
514+parserDone (Success n b) _ None = return $ Done n b
515+parserDone (Failure n e) _ None = return $ Error n e
516+parserDone _ _ _ = error "Bug: toParser: called with input"
518+-- | Convert a CPS style 'ParserK' to a direct style 'ParserD.Parser'.
522+{-# INLINE_LATE toParser #-}
523+toParser :: Monad m => Parser a m b -> ParserD.Parser a m b
524+toParser parser = ParserD.Parser step initial extract
528+ initial = pure (ParserD.IPartial (\x -> runParser parser 0 0 x parserDone))
531+ r <- cont (Single a)
533+ Done n b -> ParserD.Done n b
534+ Error _ e -> ParserD.Error e
535+ Partial n cont1 -> ParserD.Partial n cont1
536+ Continue n cont1 -> ParserD.Continue n cont1
541+ Done n b -> return $ ParserD.Done n b
542+ Error _ e -> return $ ParserD.Error e
543+ Partial _ cont1 -> extract cont1
544+ Continue n cont1 -> return $ ParserD.Continue n cont1
546+#ifndef DISABLE_FUSION
547+{-# RULES "fromParser/toParser fusion" [2]
548+ forall s. toParser (fromParser s) = s #-}
549+{-# RULES "toParser/fromParser fusion" [2]
550+ forall s. fromParser (toParser s) = s #-}