202c33d · streamly · git.iko.soy

git.iko.soy/streamly

on master help sign in

Add Alternative instance, combinators and parsers

202c33dHarendra Kumar7 years ago

benchmark/Streamly/Benchmark/Data/Parser.hs+76−6

compare with master

unifiedsplit

@@ -13,9 +13,12 @@ module Main

13 ) where

15import Control.DeepSeq (NFData(..))

16+import Control.Monad.Catch (MonadCatch, MonadThrow)

17+-- import Data.Foldable (asum)

16import System.Random (randomRIO)

18import System.Random (randomRIO)

17import Prelude hiding (any, all, take)

19import Prelude hiding (any, all, take)

21+import qualified Control.Applicative as AP

19import qualified Streamly as S hiding (runStream)

22import qualified Streamly as S hiding (runStream)

20import qualified Streamly.Prelude as S

23import qualified Streamly.Prelude as S

21import qualified Streamly.Internal.Data.Fold as FL

24import qualified Streamly.Internal.Data.Fold as FL

@@ -57,28 +60,86 @@ benchIOSink value name f =

57-------------------------------------------------------------------------------

60-------------------------------------------------------------------------------

59{-# INLINE any #-}

62{-# INLINE any #-}

60−any :: (Monad m, Ord a) => a -> SerialT m a -> m Bool

63+any :: (MonadThrow m, Ord a) => a -> SerialT m a -> m Bool

61any value = IP.parse (PR.any (> value))

64any value = IP.parse (PR.any (> value))

63{-# INLINE all #-}

66{-# INLINE all #-}

64−all :: (Monad m, Ord a) => a -> SerialT m a -> m Bool

67+all :: (MonadThrow m, Ord a) => a -> SerialT m a -> m Bool

65all value = IP.parse (PR.all (<= value))

68all value = IP.parse (PR.all (<= value))

67{-# INLINE take #-}

70{-# INLINE take #-}

68−take :: Monad m => Int -> SerialT m a -> m ()

71+take :: MonadThrow m => Int -> SerialT m a -> m ()

69−take value = IP.parse (FL.take value FL.drain)

72+take value = IP.parse (PR.take value FL.drain)

73+

74+{-# INLINE many #-}

75+many :: MonadCatch m => SerialT m Int -> m Int

76+many = IP.parse (PR.many FL.length (PR.satisfy (> 0)))

77+

78+{-# INLINE manyAlt #-}

79+manyAlt :: MonadCatch m => SerialT m Int -> m Int

80+manyAlt xs = do

81+ x <- IP.parse (AP.many (PR.satisfy (> 0))) xs

82+ return $ Prelude.length x

83+

84+{-# INLINE some #-}

85+some :: MonadCatch m => SerialT m Int -> m Int

86+some = IP.parse (PR.some FL.length (PR.satisfy (> 0)))

87+

88+{-# INLINE someAlt #-}

89+someAlt :: MonadCatch m => SerialT m Int -> m Int

90+someAlt xs = do

91+ x <- IP.parse (AP.some (PR.satisfy (> 0))) xs

92+ return $ Prelude.length x

93+

94+{-# INLINE manyTill #-}

95+manyTill :: MonadCatch m => Int -> SerialT m Int -> m Int

96+manyTill value =

97+ IP.parse (PR.manyTill FL.length (PR.satisfy (> 0)) (PR.satisfy (== value)))

98+

99+{-

100+-- XXX -fspec-constr-recursive=16 makes GHC go beserk when compiling this

101+-- We need to fix GHX so that we can have better control over that option or do

102+-- not have to rely on it.

103+--

104+-- choice using the "Alternative" instance with direct style parser type has

105+-- quadratic performance complexity.

106+--

107+{-# INLINE choice #-}

108+choice :: MonadCatch m => Int -> SerialT m Int -> m Int

109+choice value = do

110+ IP.parse (asum (replicate value (PR.satisfy (< 0)))

111+ AP.<|> PR.satisfy (> 0))

112+-}

113

71{-# INLINE splitAllAny #-}

114{-# INLINE splitAllAny #-}

72−splitAllAny :: (Monad m, Ord a)

115+splitAllAny :: (MonadThrow m, Ord a)

73 => a -> SerialT m a -> m (Bool, Bool)

116 => a -> SerialT m a -> m (Bool, Bool)

74splitAllAny value = IP.parse ((,) <$> PR.all (<= value) <*> PR.any (> value))

117splitAllAny value = IP.parse ((,) <$> PR.all (<= value) <*> PR.any (> value))

118

76{-# INLINE teeAllAny #-}

119{-# INLINE teeAllAny #-}

77−teeAllAny :: (Monad m, Ord a)

120+teeAllAny :: (MonadThrow m, Ord a)

78 => a -> SerialT m a -> m (Bool, Bool)

121 => a -> SerialT m a -> m (Bool, Bool)

79teeAllAny value =

122teeAllAny value =

80 IP.parse (PR.teeWith (,) (PR.all (<= value)) (PR.any (> value)))

123 IP.parse (PR.teeWith (,) (PR.all (<= value)) (PR.any (> value)))

124

125+{-# INLINE teeFstAllAny #-}

126+teeFstAllAny :: (MonadThrow m, Ord a)

127+ => a -> SerialT m a -> m (Bool, Bool)

128+teeFstAllAny value =

129+ IP.parse (PR.teeWithFst (,) (PR.all (<= value)) (PR.any (> value)))

130+

131+{-# INLINE shortestAllAny #-}

132+shortestAllAny :: (MonadThrow m, Ord a)

133+ => a -> SerialT m a -> m Bool

134+shortestAllAny value =

135+ IP.parse (PR.shortest (PR.all (<= value)) (PR.any (> value)))

136+

137+{-# INLINE longestAllAny #-}

138+longestAllAny :: (MonadCatch m, Ord a)

139+ => a -> SerialT m a -> m Bool

140+longestAllAny value =

141+ IP.parse (PR.longest (PR.all (<= value)) (PR.any (> value)))

142+

82-------------------------------------------------------------------------------

143-------------------------------------------------------------------------------

83-- Benchmarks

144-- Benchmarks

84-------------------------------------------------------------------------------

145-------------------------------------------------------------------------------

@@ -89,7 +150,16 @@ o_1_space_serial_parse value =

89 , benchIOSink value "all" $ all value

150 , benchIOSink value "all" $ all value

90 , benchIOSink value "take" $ take value

151 , benchIOSink value "take" $ take value

91 , benchIOSink value "split (all,any)" $ splitAllAny value

152 , benchIOSink value "split (all,any)" $ splitAllAny value

153+ , benchIOSink value "many" many

154+ , benchIOSink value "some" some

155+ , benchIOSink value "manyAlt" manyAlt

156+ , benchIOSink value "someAlt" someAlt

157+ , benchIOSink value "manyTill" $ manyTill value

158+ -- , benchIOSink value "choice/100" $ choice (value `div` 100)

92 , benchIOSink value "tee (all,any)" $ teeAllAny value

159 , benchIOSink value "tee (all,any)" $ teeAllAny value

160+ , benchIOSink value "teeFst (all,any)" $ teeFstAllAny value

161+ , benchIOSink value "shortest (all,any)" $ shortestAllAny value

162+ , benchIOSink value "longest (all,any)" $ longestAllAny value

93 ]

163 ]

164

95-------------------------------------------------------------------------------

165-------------------------------------------------------------------------------

benchmark/Streamly/Benchmark/FileIO/Stream.hs+1−1

@@ -448,7 +448,7 @@ inspect $ 'chunksOfD `hasNoType` ''D.ConcatMapUState

448{-# INLINE splitParseChunksOfSum #-}

449splitParseChunksOfSum :: Int -> Handle -> IO Int

450splitParseChunksOfSum n inh =

451− S.length $ IP.splitParse (IFL.take n FL.sum) (S.unfold FH.read inh)

451+ S.length $ IP.splitParse (PR.take n FL.sum) (S.unfold FH.read inh)

452

453{-# INLINE linesUnlinesCopy #-}

454linesUnlinesCopy :: Handle -> Handle -> IO ()

benchmark/streamly-benchmarks.cabal+1

@@ -257,6 +257,7 @@ benchmark parser

257 buildable: False

258 else

259 buildable: True

260+ build-depends: exceptions >= 0.8 && < 0.11

260

261

261-------------------------------------------------------------------------------

262-------------------------------------------------------------------------------

262-- Raw Streams

263-- Raw Streams

src/Streamly/Internal/Data/Fold.hs−33

@@ -129,7 +129,6 @@ module Streamly.Internal.Data.Fold

129

130 -- * Parsing

131 -- ** Trimming

132− , take

133 , ltake

132 , ltake

134 -- , lrunFor -- time

133 -- , lrunFor -- time

135 , ltakeWhile

134 , ltakeWhile

@@ -228,7 +227,6 @@ import qualified Prelude

228

227

229import Streamly.Internal.Data.Pipe.Types (Pipe (..), PipeState(..))

228import Streamly.Internal.Data.Pipe.Types (Pipe (..), PipeState(..))

230import Streamly.Internal.Data.Fold.Types

229import Streamly.Internal.Data.Fold.Types

231−import Streamly.Internal.Data.Parser.Types

232import Streamly.Internal.Data.Strict

230import Streamly.Internal.Data.Strict

233import Streamly.Internal.Data.SVar

231import Streamly.Internal.Data.SVar

234

232

@@ -828,37 +826,6 @@ or = Fold (\x a -> return $ x || a) (return False) return

828------------------------------------------------------------------------------

826------------------------------------------------------------------------------

829-- Grouping without looking at elements

827-- Grouping without looking at elements

830------------------------------------------------------------------------------

828------------------------------------------------------------------------------

831−--

832−-- XXX Once we have terminating folds, this Parse should get replaced by Fold.

833−-- Alternatively, we can name it "chunkOf" and the corresponding time domain

834−-- combinator as "intervalOf" or even "chunk" and "interval".

835−--

836−-- | Take at most @n@ input elements and fold them using the supplied fold.

837−--

838−-- Stops after @n@ elements.

839−-- Never fails.

840−--

841−-- S.chunksOf n f = S.splitParse (FL.take n f)

842−--

843−-- /Internal/

844−--

845−{-# INLINE take #-}

846−take :: Monad m => Int -> Fold m a b -> Parser m a b

847−take n (Fold fstep finitial fextract) = Parser step initial extract

848−

849− where

850−

851− initial = (Tuple' 0) <$> finitial

852−

853− step (Tuple' i r) a = do

854− res <- fstep r a

855− let i1 = i + 1

856− s1 = Tuple' i1 res

857− if i1 < n

858− then return $ Yield 0 s1

859− else Stop 0 <$> fextract res

860−

861− extract (Tuple' _ r) = fextract r

862

829

863------------------------------------------------------------------------------

830------------------------------------------------------------------------------

864-- Binary APIs

831-- Binary APIs

src/Streamly/Internal/Data/Parser.hs+366−49

@@ -10,47 +10,121 @@

10-- Stability : experimental

11-- Portability : GHC

12--

13−-- Parsers.

13+-- Fast streaming parsers.

14+--

15+-- 'Applicative' and 'Alternative' type class based combinators from the

16+-- <http://hackage.haskell.org/package/parser-combinators parser-combinators>

17+-- package can also be used with the 'Parser' type. However, there are two

18+-- important differences between @parser-combinators@ and the equivalent ones

19+-- provided in this module in terms of performance:

20+--

21+-- 1) @parser-combinators@ use plain Haskell lists to collect the results, in a

22+-- strict Monad like IO, the results are necessarily buffered before they can

23+-- be consumed. This may not perform optimally in streaming applications

24+-- processing large amounts of data. Equivalent combinators in this module can

25+-- consume the results of parsing using a 'Fold', thus providing a scalability

26+-- and a generic consumer.

27+--

28+-- 2) Several combinators in this module can be many times faster because of

29+-- stream fusion. For example, 'Streamly.Internal.Data.Parser.many' combinator

30+-- in this module is much faster than the 'Control.Applicative.many' combinator

31+-- of 'Alternative' type class.

32+--

33+-- Failing parsers in this module throw the 'ParseError' exception.

34+

35+-- XXX As far as possible, try that the combinators in this module and in

36+-- "parser-combinators/parsec/megaparsec/attoparsec" have consistent names.

37+-- takeP/takeWhileP?

15module Streamly.Internal.Data.Parser

39module Streamly.Internal.Data.Parser

16 (

40 (

17 Parser (..)

41 Parser (..)

19− -- * Combinators

43+ -- First order parsers

44+ -- * Accumulators

20 , fromFold

45 , fromFold

21−

22− -- * Folds

23 , any

46 , any

24 , all

47 , all

25−

48+ , yield

49+ , yieldM

50+ , die

51+ , dieM

52+

53+ -- * Element parsers

54+ , peek

55+ , eof

56+ , satisfy

57+

58+ -- * Sequence parsers

59+ -- Grab a sequence of input elements without inspecting them

60+ , take

61+ -- , takeBetween

62+ -- , takeLE -- take -- takeBetween 0 n

63+ -- , takeLE1 -- take1 -- takeBetween 1 n

64+ , takeEQ -- takeBetween n n

65+ , takeGE -- takeBetween n maxBound

66+

67+ -- Grab a sequence of input elements by inspecting them

68+ , takeWhile

69+ -- , takeWhileBetween

26 , sepBy

70 , sepBy

27 , sepByMax

71 , sepByMax

72+ -- , sepByBetween

28 , sepWithSuffix

73 , sepWithSuffix

29− , wordBy

30−

31− -- * Parsers

32− , takeWhile

33− , takeEQ

34− , takeGE

35−

36 , sepWithPrefix

74 , sepWithPrefix

37− -- , sepWithInfix

75+ , wordBy

38 , groupBy

76 , groupBy

78+ -- Second order parsers (parsers using parsers)

79+ -- * Binary Combinators

80+

40 -- Parallel parsers

81 -- Parallel parsers

41 , teeWith

82 , teeWith

42 , teeWithFst

83 , teeWithFst

43 , teeWithMin

84 , teeWithMin

85+

86+ -- Alternatives

87+ , shortest

88+ , longest

89+ -- , fastest

90+

91+ -- * N-ary Combinators

92+ -- N-ary split applicative

93+ -- Run n actions in sequence

94+ , sequence

95+

96+ -- Repeat the same action in sequence

97+ -- , splitLE

98+ -- , splitEQ -- splitN/takeN/parseN = replicateM n

99+ -- , splitGE -- splitEQ n, splitMany

100+ , count

101+ , countBetween

102+ , many -- splitMany/takeMany/parseMany

103+ -- = splitGE 0 = countBetween 0 maxBound

104+ , some -- splitMany1/takeMany1/parseMany1

105+ -- = splitGE 1 = countBetween 1 maxBound

106+

107+ -- , countBetweenTill

108+ , manyTill -- splitBreakOn, manyTill, parseBreakOn

109+

110+ -- Run n actions in parallel

111+ -- , shortestN

112+ -- , longestN

113+ -- , fastestN -- first N successful in time

114+ , choice -- first successful in position

115+ -- , choiceN -- first N successful

44 )

116 )

45where

117where

118

119+import Control.Exception (assert)

120+import Control.Monad.Catch (MonadCatch, MonadThrow(..))

47import Prelude

121import Prelude

48− hiding (any, all, takeWhile)

122+ hiding (any, all, take, takeWhile, sequence)

123

50import Streamly.Internal.Data.Fold.Types (Fold(..))

124import Streamly.Internal.Data.Fold.Types (Fold(..))

51−import Streamly.Internal.Data.Parser.Tee (teeWith, teeWithFst, teeWithMin)

52−import Streamly.Internal.Data.Parser.Types (Parser(..), Step(..))

125

126+import Streamly.Internal.Data.Parser.Tee

127+import Streamly.Internal.Data.Parser.Types

54import Streamly.Internal.Data.Strict

128import Streamly.Internal.Data.Strict

129

56-------------------------------------------------------------------------------

130-------------------------------------------------------------------------------

@@ -111,9 +185,109 @@ all predicate = Parser step initial return

111 else Stop 0 False

185 else Stop 0 False

112 else Stop 0 False

186 else Stop 0 False

113

187

188+-------------------------------------------------------------------------------

189+-- Failing Parsers

190+-------------------------------------------------------------------------------

191+

192+-- | Peek the head element of a stream, without consuming it. Fails if it

193+-- encounters end of input.

194+--

195+-- >>> S.parse ((,) <$> PR.peek <*> PR.satisfy (> 0)) $ S.fromList [1]

196+-- (1,1)

197+--

198+-- /Internal/

199+--

200+{-# INLINABLE peek #-}

201+peek :: MonadThrow m => Parser m a a

202+peek = Parser step initial extract

203+

204+ where

205+

206+ initial = return ()

207+

208+ step () a = return $ Stop 1 a

209+

210+ extract () = throwM $ ParseError "peek: end of input"

211+

212+-- | Succeeds if we are at the end of input, fails otherwise.

213+--

214+-- >>> S.parse ((,) <$> PR.satisfy (> 0) <*> PR.eof) $ S.fromList [1]

215+-- > (1,())

216+--

217+-- /Internal/

218+--

219+{-# INLINABLE eof #-}

220+eof :: Monad m => Parser m a ()

221+eof = Parser step initial return

222+

223+ where

224+

225+ initial = return ()

226+

227+ step () _ = return $ Error "eof: not at end of input"

228+

229+-- | Returns the next element if it passes the predicate, fails otherwise.

230+--

231+-- >>> S.parse (PR.satisfy (== 1)) $ S.fromList [1,0,1]

232+-- > 1

233+--

234+-- /Internal/

235+--

236+{-# INLINE satisfy #-}

237+satisfy :: MonadThrow m => (a -> Bool) -> Parser m a a

238+satisfy predicate = Parser step initial extract

239+

240+ where

241+

242+ initial = return ()

243+

244+ step () a = return $

245+ if predicate a

246+ then Stop 0 a

247+ else Error "satisfy: predicate failed"

248+

249+ extract _ = throwM $ ParseError "satisfy: end of input"

250+

114-------------------------------------------------------------------------------

251-------------------------------------------------------------------------------

115-- Taking elements

252-- Taking elements

116-------------------------------------------------------------------------------

253-------------------------------------------------------------------------------

254+--

255+-- XXX Once we have terminating folds, this Parse should get replaced by Fold.

256+-- Alternatively, we can name it "chunkOf" and the corresponding time domain

257+-- combinator as "intervalOf" or even "chunk" and "interval".

258+--

259+-- | Take at most @n@ input elements and fold them using the supplied fold.

260+--

261+-- Stops after @n@ elements.

262+-- Never fails.

263+--

264+-- >>> S.parse (PR.take 1 FL.toList) $ S.fromList [1]

265+-- [1]

266+--

267+-- @

268+-- S.chunksOf n f = S.splitParse (FL.take n f)

269+-- @

270+--

271+-- /Internal/

272+--

273+{-# INLINE take #-}

274+take :: Monad m => Int -> Fold m a b -> Parser m a b

275+take n (Fold fstep finitial fextract) = Parser step initial extract

276+

277+ where

278+

279+ initial = Tuple' 0 <$> finitial

280+

281+ step (Tuple' i r) a = do

282+ res <- fstep r a

283+ let i1 = i + 1

284+ s1 = Tuple' i1 res

285+ if i1 < n

286+ then return $ Yield 0 s1

287+ else Stop 0 <$> fextract res

288+

289+ extract (Tuple' _ r) = fextract r

290+

117--

291--

118-- XXX can we use a "cmp" operation in a common implementation?

292-- XXX can we use a "cmp" operation in a common implementation?

119--

293--

@@ -122,13 +296,13 @@ all predicate = Parser step initial return

122-- * Stops - after @n@ elements.

296-- * Stops - after @n@ elements.

123-- * Fails - if the stream ends before it can collect @n@ elements.

297-- * Fails - if the stream ends before it can collect @n@ elements.

124--

298--

125−-- >>> S.parse (PR.takeExact 4 FL.toList) $ S.fromList [1,0,1]

299+-- >>> S.parse (PR.takeEQ 4 FL.toList) $ S.fromList [1,0,1]

126−-- > Left "takeEQ: Expecting exactly 4 elements, got 3"

300+-- > "takeEQ: Expecting exactly 4 elements, got 3"

127--

301--

128-- /Internal/

302-- /Internal/

129--

303--

130{-# INLINE takeEQ #-}

304{-# INLINE takeEQ #-}

131−takeEQ :: Monad m => Int -> Fold m a b -> Parser m a b

305+takeEQ :: MonadThrow m => Int -> Fold m a b -> Parser m a b

132takeEQ n (Fold fstep finitial fextract) = Parser step initial extract

306takeEQ n (Fold fstep finitial fextract) = Parser step initial extract

133

307

134 where

308 where

@@ -144,7 +318,7 @@ takeEQ n (Fold fstep finitial fextract) = Parser step initial extract

144 extract (Tuple' i r) =

318 extract (Tuple' i r) =

145 if n == i

319 if n == i

146 then fextract r

320 then fextract r

147− else error err

321+ else throwM $ ParseError err

148

322

149 where

323 where

150

324

@@ -155,18 +329,18 @@ takeEQ n (Fold fstep finitial fextract) = Parser step initial extract

155-- | Take at least @n@ input elements, but can collect more.

329-- | Take at least @n@ input elements, but can collect more.

156--

330--

157-- * Stops - never.

331-- * Stops - never.

158−-- * Fails - if the stream end before producing @n@ elements.

332+-- * Fails - if the stream ends before producing @n@ elements.

159--

333--

160-- >>> S.parse (PR.takeGE 4 FL.toList) $ S.fromList [1,0,1]

334-- >>> S.parse (PR.takeGE 4 FL.toList) $ S.fromList [1,0,1]

161−-- > Left "takeGE: Expecting at least 4 elements, got only 3"

335+-- > "takeGE: Expecting at least 4 elements, got only 3"

162--

336--

163-- >>> S.parse (PR.takeGE 4 FL.toList) $ S.fromList [1,0,1,0,1]

337-- >>> S.parse (PR.takeGE 4 FL.toList) $ S.fromList [1,0,1,0,1]

164−-- > Right [1,0,1,0,1]

338+-- > [1,0,1,0,1]

165--

339--

166-- /Internal/

340-- /Internal/

167--

341--

168{-# INLINE takeGE #-}

342{-# INLINE takeGE #-}

169−takeGE :: Monad m => Int -> Fold m a b -> Parser m a b

343+takeGE :: MonadThrow m => Int -> Fold m a b -> Parser m a b

170takeGE n (Fold fstep finitial fextract) = Parser step initial extract

344takeGE n (Fold fstep finitial fextract) = Parser step initial extract

171

345

172 where

346 where

@@ -182,7 +356,7 @@ takeGE n (Fold fstep finitial fextract) = Parser step initial extract

182 then Skip 0 s1

356 then Skip 0 s1

183 else Yield 0 s1

357 else Yield 0 s1

184

358

185− extract (Tuple' i r) = fmap f (fextract r)

359+ extract (Tuple' i r) = fextract r >>= f

186

360

187 where

361 where

188

362

@@ -192,17 +366,19 @@ takeGE n (Fold fstep finitial fextract) = Parser step initial extract

192

366

193 f x =

367 f x =

194 if i >= n

368 if i >= n

195− then x

369+ then return x

196− else error err

370+ else throwM $ ParseError err

197

371

198−-- | Take until the predicate fails. The element on which the predicate fails

372+-- | Collect stream elements until an element fails the predicate. The element

199−-- is returned back to the input stream.

373+-- on which the predicate fails is returned back to the input stream.

200--

374--

201-- * Stops - when the predicate fails.

375-- * Stops - when the predicate fails.

202-- * Fails - never.

376-- * Fails - never.

203--

377--

204-- >>> S.parse (PR.takeWhile (== 0) FL.toList) $ S.fromList [0,0,1,0,1]

378-- >>> S.parse (PR.takeWhile (== 0) FL.toList) $ S.fromList [0,0,1,0,1]

205−-- > Right [0,0]

379+-- > [0,0]

380+--

381+-- We can implement a @breakOn@ using 'takeWhile':

206--

382--

207-- @

383-- @

208-- breakOn p = takeWhile (not p)

384-- breakOn p = takeWhile (not p)

@@ -224,20 +400,21 @@ takeWhile predicate (Fold fstep finitial fextract) =

224 then Yield 0 <$> fstep s a

400 then Yield 0 <$> fstep s a

225 else Stop 1 <$> fextract s

401 else Stop 1 <$> fextract s

226

402

227−-- | Keep taking elements until the predicate succeeds. Drop the succeeding

403+-- | Collect stream elements until an element succeeds the predicate. Drop the

228−-- element.

404+-- element on which the predicate succeeded. The succeeding element is treated

405+-- as an infix separator which is dropped from the output.

229--

406--

230-- * Stops - when the predicate succeeds.

407-- * Stops - when the predicate succeeds.

231-- * Fails - never.

408-- * Fails - never.

232--

409--

233-- >>> S.parse (PR.sepBy (== 1) FL.toList) $ S.fromList [0,0,1,0,1]

410-- >>> S.parse (PR.sepBy (== 1) FL.toList) $ S.fromList [0,0,1,0,1]

234−-- > Right [0,0]

411+-- > [0,0]

412+--

413+-- S.splitOn pred f = S.splitParse (PR.sepBy pred f)

235--

414--

236-- >>> S.toList $ S.splitParse (PR.sepBy (== 1) FL.toList) $ S.fromList [0,0,1,0,1]

415-- >>> S.toList $ S.splitParse (PR.sepBy (== 1) FL.toList) $ S.fromList [0,0,1,0,1]

237-- > [[0,0],[0],[]]

416-- > [[0,0],[0],[]]

238--

417--

239−-- S.splitOn pred f = S.splitParse (PR.sepBy pred f)

240−--

241-- /Internal/

418-- /Internal/

242--

419--

243{-# INLINABLE sepBy #-}

420{-# INLINABLE sepBy #-}

@@ -253,8 +430,9 @@ sepBy predicate (Fold fstep finitial fextract) =

253 then Yield 0 <$> fstep s a

430 then Yield 0 <$> fstep s a

254 else Stop 0 <$> fextract s

431 else Stop 0 <$> fextract s

255

432

256−-- | Keep taking elements until the predicate succeeds. Take the succeeding

433+-- | Collect stream elements until an element succeeds the predicate. Also take

257−-- element as well.

434+-- the element on which the predicate succeeded. The succeeding element is

435+-- treated as a suffix separator which is kept in the output segement.

258--

436--

259-- * Stops - when the predicate succeeds.

437-- * Stops - when the predicate succeeds.

260-- * Fails - never.

438-- * Fails - never.

@@ -269,10 +447,13 @@ sepWithSuffix ::

269 (a -> Bool) -> Fold m a b -> Parser m a b

447 (a -> Bool) -> Fold m a b -> Parser m a b

270sepWithSuffix = undefined

448sepWithSuffix = undefined

271

449

272−-- | Keep taking elements until the predicate succeeds. Return the succeeding

450+-- | Collect stream elements until an elements passes the predicate, return the

273−-- element back to the input.

451+-- last element on which the predicate succeeded back to the input stream. If

452+-- the predicate succeeds on the first element itself then it is kept in the

453+-- stream and we continue collecting. The succeeding element is treated as a

454+-- prefix separator which is kept in the output segement.

274--

455--

275−-- * Stops - when the predicate succeeds.

456+-- * Stops - when the predicate succeeds in non-leading position.

276-- * Fails - never.

457-- * Fails - never.

277--

458--

278-- S.splitWithPrefix pred f = S.splitParse (PR.sepWithPrefix pred f)

459-- S.splitWithPrefix pred f = S.splitParse (PR.sepWithPrefix pred f)

@@ -294,7 +475,7 @@ sepWithPrefix = undefined

294{-# INLINABLE sepByMax #-}

475{-# INLINABLE sepByMax #-}

295sepByMax :: Monad m

476sepByMax :: Monad m

296 => (a -> Bool) -> Int -> Fold m a b -> Parser m a b

477 => (a -> Bool) -> Int -> Fold m a b -> Parser m a b

297−sepByMax predicate count (Fold fstep finitial fextract) =

478+sepByMax predicate cnt (Fold fstep finitial fextract) =

298 Parser step initial extract

479 Parser step initial extract

299

480

300 where

481 where

@@ -304,22 +485,24 @@ sepByMax predicate count (Fold fstep finitial fextract) =

304 res <- fstep r a

485 res <- fstep r a

305 let i1 = i + 1

486 let i1 = i + 1

306 s1 = Tuple' i1 res

487 s1 = Tuple' i1 res

307− if not (predicate a) && i1 < count

488+ if not (predicate a) && i1 < cnt

308 then return $ Yield 0 s1

489 then return $ Yield 0 s1

309 else do

490 else do

310 b <- fextract res

491 b <- fextract res

311 return $ Stop 0 b

492 return $ Stop 0 b

312 extract (Tuple' _ r) = fextract r

493 extract (Tuple' _ r) = fextract r

313

494

314−-- | Like 'splitOn' after stripping leading, trailing, and repeated separators.

495+-- | Like 'splitOn' but strips leading, trailing, and repeated separators.

315−-- Therefore, @".a..b."@ with '.' as the separator would be parsed as

496+-- Therefore, @".a..b."@ having '.' as the separator would be parsed as

316-- @["a","b"]@. In other words, its like parsing words from whitespace

497-- @["a","b"]@. In other words, its like parsing words from whitespace

317-- separated text.

498-- separated text.

318--

499--

319-- * Stops - when it finds a word separator after a non-word element

500-- * Stops - when it finds a word separator after a non-word element

320-- * Fails - never.

501-- * Fails - never.

321--

502--

503+-- @

322-- S.wordsBy pred f = S.splitParse (PR.wordBy pred f)

504-- S.wordsBy pred f = S.splitParse (PR.wordBy pred f)

505+-- @

323--

506--

324-- /Unimplemented/

507-- /Unimplemented/

325--

508--

@@ -329,17 +512,19 @@ wordBy ::

329 (a -> Bool) -> Fold m a b -> Parser m a b

512 (a -> Bool) -> Fold m a b -> Parser m a b

330wordBy = undefined

513wordBy = undefined

331

514

332−-- | @group cmp f $ S.fromList [a,b,c,...]@ assigns the element @a@ to the

515+-- | @groupBy cmp f $ S.fromList [a,b,c,...]@ assigns the element @a@ to the

333−-- first group, if @a \`cmp` b@ is 'True' then @b@ is also assigned to the same

516+-- first group, then if @a \`cmp` b@ is 'True' @b@ is also assigned to the same

334-- group. If @a \`cmp` c@ is 'True' then @c@ is also assigned to the same

517-- group. If @a \`cmp` c@ is 'True' then @c@ is also assigned to the same

335-- group and so on. When the comparison fails a new group is started. Each

518-- group and so on. When the comparison fails a new group is started. Each

336−-- group is folded using the fold @f@ and the result of the fold is emitted in

519+-- group is folded using the 'Fold' @f@ and the result of the fold is emitted

337−-- the output stream.

520+-- in the output stream.

338--

521--

339−-- * Stops - when the group ends.

522+-- * Stops - when the comparison fails.

340-- * Fails - never.

523-- * Fails - never.

341--

524--

525+-- @

342-- S.groupsBy cmp f = S.splitParse (PR.groupBy cmp f)

526-- S.groupsBy cmp f = S.splitParse (PR.groupBy cmp f)

527+-- @

343--

528--

344-- /Unimplemented/

529-- /Unimplemented/

345--

530--

@@ -348,3 +533,135 @@ groupBy ::

348 -- Monad m =>

533 -- Monad m =>

349 (a -> a -> Bool) -> Fold m a b -> Parser m a b

534 (a -> a -> Bool) -> Fold m a b -> Parser m a b

350groupBy = undefined

535groupBy = undefined

536+

537+-------------------------------------------------------------------------------

538+-- nested parsers

539+-------------------------------------------------------------------------------

540+

541+-- | @sequence f t@ collects sequential parses of parsers in the container @t@

542+-- using the fold @f@. Fails if the input ends or any of the parsers fail.

543+--

544+-- /Unimplemented/

545+--

546+{-# INLINE sequence #-}

547+sequence ::

548+ -- Foldable t =>

549+ Fold m b c -> t (Parser m a b) -> Parser m a c

550+sequence _f _p = undefined

551+

552+-- | @choice parsers@ applies the @parsers@ in order and returns the first

553+-- successful parse.

554+--

555+{-# INLINE choice #-}

556+choice ::

557+ -- Foldable t =>

558+ t (Parser m a b) -> Parser m a b

559+choice _ps = undefined

560+

561+-- XXX "many" is essentially a Fold because it cannot fail. So it can be

562+-- downgraded to a Fold. Or we can make the return type a Fold instead and

563+-- upgrade that to a parser when needed.

564+--

565+-- | Collect zero or more parses. Apply the parser repeatedly on the input

566+-- stream, stop when the parser fails, accumulate zero or more parse results

567+-- using the supplied 'Fold'. This parser never fails, in case the first

568+-- application of parser fails it returns an empty result.

569+--

570+-- Compare with 'Control.Applicative.many'.

571+--

572+-- /Internal/

573+--

574+{-# INLINE many #-}

575+many :: MonadCatch m => Fold m b c -> Parser m a b -> Parser m a c

576+many = splitMany

577+

578+-- | Collect one or more parses. Apply the supplied parser repeatedly on the

579+-- input stream and accumulate the parse results as long as the parser

580+-- succeeds, stop when it fails. This parser fails if not even one result is

581+-- collected.

582+--

583+-- Compare with 'Control.Applicative.some'.

584+--

585+-- /Internal/

586+--

587+{-# INLINE some #-}

588+some :: MonadCatch m => Fold m b c -> Parser m a b -> Parser m a c

589+some = splitSome

590+

591+-- | @countBetween m n f p@ collects between @m@ and @n@ sequential parses of

592+-- parser @p@ using the fold @f@. Stop after collecting @n@ results. Fails if

593+-- the input ends or the parser fails before @m@ results are collected.

594+--

595+-- /Unimplemented/

596+--

597+{-# INLINE countBetween #-}

598+countBetween ::

599+ -- MonadCatch m =>

600+ Int -> Int -> Fold m b c -> Parser m a b -> Parser m a c

601+countBetween _m _n _f = undefined

602+

603+-- | @count n f p@ collects exactly @n@ sequential parses of parser @p@ using

604+-- the fold @f@. Fails if the input ends or the parser fails before @n@

605+-- results are collected.

606+--

607+-- /Unimplemented/

608+--

609+{-# INLINE count #-}

610+count ::

611+ -- MonadCatch m =>

612+ Int -> Fold m b c -> Parser m a b -> Parser m a c

613+count n = countBetween n n

614+

615+data ManyTillState fs sr sl = ManyTillR Int fs sr | ManyTillL fs sl

616+

617+-- | @manyTill f collect test@ tries the parser @test@ on the input, if @test@

618+-- fails it backtracks and tries @collect@, after @collect@ succeeds @test@ is

619+-- tried again and so on. The parser stops when @test@ succeeds. The output of

620+-- @test@ is discarded and the output of @collect@ is accumulated by the

621+-- supplied fold. The parser fails if @collect@ fails.

622+--

623+-- /Internal/

624+--

625+{-# INLINE manyTill #-}

626+manyTill :: MonadCatch m

627+ => Fold m b c -> Parser m a b -> Parser m a x -> Parser m a c

628+manyTill (Fold fstep finitial fextract)

629+ (Parser stepL initialL extractL)

630+ (Parser stepR initialR _) =

631+ Parser step initial extract

632+

633+ where

634+

635+ initial = do

636+ fs <- finitial

637+ ManyTillR 0 fs <$> initialR

638+

639+ step (ManyTillR cnt fs st) a = do

640+ r <- stepR st a

641+ case r of

642+ Yield n s -> return $ Yield n (ManyTillR 0 fs s)

643+ Skip n s -> do

644+ assert (cnt + 1 - n >= 0) (return ())

645+ return $ Skip n (ManyTillR (cnt + 1 - n) fs s)

646+ Stop n _ -> do

647+ b <- fextract fs

648+ return $ Stop n b

649+ Error _ -> do

650+ rR <- initialL

651+ return $ Skip (cnt + 1) (ManyTillL fs rR)

652+

653+ step (ManyTillL fs st) a = do

654+ r <- stepL st a

655+ case r of

656+ Yield n s -> return $ Yield n (ManyTillL fs s)

657+ Skip n s -> return $ Skip n (ManyTillL fs s)

658+ Stop n b -> do

659+ fs1 <- fstep fs b

660+ l <- initialR

661+ -- XXX we need a yield with backtrack here

662+ -- return $ Yield n (ManyTillR 0 fs1 l)

663+ return $ Skip n (ManyTillR 0 fs1 l)

664+ Error err -> return $ Error err

665+

666+ extract (ManyTillL fs sR) = extractL sR >>= fstep fs >>= fextract

667+ extract (ManyTillR _ fs _) = fextract fs

src/Streamly/Internal/Data/Parser/Tee.hs+258−33

@@ -1,4 +1,5 @@

1−{-# LANGUAGE CPP #-}

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE ScopedTypeVariables #-}

3-- Somehow uni-pattern match using "let" produces better optimized code

4-- Somehow uni-pattern match using "let" produces better optimized code

4-- compared to using cases and using explicit "error" messages in unreachable

5-- compared to using cases and using explicit "error" messages in unreachable

@@ -25,37 +26,52 @@

26module Streamly.Internal.Data.Parser.Tee

27module Streamly.Internal.Data.Parser.Tee

27 (

28 (

28− -- Parallel parsers

29+ -- Parallel zipped

29 teeWith

30 teeWith

30 , teeWithFst

31 , teeWithFst

31 , teeWithMin

32 , teeWithMin

33+

34+ -- Parallel alternatives

35+ , shortest

36+ , longest

32 )

37 )

33where

38where

35import Control.Exception (assert)

40import Control.Exception (assert)

41+import Control.Monad.Catch (MonadCatch, try)

36import Prelude

42import Prelude

37 hiding (any, all, takeWhile)

43 hiding (any, all, takeWhile)

39import Fusion.Plugin.Types (Fuse(..))

45import Fusion.Plugin.Types (Fuse(..))

40−import Streamly.Internal.Data.Parser.Types (Parser(..), Step(..))

46+import Streamly.Internal.Data.Parser.Types (Parser(..), Step(..), ParseError)

42-------------------------------------------------------------------------------

48-------------------------------------------------------------------------------

43−-- Distributing Parsers

49+-- Distribute input to two parsers and collect both results

44-------------------------------------------------------------------------------

50-------------------------------------------------------------------------------

46data StepState s a = StepState s | StepResult a

52data StepState s a = StepState s | StepResult a

54+-- XXX Use a Zipper structure for buffering?

55+--

48-- | State of the pair of parsers in a tee composition

56-- | State of the pair of parsers in a tee composition

49-- Note: strictness annotation is important for fusing the constructors

57-- Note: strictness annotation is important for fusing the constructors

50{-# ANN type TeeState Fuse #-}

58{-# ANN type TeeState Fuse #-}

51data TeeState sL sR x a b =

59data TeeState sL sR x a b =

60+-- @TeePair (past buffer, parser state, future-buffer1, future-buffer2) ...@

52 TeePair !([x], StepState sL a, [x], [x]) !([x], StepState sR b, [x], [x])

61 TeePair !([x], StepState sL a, [x], [x]) !([x], StepState sR b, [x], [x])

54−data Res = Yld Int | Stp Int | Skp

63+data Res = Yld Int | Stp Int | Skp | Err String

56-- XXX: With the current "Step" semantics, it is hard to write, and not sure

65-- XXX: With the current "Step" semantics, it is hard to write, and not sure

57-- how useful, an efficient teeWith that returns a correct unused input count.

66-- how useful, an efficient teeWith that returns a correct unused input count.

58--

67--

68+-- XXX Teeing a parser with a Fold could be more useful and simpler to

69+-- implement. A fold never fails or backtracks so we do not need to buffer the

70+-- input for the fold. It can be useful in, for example, maintaining the line

71+-- and column number position to report for errors. We can always have the

72+-- line/column fold running in parallel with the main parser, whenever an error

73+-- occurs we can zip the error with the context fold.

74+--

59-- | @teeWith f p1 p2@ distributes its input to both @p1@ and @p2@ until both

75-- | @teeWith f p1 p2@ distributes its input to both @p1@ and @p2@ until both

60-- of them succeed or fail and combines their output using @f@. The parser

76-- of them succeed or fail and combines their output using @f@. The parser

61-- succeeds if both the parsers succeed.

77-- succeeds if both the parsers succeed.

@@ -104,6 +120,7 @@ teeWith zf (Parser stepL initialL extractL) (Parser stepR initialR extractR) =

104 src = Prelude.reverse src0

120 src = Prelude.reverse src0

105 state = (buf2, StepState s, src ++ inp11, inp21)

121 state = (buf2, StepState s, src ++ inp11, inp21)

106 in assert (n <= length buf1) (return (state, Skp))

122 in assert (n <= length buf1) (return (state, Skp))

123+ Error err -> return (undefined, Err err)

107

124

108 {-# INLINE_LATE step #-}

125 {-# INLINE_LATE step #-}

109 step (TeePair (bufL, StepState sL, inpL1, inpL2)

126 step (TeePair (bufL, StepState sL, inpL1, inpL2)

@@ -121,6 +138,8 @@ teeWith zf (Parser stepL initialL extractL) (Parser stepR initialR extractR) =

121 let (_, StepResult rL, _, _) = l

138 let (_, StepResult rL, _, _) = l

122 (_, StepResult rR, _, _) = r

139 (_, StepResult rR, _, _) = r

123 in Stop (min n1 n2) (zf rL rR)

140 in Stop (min n1 n2) (zf rL rR)

141+ (Err err, _) -> Error err

142+ (_, Err err) -> Error err

124 _ -> Skip 0 next

143 _ -> Skip 0 next

125

144

126 step (TeePair (bufL, StepState sL, inpL1, inpL2)

145 step (TeePair (bufL, StepState sL, inpL1, inpL2)

@@ -137,6 +156,7 @@ teeWith zf (Parser stepL initialL extractL) (Parser stepR initialR extractR) =

137 let (_, StepResult rL, _, _) = l

156 let (_, StepResult rL, _, _) = l

138 in Stop n (zf rL rR)

157 in Stop n (zf rL rR)

139 Skp -> Skip 0 next

158 Skp -> Skip 0 next

159+ Err err -> Error err

140

160

141 step (TeePair l@(_, StepResult rL, _, _)

161 step (TeePair l@(_, StepResult rL, _, _)

142 (bufR, StepState sR, inpR1, inpR2)) x = do

162 (bufR, StepState sR, inpR1, inpR2)) x = do

@@ -152,28 +172,25 @@ teeWith zf (Parser stepL initialL extractL) (Parser stepR initialR extractR) =

152 let (_, StepResult rR, _, _) = r

172 let (_, StepResult rR, _, _) = r

153 in Stop n (zf rL rR)

173 in Stop n (zf rL rR)

154 Skp -> Skip 0 next

174 Skp -> Skip 0 next

175+ Err err -> Error err

155

176

156 step _ _ = undefined

177 step _ _ = undefined

157

178

158− {-# INLINE extractBoth #-}

159− extractBoth sL sR = do

160− rL <- extractL sL

161− rR <- extractR sR

162− return (zf rL rR)

163−

164 {-# INLINE_LATE extract #-}

179 {-# INLINE_LATE extract #-}

165 extract st =

180 extract st =

166 case st of

181 case st of

167− TeePair (_, StepState sL, _, _) (_, StepState sR, _, _) ->

182+ TeePair (_, StepState sL, _, _) (_, StepState sR, _, _) -> do

168− extractBoth sL sR

183+ rL <- extractL sL

184+ rR <- extractR sR

185+ return $ zf rL rR

169− TeePair (_, StepState sL, _, _) (_, StepResult rR, _, _) -> do

186+ TeePair (_, StepState sL, _, _) (_, StepResult rR, _, _) -> do

170− rL <- extractL sL

187+ rL <- extractL sL

171− return $ zf rL rR

188+ return $ zf rL rR

172− TeePair (_, StepResult rL, _, _) (_, StepState sR, _, _) -> do

189+ TeePair (_, StepResult rL, _, _) (_, StepState sR, _, _) -> do

173− rR <- extractR sR

190+ rR <- extractR sR

174− return $ zf rL rR

191+ return $ zf rL rR

175− TeePair (_, StepResult rL, _, _) (_, StepResult rR, _, _) ->

192+ TeePair (_, StepResult rL, _, _) (_, StepResult rR, _, _) ->

176− return $ zf rL rR

193+ return $ zf rL rR

177

194

178-- | Like 'teeWith' but ends parsing and zips the results, if available,

195-- | Like 'teeWith' but ends parsing and zips the results, if available,

179-- whenever the first parser ends.

196-- whenever the first parser ends.

@@ -223,6 +240,7 @@ teeWithFst zf (Parser stepL initialL extractL)

223 src = Prelude.reverse src0

240 src = Prelude.reverse src0

224 state = (buf2, StepState s, src ++ inp11, inp21)

241 state = (buf2, StepState s, src ++ inp11, inp21)

225 in assert (n <= length buf1) (return (state, Skp))

242 in assert (n <= length buf1) (return (state, Skp))

243+ Error err -> return (undefined, Err err)

226

244

227 {-# INLINE_LATE step #-}

245 {-# INLINE_LATE step #-}

228 step (TeePair (bufL, StepState sL, inpL1, inpL2)

246 step (TeePair (bufL, StepState sL, inpL1, inpL2)

@@ -250,6 +268,8 @@ teeWithFst zf (Parser stepL initialL extractL)

250 return $ Stop n1 (zf rL rR)

268 return $ Stop n1 (zf rL rR)

251 (Yld n1, Yld n2) -> return $ Yield (min n1 n2) next

269 (Yld n1, Yld n2) -> return $ Yield (min n1 n2) next

252 (Yld n1, Stp n2) -> return $ Yield (min n1 n2) next

270 (Yld n1, Stp n2) -> return $ Yield (min n1 n2) next

271+ (Err err, _) -> return $ Error err

272+ (_, Err err) -> return $ Error err

253 _ -> return $ Skip 0 next

273 _ -> return $ Skip 0 next

254

274

255 step (TeePair (bufL, StepState sL, inpL1, inpL2)

275 step (TeePair (bufL, StepState sL, inpL1, inpL2)

@@ -266,24 +286,21 @@ teeWithFst zf (Parser stepL initialL extractL)

266 let (_, StepResult rL, _, _) = l

286 let (_, StepResult rL, _, _) = l

267 in Stop n (zf rL rR)

287 in Stop n (zf rL rR)

268 Skp -> Skip 0 next

288 Skp -> Skip 0 next

289+ Err err -> Error err

269

290

270 step _ _ = undefined

291 step _ _ = undefined

271

292

272− {-# INLINE extractBoth #-}

273− extractBoth sL sR = do

274− rL <- extractL sL

275− rR <- extractR sR

276− return (zf rL rR)

277−

278 {-# INLINE_LATE extract #-}

293 {-# INLINE_LATE extract #-}

279 extract st =

294 extract st =

280 case st of

295 case st of

281− TeePair (_, StepState sL, _, _) (_, StepState sR, _, _) ->

296+ TeePair (_, StepState sL, _, _) (_, StepState sR, _, _) -> do

282− extractBoth sL sR

297+ rL <- extractL sL

298+ rR <- extractR sR

299+ return $ zf rL rR

283− TeePair (_, StepState sL, _, _) (_, StepResult rR, _, _) -> do

300+ TeePair (_, StepState sL, _, _) (_, StepResult rR, _, _) -> do

284− rL <- extractL sL

301+ rL <- extractL sL

285− return $ zf rL rR

302+ return $ zf rL rR

286− _ -> error "unreachable"

303+ _ -> error "unreachable"

287

304

288-- | Like 'teeWith' but ends parsing and zips the results, if available,

305-- | Like 'teeWith' but ends parsing and zips the results, if available,

289-- whenever any of the parsers ends or fails.

306-- whenever any of the parsers ends or fails.

@@ -295,3 +312,211 @@ teeWithMin ::

295 -- Monad m =>

312 -- Monad m =>

296 (a -> b -> c) -> Parser m x a -> Parser m x b -> Parser m x c

313 (a -> b -> c) -> Parser m x a -> Parser m x b -> Parser m x c

297teeWithMin = undefined

314teeWithMin = undefined

315+

316+-------------------------------------------------------------------------------

317+-- Distribute input to two parsers and choose one result

318+-------------------------------------------------------------------------------

319+

320+-- | Shortest alternative. Apply both parsers in parallel but choose the result

321+-- from the one which consumed least input i.e. take the shortest succeeding

322+-- parse.

323+--

324+-- /Internal/

325+--

326+{-# INLINE shortest #-}

327+shortest :: Monad m => Parser m x a -> Parser m x a -> Parser m x a

328+shortest (Parser stepL initialL extractL) (Parser stepR initialR _) =

329+ Parser step initial extract

330+

331+ where

332+

333+ {-# INLINE_LATE initial #-}

334+ initial = do

335+ sL <- initialL

336+ sR <- initialR

337+ return $ TeePair ([], StepState sL, [], []) ([], StepState sR, [], [])

338+

339+ {-# INLINE consume #-}

340+ consume buf inp1 inp2 stp st y = do

341+ let (x, inp11, inp21) =

342+ case inp1 of

343+ [] -> (y, [], [])

344+ z : [] -> (z, reverse (x:inp2), [])

345+ z : zs -> (z, zs, x:inp2)

346+ r <- stp st x

347+ let buf1 = x:buf

348+ return (buf1, r, inp11, inp21)

349+

350+ -- consume one input item and return the next state of the fold

351+ {-# INLINE useStream #-}

352+ useStream buf inp1 inp2 stp st y = do

353+ (buf1, r, inp11, inp21) <- consume buf inp1 inp2 stp st y

354+ case r of

355+ Yield n s ->

356+ let state = (Prelude.take n buf1, StepState s, inp11, inp21)

357+ in assert (n <= length buf1) (return (state, Yld n))

358+ Stop n b ->

359+ let state = (Prelude.take n buf1, StepResult b, inp11, inp21)

360+ in assert (n <= length buf1) (return (state, Stp n))

361+ -- Skip 0 s -> (buf1, Right s, inp11, inp21)

362+ Skip n s ->

363+ let (src0, buf2) = splitAt n buf1

364+ src = Prelude.reverse src0

365+ state = (buf2, StepState s, src ++ inp11, inp21)

366+ in assert (n <= length buf1) (return (state, Skp))

367+ Error err -> return (undefined, Err err)

368+

369+ -- XXX Even if a parse finished earlier it may not be shortest if the other

370+ -- parser finishes later but returns a lot of unconsumed input. Our current

371+ -- criterion of shortest is whichever parse decided to stop earlier.

372+ {-# INLINE_LATE step #-}

373+ step (TeePair (bufL, StepState sL, inpL1, inpL2)

374+ (bufR, StepState sR, inpR1, inpR2)) x = do

375+ (l,stL) <- useStream bufL inpL1 inpL2 stepL sL x

376+ (r,stR) <- useStream bufR inpR1 inpR2 stepR sR x

377+ let next = TeePair l r

378+ return $ case (stL,stR) of

379+ (Stp n1, _) ->

380+ let (_, StepResult rL, _, _) = l

381+ in Stop n1 rL

382+ (_, Stp n2) ->

383+ let (_, StepResult rR, _, _) = r

384+ in Stop n2 rR

385+ (Yld n1, Yld n2) -> Yield (min n1 n2) next

386+ (Err err, _) -> Error err

387+ (_, Err err) -> Error err

388+ _ -> Skip 0 next

389+

390+ step _ _ = undefined

391+

392+ {-# INLINE_LATE extract #-}

393+ extract st =

394+ case st of

395+ TeePair (_, StepState sL, _, _) _ -> extractL sL

396+ _ -> error "unreachable"

397+

398+-- | Longest alternative. Apply both parsers in parallel but choose the result

399+-- from the one which consumed more input i.e. take the longest succeeding

400+-- parse.

401+--

402+-- /Internal/

403+--

404+{-# INLINE longest #-}

405+longest :: MonadCatch m => Parser m x a -> Parser m x a -> Parser m x a

406+longest (Parser stepL initialL extractL) (Parser stepR initialR extractR) =

407+ Parser step initial extract

408+

409+ where

410+

411+ {-# INLINE_LATE initial #-}

412+ initial = do

413+ sL <- initialL

414+ sR <- initialR

415+ return $ TeePair ([], StepState sL, [], []) ([], StepState sR, [], [])

416+

417+ {-# INLINE consume #-}

418+ consume buf inp1 inp2 stp st y = do

419+ let (x, inp11, inp21) =

420+ case inp1 of

421+ [] -> (y, [], [])

422+ z : [] -> (z, reverse (x:inp2), [])

423+ z : zs -> (z, zs, x:inp2)

424+ r <- stp st x

425+ let buf1 = x:buf

426+ return (buf1, r, inp11, inp21)

427+

428+ -- consume one input item and return the next state of the fold

429+ {-# INLINE useStream #-}

430+ useStream buf inp1 inp2 stp st y = do

431+ (buf1, r, inp11, inp21) <- consume buf inp1 inp2 stp st y

432+ case r of

433+ Yield n s ->

434+ let state = (Prelude.take n buf1, StepState s, inp11, inp21)

435+ in assert (n <= length buf1) (return (state, Yld n))

436+ Stop n b ->

437+ let state = (Prelude.take n buf1, StepResult b, inp11, inp21)

438+ in assert (n <= length buf1) (return (state, Stp n))

439+ -- Skip 0 s -> (buf1, Right s, inp11, inp21)

440+ Skip n s ->

441+ let (src0, buf2) = splitAt n buf1

442+ src = Prelude.reverse src0

443+ state = (buf2, StepState s, src ++ inp11, inp21)

444+ in assert (n <= length buf1) (return (state, Skp))

445+ Error err -> return (undefined, Err err)

446+

447+ {-# INLINE_LATE step #-}

448+ step (TeePair (bufL, StepState sL, inpL1, inpL2)

449+ (bufR, StepState sR, inpR1, inpR2)) x = do

450+ (l,stL) <- useStream bufL inpL1 inpL2 stepL sL x

451+ (r,stR) <- useStream bufR inpR1 inpR2 stepR sR x

452+ let next = TeePair l r

453+ return $ case (stL,stR) of

454+ (Yld n1, Yld n2) -> Yield (min n1 n2) next

455+ (Yld n1, Stp n2) -> Yield (min n1 n2) next

456+ (Stp n1, Yld n2) -> Yield (min n1 n2) next

457+ (Stp n1, Stp n2) ->

458+ let (_, StepResult rL, _, _) = l

459+ (_, StepResult rR, _, _) = r

460+ in Stop (max n1 n2) (if n1 >= n2 then rL else rR)

461+ (Err err, _) -> Error err

462+ (_, Err err) -> Error err

463+ _ -> Skip 0 next

464+

465+ -- XXX the parser that finishes last may not be the longest because it may

466+ -- return a lot of unused input which makes it shorter. Our current

467+ -- criterion of deciding longest is based on whoever decides to finish

468+ -- last and not whoever consumed more input.

469+ --

470+ -- To actually know who made more progress we need to keep an account of

471+ -- how many items are unconsumed since the last yield.

472+ --

473+ step (TeePair (bufL, StepState sL, inpL1, inpL2)

474+ r@(_, StepResult _, _, _)) x = do

475+ (l,stL) <- useStream bufL inpL1 inpL2 stepL sL x

476+ let next = TeePair l r

477+ return $ case stL of

478+ Yld n -> Yield n next

479+ Stp n ->

480+ let (_, StepResult rL, _, _) = l

481+ in Stop n rL

482+ Skp -> Skip 0 next

483+ Err err -> Error err

484+

485+ step (TeePair l@(_, StepResult _, _, _)

486+ (bufR, StepState sR, inpR1, inpR2)) x = do

487+ (r, stR) <- useStream bufR inpR1 inpR2 stepR sR x

488+ let next = TeePair l r

489+ return $ case stR of

490+ Yld n -> Yield n next

491+ Stp n ->

492+ let (_, StepResult rR, _, _) = r

493+ in Stop n rR

494+ Skp -> Skip 0 next

495+ Err err -> Error err

496+

497+ step _ _ = undefined

498+

499+ {-# INLINE_LATE extract #-}

500+ extract st =

501+ -- XXX When results are partial we may not be able to precisely compare

502+ -- which parser has made more progress till now. One way to do that is

503+ -- to figure out the actually consumed input up to the last yield.

504+ --

505+ case st of

506+ TeePair (_, StepState sL, _, _) (_, StepState sR, _, _) -> do

507+ r <- try $ extractL sL

508+ case r of

509+ Left (_ :: ParseError) -> extractR sR

510+ Right b -> return b

511+ TeePair (_, StepState sL, _, _) (_, StepResult rR, _, _) -> do

512+ r <- try $ extractL sL

513+ case r of

514+ Left (_ :: ParseError) -> return rR

515+ Right b -> return b

516+ TeePair (_, StepResult rL, _, _) (_, StepState sR, _, _) -> do

517+ r <- try $ extractR sR

518+ case r of

519+ Left (_ :: ParseError) -> return rL

520+ Right b -> return b

521+ TeePair (_, StepResult _, _, _) (_, StepResult _, _, _) ->

522+ error "unreachable"

src/Streamly/Internal/Data/Parser/Types.hs+307−24

@@ -1,4 +1,5 @@

1{-# LANGUAGE ExistentialQuantification #-}

2+{-# LANGUAGE ScopedTypeVariables #-}

3-- |

4-- |

4-- Module : Streamly.Parser.Types

5-- Module : Streamly.Parser.Types

@@ -44,11 +45,27 @@ module Streamly.Internal.Data.Parser.Types

44 (

45 (

45 Step (..)

46 Step (..)

46 , Parser (..)

47 , Parser (..)

48+ , ParseError (..)

49+

50+ , yield

51+ , yieldM

47 , splitWith

52 , splitWith

53+

54+ , die

55+ , dieM

56+ , splitSome

57+ , splitMany

58+ , alt

48 )

59 )

49where

60where

62+import Control.Exception (assert, Exception(..))

63+import Control.Applicative (Alternative(..))

64+import Control.Monad.Catch (MonadCatch, try, throwM, MonadThrow)

65+

51import Fusion.Plugin.Types (Fuse(..))

66import Fusion.Plugin.Types (Fuse(..))

67+import Streamly.Internal.Data.Fold (Fold(..), toList)

68+import Streamly.Internal.Data.Strict (Tuple3'(..))

53-- | The return type of a 'Parser' step.

70-- | The return type of a 'Parser' step.

54--

71--

@@ -58,10 +75,11 @@ import Fusion.Plugin.Types (Fuse(..))

58-- point of no return in a backtracking buffer. The buffer grows or shrinks

75-- point of no return in a backtracking buffer. The buffer grows or shrinks

59-- based on the return values of the parser step execution.

76-- based on the return values of the parser step execution.

60--

77--

61−-- When a parser step is executed it generates a new state of the parse result

78+-- When a parser step is executed it generates a new intermediate state of the

62−-- along with a command to the driver. The command tells the driver whether to

79+-- parse result along with a command to the driver. The command tells the

63−-- keep the input stream for backtracking or drop it, and how much to keep. The

80+-- driver whether to keep the input stream for a potential backtracking later

81+-- on or drop it, and how much to keep. The constructors of 'Step' represent

64−-- constructors of 'Step' represent the commands to the driver.

82+-- the commands to the driver.

65--

83--

66-- /Internal/

84-- /Internal/

67--

85--

@@ -84,31 +102,49 @@ data Step s b =

84 -- point of no return created by @Yield@.

102 -- point of no return created by @Yield@.

103

86 | Stop Int b

104 | Stop Int b

87− -- ^ @Stop offset state@ asks the driver to stop driving the parser because

105+ -- ^ @Stop offset result@ asks the driver to stop driving the parser

88− -- it has reached a fixed point and further input will not change the

106+ -- because it has reached a fixed point and further input will not change

89− -- result. @offset@ is the count of unused elements which includes the

107+ -- the result. @offset@ is the count of unused elements which includes the

90− -- element on which 'Stop' occurred. Once a fold stops, driving it further

108+ -- element on which 'Stop' occurred.

91− -- may produce undefined behavior.

109+ | Error String

110+ -- ^ An error makes the parser backtrack to the last checkpoint and try

111+ -- another alternative.

112

93instance Functor (Step s) where

113instance Functor (Step s) where

94 {-# INLINE fmap #-}

114 {-# INLINE fmap #-}

95 fmap _ (Yield n s) = Yield n s

115 fmap _ (Yield n s) = Yield n s

96 fmap _ (Skip n s) = Skip n s

116 fmap _ (Skip n s) = Skip n s

97 fmap f (Stop n b) = Stop n (f b)

117 fmap f (Stop n b) = Stop n (f b)

118+ fmap _ (Error err) = Error err

119

99−-- | A parsing fold is represented as @Parser step initial extract@. Before we

120+-- | A parser is a fold that can fail and is represented as @Parser step

100−-- drive a parser we call the @initial@ action to retrieve the initial state of

121+-- initial extract@. Before we drive a parser we call the @initial@ action to

122+-- retrieve the initial state of the fold. The parser driver invokes @step@

101−-- the fold. The driver invokes @step@ with the state returned by the previous

123+-- with the state returned by the previous step and the next input element. It

102−-- step and the next input element. It results into a new state and a command

124+-- results into a new state and a command to the driver represented by 'Step'

103−-- to the driver represented by 'Step' type. At any point of time the driver

125+-- type. The driver keeps invoking the step function until it stops or fails.

104−-- can call @extract@ to inspect the result of the fold. It may result in an

126+-- At any point of time the driver can call @extract@ to inspect the result of

105−-- error or an output value.

127+-- the fold. It may result in an error or an output value.

128+--

129+-- /Internal/

106--

130--

107data Parser m a b =

131data Parser m a b =

108 forall s. Parser (s -> a -> m (Step s b)) (m s) (s -> m b)

132 forall s. Parser (s -> a -> m (Step s b)) (m s) (s -> m b)

109

133

110−-- | Maps a function over the output of the fold.

134+-- | This exception is used for two purposes:

135+--

136+-- * When a parser ultimately fails, the user of the parser is intimated via

137+-- this exception.

138+-- * When the "extract" function of a parser needs to throw an error.

111--

139--

140+-- /Internal/

141+--

142+newtype ParseError = ParseError String

143+ deriving Show

144+

145+instance Exception ParseError where

146+ displayException (ParseError err) = err

147+

112instance Functor m => Functor (Parser m a) where

148instance Functor m => Functor (Parser m a) where

113 {-# INLINE fmap #-}

149 {-# INLINE fmap #-}

114 fmap f (Parser step1 initial extract) =

150 fmap f (Parser step1 initial extract) =

@@ -119,11 +155,30 @@ instance Functor m => Functor (Parser m a) where

119 step s b = fmap2 f (step1 s b)

155 step s b = fmap2 f (step1 s b)

120 fmap2 g = fmap (fmap g)

156 fmap2 g = fmap (fmap g)

121

157

158+-- This is the dual of stream "yield".

159+--

160+-- | A parser that always yields a pure value without consuming any input.

161+--

162+-- /Internal/

163+--

122−{-# INLINE wrap #-}

164+{-# INLINE yield #-}

123−wrap :: Monad m => b -> Parser m a b

165+yield :: Monad m => b -> Parser m a b

124−wrap b = Parser (\_ _ -> pure $ Stop 0 b) -- step

166+yield b = Parser (\_ _ -> pure $ Stop 1 b) -- step

125− (pure ()) -- initial

167+ (pure ()) -- initial

126− (\_ -> pure b) -- extract

168+ (\_ -> pure b) -- extract

169+

170+-- This is the dual of stream "yieldM".

171+--

172+-- | A parser that always yields the result of an effectful action without

173+-- consuming any input.

174+--

175+-- /Internal/

176+--

177+{-# INLINE yieldM #-}

178+yieldM :: Monad m => m b -> Parser m a b

179+yieldM b = Parser (\_ _ -> Stop 1 <$> b) -- step

180+ (pure ()) -- initial

181+ (\_ -> b) -- extract

127

182

128-------------------------------------------------------------------------------

183-------------------------------------------------------------------------------

129-- Sequential applicative

184-- Sequential applicative

@@ -132,13 +187,26 @@ wrap b = Parser (\_ _ -> pure $ Stop 0 b) -- step

132{-# ANN type SeqParseState Fuse #-}

187{-# ANN type SeqParseState Fuse #-}

133data SeqParseState sl f sr = SeqParseL sl | SeqParseR f sr

188data SeqParseState sl f sr = SeqParseL sl | SeqParseR f sr

134

189

190+-- Note: this implementation of splitWith is fast because of stream fusion but

191+-- has quadratic time complexity, because each composition adds a new branch

192+-- that each subsequent parse's input element has to go through, therefore, it

193+-- cannot scale to a large number of compositions. After around 100

194+-- compositions the performance starts dipping rapidly beyond a CPS style

195+-- unfused implementation.

196+--

135-- | Sequential application. Apply two parsers sequentially to an input stream.

197-- | Sequential application. Apply two parsers sequentially to an input stream.

136-- The input is provided to the first parser, when it is done the remaining

198-- The input is provided to the first parser, when it is done the remaining

137-- input is provided to the second parser. If both the parsers succeed their

199-- input is provided to the second parser. If both the parsers succeed their

138-- outputs are combined using the supplied function. The operation fails if any

200-- outputs are combined using the supplied function. The operation fails if any

139-- of the parsers fail.

201-- of the parsers fail.

140--

202--

141−-- This undoes an "append" of two streams, it splits the streams.

203+-- This undoes an "append" of two streams, it splits the streams using two

204+-- parsers and zips the results.

205+--

206+-- This implementation is strict in the second argument, therefore, the

207+-- following will fail:

208+--

209+-- >>> S.parse (PR.satisfy (> 0) *> undefined) $ S.fromList [1]

142--

210--

143-- /Internal/

211-- /Internal/

144--

212--

@@ -163,6 +231,7 @@ splitWith func (Parser stepL initialL extractL)

163 Yield _ s -> return $ Skip 0 (SeqParseL s)

231 Yield _ s -> return $ Skip 0 (SeqParseL s)

164 Skip n s -> return $ Skip n (SeqParseL s)

232 Skip n s -> return $ Skip n (SeqParseL s)

165 Stop n b -> Skip n <$> (SeqParseR (func b) <$> initialR)

233 Stop n b -> Skip n <$> (SeqParseR (func b) <$> initialR)

234+ Error err -> return $ Error err

166

235

167 step (SeqParseR f st) a = do

236 step (SeqParseR f st) a = do

168 r <- stepR st a

237 r <- stepR st a

@@ -170,6 +239,7 @@ splitWith func (Parser stepL initialL extractL)

170 Yield n s -> Yield n (SeqParseR f s)

239 Yield n s -> Yield n (SeqParseR f s)

171 Skip n s -> Skip n (SeqParseR f s)

240 Skip n s -> Skip n (SeqParseR f s)

172 Stop n b -> Stop n (f b)

241 Stop n b -> Stop n (f b)

242+ Error err -> Error err

173

243

174 extract (SeqParseR f sR) = fmap f (extractR sR)

244 extract (SeqParseR f sR) = fmap f (extractR sR)

175 extract (SeqParseL sL) = do

245 extract (SeqParseL sL) = do

@@ -181,7 +251,220 @@ splitWith func (Parser stepL initialL extractL)

181-- | 'Applicative' form of 'splitWith'.

251-- | 'Applicative' form of 'splitWith'.

182instance Monad m => Applicative (Parser m a) where

252instance Monad m => Applicative (Parser m a) where

183 {-# INLINE pure #-}

253 {-# INLINE pure #-}

184− pure = wrap

254+ pure = yield

185

255

186 {-# INLINE (<*>) #-}

256 {-# INLINE (<*>) #-}

187 (<*>) = splitWith id

257 (<*>) = splitWith id

258+

259+-------------------------------------------------------------------------------

260+-- Sequential Alternative

261+-------------------------------------------------------------------------------

262+

263+{-# ANN type AltParseState Fuse #-}

264+data AltParseState sl sr = AltParseL Int sl | AltParseR sr

265+

266+-- Note: this implementation of alt is fast because of stream fusion but has

267+-- quadratic time complexity, because each composition adds a new branch that

268+-- each subsequent alternative's input element has to go through, therefore, it

269+-- cannot scale to a large number of compositions

270+--

271+-- | Sequential alternative. Apply the input to the first parser and return the

272+-- result if the parser succeeds. If the first parser fails then backtrack and

273+-- apply the same input to the second parser and return the result.

274+--

275+-- Note: This implementation is not lazy in the second argument. The following

276+-- will fail:

277+--

278+-- >>> S.parse (PR.satisfy (> 0) `PR.alt` undefined) $ S.fromList [1..10]

279+--

280+-- /Internal/

281+--

282+{-# INLINE alt #-}

283+alt :: Monad m => Parser m x a -> Parser m x a -> Parser m x a

284+alt (Parser stepL initialL extractL) (Parser stepR initialR extractR) =

285+ Parser step initial extract

286+

287+ where

288+

289+ initial = AltParseL 0 <$> initialL

290+

291+ -- Once a parser yields at least one value it cannot fail. This

292+ -- restriction helps us make backtracking more efficient, as we do not need

293+ -- to keep the consumed items buffered after a yield. Note that we do not

294+ -- enforce this and if a misbehaving parser does not honor this then we can

295+ -- get unexpected results.

296+ step (AltParseL cnt st) a = do

297+ r <- stepL st a

298+ case r of

299+ Yield n s -> return $ Yield n (AltParseL 0 s)

300+ Skip n s -> do

301+ assert (cnt + 1 - n >= 0) (return ())

302+ return $ Skip n (AltParseL (cnt + 1 - n) s)

303+ Stop n b -> return $ Stop n b

304+ Error _ -> do

305+ rR <- initialR

306+ return $ Skip (cnt + 1) (AltParseR rR)

307+

308+ step (AltParseR st) a = do

309+ r <- stepR st a

310+ return $ case r of

311+ Yield n s -> Yield n (AltParseR s)

312+ Skip n s -> Skip n (AltParseR s)

313+ Stop n b -> Stop n b

314+ Error err -> Error err

315+

316+ extract (AltParseR sR) = extractR sR

317+ extract (AltParseL _ sL) = extractL sL

318+

319+-- | See documentation of 'Streamly.Internal.Data.Parser.many'.

320+--

321+-- /Internal/

322+--

323+{-# INLINE splitMany #-}

324+splitMany :: MonadCatch m => Fold m b c -> Parser m a b -> Parser m a c

325+splitMany (Fold fstep finitial fextract) (Parser step1 initial1 extract1) =

326+ Parser step initial extract

327+

328+ where

329+

330+ initial = do

331+ ps <- initial1 -- parse state

332+ fs <- finitial -- fold state

333+ pure (Tuple3' ps 0 fs)

334+

335+ {-# INLINE step #-}

336+ step (Tuple3' st cnt fs) a = do

337+ r <- step1 st a

338+ let cnt1 = cnt + 1

339+ case r of

340+ Yield _ s -> return $ Skip 0 (Tuple3' s cnt1 fs)

341+ Skip n s -> do

342+ assert (cnt1 - n >= 0) (return ())

343+ return $ Skip n (Tuple3' s (cnt1 - n) fs)

344+ Stop n b -> do

345+ s <- initial1

346+ fs1 <- fstep fs b

347+ -- XXX we need to yield and backtrack here

348+ return $ Skip n (Tuple3' s 0 fs1)

349+ Error _ -> do

350+ xs <- fextract fs

351+ return $ Stop cnt1 xs

352+

353+ -- XXX The "try" may impact performance if this parser is used as a scan

354+ extract (Tuple3' s _ fs) = do

355+ r <- try $ extract1 s

356+ case r of

357+ Left (_ :: ParseError) -> fextract fs

358+ Right b -> fstep fs b >>= fextract

359+

360+-- | See documentation of 'Streamly.Internal.Data.Parser.some'.

361+--

362+-- /Internal/

363+--

364+{-# INLINE splitSome #-}

365+splitSome :: MonadCatch m => Fold m b c -> Parser m a b -> Parser m a c

366+splitSome (Fold fstep finitial fextract) (Parser step1 initial1 extract1) =

367+ Parser step initial extract

368+

369+ where

370+

371+ initial = do

372+ ps <- initial1 -- parse state

373+ fs <- finitial -- fold state

374+ pure (Tuple3' ps 0 (Left fs))

375+

376+ {-# INLINE step #-}

377+ step (Tuple3' st _ (Left fs)) a = do

378+ r <- step1 st a

379+ case r of

380+ Yield _ s -> return $ Skip 0 (Tuple3' s undefined (Left fs))

381+ Skip n s -> return $ Skip n (Tuple3' s undefined (Left fs))

382+ Stop n b -> do

383+ s <- initial1

384+ fs1 <- fstep fs b

385+ -- XXX this is also a yield point, we will never fail beyond

386+ -- this point. If we do not yield then if an error occurs after

387+ -- this then we will backtrack to the previous yield point

388+ -- instead of this point which is wrong.

389+ --

390+ -- so we need a yield with backtrack

391+ return $ Skip n (Tuple3' s 0 (Right fs1))

392+ Error err -> return $ Error err

393+ step (Tuple3' st cnt (Right fs)) a = do

394+ r <- step1 st a

395+ let cnt1 = cnt + 1

396+ case r of

397+ Yield _ s -> return $ Yield 0 (Tuple3' s cnt1 (Right fs))

398+ Skip n s -> do

399+ assert (cnt1 - n >= 0) (return ())

400+ return $ Skip n (Tuple3' s (cnt1 - n) (Right fs))

401+ Stop n b -> do

402+ s <- initial1

403+ fs1 <- fstep fs b

404+ -- XXX we need to yield here but also backtrack

405+ return $ Skip n (Tuple3' s 0 (Right fs1))

406+ Error _ -> Stop cnt1 <$> fextract fs

407+

408+ -- XXX The "try" may impact performance if this parser is used as a scan

409+ extract (Tuple3' s _ (Left fs)) = extract1 s >>= fstep fs >>= fextract

410+ extract (Tuple3' s _ (Right fs)) = do

411+ r <- try $ extract1 s

412+ case r of

413+ Left (_ :: ParseError) -> fextract fs

414+ Right b -> fstep fs b >>= fextract

415+

416+-- This is the dual of "nil".

417+--

418+-- | A parser that always fails with an error message without consuming

419+-- any input.

420+--

421+-- /Internal/

422+--

423+{-# INLINE die #-}

424+die :: MonadThrow m => String -> Parser m a b

425+die err =

426+ Parser (\_ _ -> pure $ Error err) -- step

427+ (pure ()) -- initial

428+ (\_ -> throwM $ ParseError err) -- extract

429+

430+-- This is the dual of "nilM".

431+--

432+-- | A parser that always fails with an effectful error message and without

433+-- consuming any input.

434+--

435+-- /Internal/

436+--

437+{-# INLINE dieM #-}

438+dieM :: MonadThrow m => m String -> Parser m a b

439+dieM err =

440+ Parser (\_ _ -> Error <$> err) -- step

441+ (pure ()) -- initial

442+ (\_ -> err >>= throwM . ParseError) -- extract

443+

444+-- Note: The default implementations of "some" and "many" loop infinitely

445+-- because of the strict pattern match on both the arguments in applicative and

446+-- alternative. With the direct style parser type we cannot use the mutually

447+-- recursive definitions of "some" and "many".

448+--

449+-- Note: With the direct style parser type, the list in "some" and "many" is

450+-- accumulated strictly, it cannot be consumed lazily.

451+

452+-- | 'Alternative' instance using 'alt'.

453+--

454+-- Note: The implementation of '<|>' is not lazy in the second

455+-- argument. The following code will fail:

456+--

457+-- >>> S.parse (PR.satisfy (> 0) `<|>` undefined) $ S.fromList [1..10]

458+--

459+instance MonadCatch m => Alternative (Parser m a) where

460+ {-# INLINE empty #-}

461+ empty = die "empty"

462+

463+ {-# INLINE (<|>) #-}

464+ (<|>) = alt

465+

466+ {-# INLINE many #-}

467+ many = splitMany toList

468+

469+ {-# INLINE some #-}

470+ some = splitSome toList

src/Streamly/Internal/Data/Stream/Prelude.hs+2−1

@@ -68,6 +68,7 @@ module Streamly.Internal.Data.Stream.Prelude

68 )

69where

71+import Control.Monad.Catch (MonadThrow)

71import Control.Monad.Trans (MonadTrans(..))

72import Control.Monad.Trans (MonadTrans(..))

72import Prelude hiding (foldr, minimum, maximum)

73import Prelude hiding (foldr, minimum, maximum)

73import qualified Prelude

74import qualified Prelude

@@ -161,7 +162,7 @@ foldlMx' step begin done m = S.foldlMx' step begin done $ toStreamS m

161

162

162{-# INLINE parselMx' #-}

163{-# INLINE parselMx' #-}

163parselMx'

164parselMx'

164− :: (IsStream t, Monad m)

165+ :: (IsStream t, MonadThrow m)

165 => (s -> a -> m (Step s b))

166 => (s -> a -> m (Step s b))

166 -> m s

167 -> m s

167 -> (s -> m b)

168 -> (s -> m b)

src/Streamly/Internal/Data/Stream/StreamD.hs+10−6

@@ -325,7 +325,7 @@ import Control.Concurrent (killThread, myThreadId, takeMVar, threadDelay)

325import Control.Exception

326 (assert, Exception, SomeException, AsyncException, fromException, mask_)

327import Control.Monad (void, when, forever)

328−import Control.Monad.Catch (MonadCatch, throwM)

328+import Control.Monad.Catch (MonadCatch, MonadThrow, throwM)

329import Control.Monad.IO.Class (MonadIO(..))

330import Control.Monad.Reader (ReaderT)

331import Control.Monad.State.Strict (StateT)

@@ -362,7 +362,7 @@ import Streamly.Internal.Data.Time.Units

362import Streamly.Internal.Data.Atomics (atomicModifyIORefCAS_)

363import Streamly.Internal.Memory.Array.Types (Array(..))

364import Streamly.Internal.Data.Fold.Types (Fold(..))

365−import Streamly.Internal.Data.Parser.Types (Parser(..))

365+import Streamly.Internal.Data.Parser.Types (Parser(..), ParseError(..))

366import Streamly.Internal.Data.Pipe.Types (Pipe(..), PipeState(..))

367import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime)

368import Streamly.Internal.Data.Time.Units

@@ -971,7 +971,7 @@ splitAt n ls

971-- | Run a 'Parse' over a stream.

972{-# INLINE_NORMAL parselMx' #-}

973parselMx'

974− :: Monad m

974+ :: MonadThrow m

975 => (s -> a -> m (PR.Step s b))

976 -> m s

977 -> (s -> m b)

@@ -1003,6 +1003,7 @@ parselMx' pstep initial extract (Stream step state) = do

1003 src = Prelude.reverse src0

1004 gobuf SPEC s buf1 src pst1

1005 PR.Stop _ b -> return b

1006+ PR.Error err -> throwM $ ParseError err

1006 Skip s -> go SPEC s buf pst

1007 Skip s -> go SPEC s buf pst

1007 Stop -> extract pst

1008 Stop -> extract pst

1008

1009

@@ -1021,6 +1022,7 @@ parselMx' pstep initial extract (Stream step state) = do

1021 src = Prelude.reverse src0 ++ xs

1022 src = Prelude.reverse src0 ++ xs

1022 gobuf SPEC s buf1 src pst1

1023 gobuf SPEC s buf1 src pst1

1023 PR.Stop _ b -> return b

1024 PR.Stop _ b -> return b

1025+ PR.Error err -> throwM $ ParseError err

1024

1026

1025------------------------------------------------------------------------------

1027------------------------------------------------------------------------------

1026-- Repeated parsing

1028-- Repeated parsing

@@ -1036,7 +1038,7 @@ data ParseChunksState x inpBuf st pst =

1036

1038

1037{-# INLINE_NORMAL splitParse #-}

1039{-# INLINE_NORMAL splitParse #-}

1038splitParse

1040splitParse

1039− :: Monad m

1041+ :: MonadThrow m

1040 => Parser m a b

1042 => Parser m a b

1041 -> Stream m a

1043 -> Stream m a

1042 -> Stream m b

1044 -> Stream m b

@@ -1076,12 +1078,13 @@ splitParse (Parser pstep initial extract) (Stream step state) =

1076 let (src0, buf1) = splitAt n (x:buf)

1078 let (src0, buf1) = splitAt n (x:buf)

1077 src = Prelude.reverse src0

1079 src = Prelude.reverse src0

1078 return $ Skip $ ParseChunksBuf src s buf1 pst1

1080 return $ Skip $ ParseChunksBuf src s buf1 pst1

1079− -- XXX Halt 0 common case?

1081+ -- XXX Specialize for Stop 0 common case?

1080 PR.Stop n b -> do

1082 PR.Stop n b -> do

1081 assert (n <= length (x:buf)) (return ())

1083 assert (n <= length (x:buf)) (return ())

1082 let src = Prelude.reverse (Prelude.take n (x:buf))

1084 let src = Prelude.reverse (Prelude.take n (x:buf))

1083 return $ Skip $

1085 return $ Skip $

1084 ParseChunksYield b (ParseChunksInit src s)

1086 ParseChunksYield b (ParseChunksInit src s)

1087+ PR.Error err -> throwM $ ParseError err

1085 Skip s -> return $ Skip $ ParseChunksStream s buf pst

1088 Skip s -> return $ Skip $ ParseChunksStream s buf pst

1086 Stop -> do

1089 Stop -> do

1087 b <- extract pst

1090 b <- extract pst

@@ -1108,11 +1111,12 @@ splitParse (Parser pstep initial extract) (Stream step state) =

1108 let (src0, buf1) = splitAt n (x:buf)

1111 let (src0, buf1) = splitAt n (x:buf)

1109 src = Prelude.reverse src0 ++ xs

1112 src = Prelude.reverse src0 ++ xs

1110 return $ Skip $ ParseChunksBuf src s buf1 pst1

1113 return $ Skip $ ParseChunksBuf src s buf1 pst1

1111− -- XXX have 0 case

1114+ -- XXX Specialize for Stop 0 common case?

1112 PR.Stop n b -> do

1115 PR.Stop n b -> do

1113 assert (n <= length (x:buf)) (return ())

1116 assert (n <= length (x:buf)) (return ())

1114 let src = Prelude.reverse (Prelude.take n (x:buf)) ++ xs

1117 let src = Prelude.reverse (Prelude.take n (x:buf)) ++ xs

1115 return $ Skip $ ParseChunksYield b (ParseChunksInit src s)

1118 return $ Skip $ ParseChunksYield b (ParseChunksInit src s)

1119+ PR.Error err -> throwM $ ParseError err

1116

1120

1117 stepOuter _ (ParseChunksYield a next) = return $ Yield a next

1121 stepOuter _ (ParseChunksYield a next) = return $ Yield a next

1118

1122

src/Streamly/Internal/Prelude.hs+3−3

@@ -511,7 +511,7 @@ where

511import Control.Concurrent (threadDelay)

512import Control.Exception (Exception, assert)

513import Control.Monad (void)

514−import Control.Monad.Catch (MonadCatch)

514+import Control.Monad.Catch (MonadCatch, MonadThrow)

515import Control.Monad.IO.Class (MonadIO(..))

516import Control.Monad.Reader (ReaderT)

517import Control.Monad.State.Strict (StateT)

@@ -1202,7 +1202,7 @@ runSink = fold . toFold

1202-- /Internal/

1203--

1204{-# INLINE parse #-}

1205−parse :: Monad m => Parser m a b -> SerialT m a -> m b

1205+parse :: MonadThrow m => Parser m a b -> SerialT m a -> m b

1206parse (Parser step initial extract) = P.parselMx' step initial extract

1207

1208------------------------------------------------------------------------------

@@ -3128,7 +3128,7 @@ concatMapTreeYieldLeavesWith combine f = concatMapLoopWith combine f yield

3128--

3129{-# INLINE splitParse #-}

3130splitParse

3131− :: (IsStream t, Monad m)

3131+ :: (IsStream t, MonadThrow m)

3132 => Parser m a b

3133 -> t m a

3134 -> t m b