@@ -19,22 +19,36 @@
1919module Streamly.Internal.Data.Parser.ParserK.Type
2020 (
2121 Step (..)
22− , Parse (..)
23− , Parser (..) -- XXX Stop exporting this
22+ , Input (..)
23+ , ParseResult (..)
24+ , Parser (..)
2425 , ParserK
26+ , fromParser
27+ , toParser
2528 , fromPure
2629 , fromEffect
2730 , die
2831 )
2932where
3033
34+#include "ArrayMacros.h"
35+#include "assert.hs"
3136#include "inline.hs"
3237
3338import Control.Applicative (Alternative(..), liftA2)
3439import Control.Monad (MonadPlus(..), ap)
3540import Control.Monad.IO.Class (MonadIO, liftIO)
3641-- 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)
46+
3747import 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
50+
51+data Input a = None | Single a | Chunk (Array a)
3852
3953-- | The intermediate result of running a parser step. The parser driver may
4054-- 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
4660--
4761-- /Pre-release/
4862--
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
65+ -- array.
5066 Done !Int r
5167 -- XXX we can use a "resume" and a "stop" continuations instead of Maybe.
5268 -- measure if that works any better.
53− | Partial !Int (Maybe a -> m (Step m a r))
54− | Continue !Int (Maybe a -> m (Step m a r))
55− | Error String
69+ -- Array a -> m (Step a m r), m (Step a m r)
70+ | Partial !Int (Input a -> m (Step a m r))
71+ | Continue !Int (Input a -> m (Step a m r))
72+ | Error !Int String
5673
57−instance Functor m => Functor (Step m a) where
74+instance Functor m => Functor (Step a m) where
5875 fmap f (Done n r) = Done n (f r)
5976 fmap f (Partial n k) = Partial n (fmap (fmap f) . k)
6077 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
6279
6380-- | The parser's result.
6481--
82+-- Int is the position index into the current input array. Could be negative.
83+-- Cannot be beyond the input array max bound.
84+--
6585-- /Pre-release/
6686--
67−data Parse b =
68− Success !Int !b -- Leftover count, result
69− | Failure !String -- Error
87+data ParseResult b =
88+ Success !Int !b -- Position index, result
89+ | Failure !Int !String -- Position index, error
7090
7191-- | Map a function over 'Success'.
72−instance Functor Parse where
92+instance Functor ParseResult where
7393 fmap f (Success n b) = Success n (f b)
74− fmap _ (Failure e) = Failure e
94+ fmap _ (Failure n e) = Failure n e
95+
96+-- XXX Change the type to the shape (a -> m r -> m r) -> (m r -> m r) -> m r
97+--
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)
100+--
101+-- Use Step itself in place of ParseResult.
75102
76103-- | A continuation passing style parser representation. A continuation of
77104-- 'Step's, each step passes a state and a parse result to the next 'Step'. The
@@ -82,24 +109,27 @@ instance Functor Parse where
82109--
83110newtype Parser a m b = MkParser
84111 { runParser :: forall r.
85− -- leftover: the number of elements that were not used by the
86− -- previous consumer and should be carried forward.
112+ -- XXX Maintain and pass the original position in the stream. that
113+ -- way we can also report better errors. Use a Context structure for
114+ -- passing the state.
115+
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".
87123 Int
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
92− -- need to backtrack by this amount.
93− --
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)
98− -- The first argument is the (nest level, used count) tuple as
99− -- described above. The leftover element count is carried as part of
100− -- 'Success' constructor of 'Parse'.
101− -> ((Int, Int) -> Parse b -> m (Step m a r))
102− -> m (Step m a r)
124+ -- used elem count, a count of elements consumed by the parser. If
125+ -- an Alternative fails we need to backtrack by this amount.
126+ -> Int
127+ -- The second argument is the used count as described above. The
128+ -- current input position is carried as part of 'Success'
129+ -- constructor of 'ParseResult'.
130+ -> Input a
131+ -> (ParseResult b -> Int -> Input a -> m (Step a m r))
132+ -> m (Step a m r)
103133 }
104134
105135type ParserK = Parser
@@ -113,9 +143,9 @@ type ParserK = Parser
113143--
114144instance Functor m => Functor (Parser a m) where
115145 {-# INLINE fmap #-}
116− fmap f parser = MkParser $ \n st k ->
117− let k1 s res = k s (fmap f res)
118− in runParser parser n st k1
146+ fmap f parser = MkParser $ \n st arr pk ->
147+ let pk1 res = pk (fmap f res)
148+ in runParser parser n st arr pk1
119149
120150-------------------------------------------------------------------------------
121151-- Sequential applicative
@@ -129,7 +159,7 @@ instance Functor m => Functor (Parser a m) where
129159--
130160{-# INLINE fromPure #-}
131161fromPure :: 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
133163
134164-- | See 'Streamly.Internal.Data.Parser.fromEffect'.
135165--
@@ -137,7 +167,8 @@ fromPure b = MkParser $ \n st k -> k st (Success n b)
137167--
138168{-# INLINE fromEffect #-}
139169fromEffect :: Monad m => m b -> Parser a m b
140−fromEffect eff = MkParser $ \n st k -> eff >>= \b -> k st (Success n b)
170+fromEffect eff =
171+ MkParser $ \n st arr pk -> eff >>= \b -> pk (Success n b) st arr
141172
142173-- | 'Applicative' form of 'Streamly.Internal.Data.Parser.splitWith'. Note that
143174-- this operation does not fuse, use 'Streamly.Internal.Data.Parser.splitWith'
@@ -151,19 +182,19 @@ instance Monad m => Applicative (Parser a m) where
151182 (<*>) = ap
152183
153184 {-# INLINE (*>) #-}
154− p1 *> p2 = MkParser $ \n st k ->
155− let k1 s (Success n1 _) = runParser p2 n1 s k
156− k1 s (Failure e) = k s (Failure e)
157− in runParser p1 n st k1
185+ p1 *> p2 = MkParser $ \n st arr k ->
186+ let k1 (Success n1 _) s input = runParser p2 n1 s input k
187+ k1 (Failure n1 e) s input = k (Failure n1 e) s input
188+ in runParser p1 n st arr k1
158189
159190 {-# INLINE (<*) #-}
160− p1 <* p2 = MkParser $ \n st k ->
161− let k1 s1 (Success n1 b) =
162− let k2 s2 (Success n2 _) = k s2 (Success n2 b)
163− k2 s2 (Failure e) = k s2 (Failure e)
164− in runParser p2 n1 s1 k2
165− k1 s1 (Failure e) = k s1 (Failure e)
166− in runParser p1 n st k1
191+ p1 <* p2 = MkParser $ \n st arr k ->
192+ let k1 (Success n1 b) s1 input =
193+ let k2 (Success n2 _) = k (Success n2 b)
194+ k2 (Failure n2 e) = k (Failure n2 e)
195+ in runParser p2 n1 s1 input k2
196+ k1 (Failure n1 e) s1 input = k (Failure n1 e) s1 input
197+ in runParser p1 n st arr k1
167198
168199 {-# INLINE liftA2 #-}
169200 liftA2 f p = (<*>) (fmap f p)
@@ -181,7 +212,7 @@ instance Monad m => Applicative (Parser a m) where
181212--
182213{-# INLINE die #-}
183214die :: 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)
185216
186217-- | Monad composition can be used for lookbehind parsers, we can make the
187218-- future parses depend on the previously parsed values.
@@ -230,10 +261,10 @@ instance Monad m => Monad (Parser a m) where
230261 return = pure
231262
232263 {-# INLINE (>>=) #-}
233− p >>= f = MkParser $ \n st k ->
234− let k1 s1 (Success n1 b) = runParser (f b) n1 s1 k
235− k1 s1 (Failure e) = k s1 (Failure e)
236− in runParser p n st k1
264+ p >>= f = MkParser $ \n st arr pk ->
265+ let pk1 (Success n1 b) s1 inp = runParser (f b) n1 s1 inp pk
266+ pk1 (Failure n1 e) s1 inp = pk (Failure n1 e) s1 inp
267+ in runParser p n st arr pk1
237268
238269 {-# INLINE (>>) #-}
239270 (>>) = (*>)
@@ -274,11 +305,11 @@ instance Monad m => Alternative (Parser a m) where
274305 empty = die "empty"
275306
276307 {-# INLINE (<|>) #-}
277− p1 <|> p2 = MkParser $ \n (level, _) k ->
278− let k1 (0, _) _ = error "Bug: 0 nest level in Alternative"
279− k1 (l1, n1) (Failure _) = runParser p2 n1 (l1 - 1, 0) k
280− k1 (l1, _) success = k (l1 - 1, 0) success
281− in runParser p1 n (level + 1, 0) k1
308+ p1 <|> p2 = MkParser $ \n _ arr k ->
309+ let
310+ k1 (Failure pos _) used input = runParser p2 (pos - used) 0 input k
311+ k1 success _ input = k success 0 input
312+ in runParser p1 n 0 arr k1
282313
283314 -- some and many are implemented here instead of using default definitions
284315 -- so that we can use INLINE on them. It gives 50% performance improvement.
@@ -314,3 +345,207 @@ instance MonadTrans (Parser a) where
314345 {-# INLINE lift #-}
315346 lift = fromEffect
316347-}
348+
349+-------------------------------------------------------------------------------
350+-- Convert ParserD to ParserK
351+-------------------------------------------------------------------------------
352+
353+data ChunkResult s b =
354+ ChunkDone !Int !b
355+ | ChunkPartial !Int !s
356+ | ChunkContinue !Int !s
357+ | ChunkError !Int String
358+
359+-- This is very similar to fromParserD in the Array/Unboxed/Fold module.
360+{-# INLINE parseChunk #-}
361+parseChunk
362+ :: forall m a s b. (MonadIO m, Unbox a)
363+ => (s -> a -> m (ParserD.Step s b))
364+ -> s
365+ -> Array a
366+ -> Int
367+ -> m (ChunkResult s b)
368+parseChunk pstep state (Array contents start end) offset = do
369+ if offset >= 0
370+ then go SPEC (start + offset * SIZE_OF(a)) state
371+ else return $ ChunkContinue offset state
372+
373+ where
374+
375+ {-# INLINE onBack #-}
376+ onBack offset1 elemSize constr pst = do
377+ let pos = offset1 - start
378+ in if pos >= 0
379+ then go SPEC offset1 pst
380+ else return $ constr (pos `div` elemSize) pst
381+
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
390+ pRes <- pstep pst x
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
396+ case pRes of
397+ ParserD.Done 0 b ->
398+ return $ ChunkDone nextOff b
399+ ParserD.Done 1 b ->
400+ return $ ChunkDone curOff b
401+ ParserD.Done n b ->
402+ return $ ChunkDone ((back n - start) `div` elemSize) b
403+ ParserD.Partial 0 pst1 ->
404+ go SPEC next pst1
405+ ParserD.Partial 1 pst1 ->
406+ go SPEC cur pst1
407+ ParserD.Partial n pst1 ->
408+ onBack (back n) elemSize ChunkPartial pst1
409+ ParserD.Continue 0 pst1 ->
410+ go SPEC next pst1
411+ ParserD.Continue 1 pst1 ->
412+ go SPEC cur pst1
413+ ParserD.Continue n pst1 ->
414+ onBack (back n) elemSize ChunkContinue pst1
415+ ParserD.Error err ->
416+ return $ ChunkError curOff err
417+
418+{-# INLINE parseDToK #-}
419+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))
424+ -> Int
425+ -> Int
426+ -> Input a
427+ -> (ParseResult b -> Int -> Input a -> m (Step a m r))
428+ -> m (Step a m r)
429+parseDToK pstep initial extract offset usedCount input cont = do
430+ res <- initial
431+ case res of
432+ ParserD.IPartial pst -> do
433+ case input of
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
439+
440+ where
441+
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.
449+ case pRes of
450+ ChunkDone n b ->
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))
459+ ChunkError n err ->
460+ cont (Failure n err) (count + n - off) (Chunk arr)
461+
462+ -- XXX This is not yet finished
463+ {-# NOINLINE parseContSingle #-}
464+ parseContSingle _count off pst x = do
465+ pRes <- pstep pst x
466+ case pRes of
467+ ParserD.Done _n b -> do
468+ cont (Success (off + 1) b) undefined undefined
469+ _ -> undefined
470+
471+ {-# NOINLINE parseContNothing #-}
472+ parseContNothing count pst = do
473+ r <- extract pst
474+ case r of
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.
478+ ParserD.Done n b ->
479+ assert (n >= 0)
480+ (cont (Success (- n) b) (count - n) None)
481+ ParserD.Continue n pst1 ->
482+ assert (n >= 0)
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"
489+
490+ -- XXX Maybe we can use two separate continuations instead of using
491+ -- Just/Nothing cases here. That may help in avoiding the parseContJust
492+ -- function call.
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
497+
498+-- | Convert a raw byte 'Parser' to a chunked parser.
499+--
500+-- /Pre-release/
501+--
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
506+
507+-------------------------------------------------------------------------------
508+-- Convert CPS style 'Parser' to direct style 'D.Parser'
509+-------------------------------------------------------------------------------
510+
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"
517+
518+-- | Convert a CPS style 'ParserK' to a direct style 'ParserD.Parser'.
519+--
520+-- /Pre-release/
521+--
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
525+
526+ where
527+
528+ initial = pure (ParserD.IPartial (\x -> runParser parser 0 0 x parserDone))
529+
530+ step cont a = do
531+ r <- cont (Single a)
532+ return $ case r of
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
537+
538+ extract cont = do
539+ r <- cont None
540+ case r of
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
545+
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 #-}
551+#endif