benchmark/Streamly/Benchmark/Data/Parser.hs · streamly

git.iko.soy/streamly

on efecb26 help sign in

streamly/benchmark/Streamly/Benchmark/Data/Parser.hs

886 lines 31 kB history raw

1{-# OPTIONS_GHC -Wno-deprecations #-}

3#undef FUSION_CHECK

4#ifdef FUSION_CHECK

5{-# OPTIONS_GHC -ddump-simpl -ddump-to-file -dsuppress-all #-}

6#endif

8-- |

9-- Module : Streamly.Benchmark.Data.Parser

11--

12-- License : BSD-3-Clause

13-- Maintainer : streamly@composewell.com

15{-# LANGUAGE CPP #-}

16{-# LANGUAGE FlexibleContexts #-}

17{-# LANGUAGE ScopedTypeVariables #-}

18{-# OPTIONS_GHC -Wno-orphans #-}

20module Main

21 (

22 main

23 ) where

25import Control.Applicative ((<|>))

26import Control.DeepSeq (NFData(..))

27import Data.Function ((&))

28import Data.Functor (($>))

29import Data.Monoid (Sum(..))

30import GHC.Magic (inline)

31import GHC.Magic (noinline)

32import System.IO (Handle)

33import System.Random (randomRIO)

34import Streamly.Internal.Data.Fold (Fold(..))

35import Streamly.Internal.Data.Parser

36 (ParseError(..), Parser(..), Initial(..), Step(..))

37import Streamly.Internal.Data.Stream (Stream)

38import Prelude hiding

39 (any, all, take, sequence, sequence_, sequenceA, takeWhile, dropWhile, span)

41import qualified Control.Applicative as AP

42import qualified Data.Foldable as F

43import qualified Data.Traversable as TR

44import qualified Streamly.FileSystem.Handle as Handle

45import qualified Streamly.Internal.Data.Array as Array

46import qualified Streamly.Internal.Data.Fold as Fold

47import qualified Streamly.Internal.Data.Parser as PR

48import qualified Streamly.Data.Stream as Stream

49import qualified Streamly.Internal.Data.Producer as Producer

50import qualified Streamly.Internal.Data.Stream as Stream

52import Gauge hiding (env)

53import Streamly.Benchmark.Common

54import Streamly.Benchmark.Common.Handle

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

57-- Utilities

58-------------------------------------------------------------------------------

60-- XXX these can be moved to the common module

62{-# INLINE sourceUnfoldrM #-}

63sourceUnfoldrM :: Monad m => Int -> Int -> Stream m Int

64sourceUnfoldrM value n = Stream.unfoldrM step n

65 where

66 step cnt =

67 if cnt > n + value

68 then return Nothing

69 else return (Just (cnt, cnt + 1))

71-- | Generates something like this: { { \{ \{ } }. The stream consists of

72-- three parts, the first part is contains a sequence of `{`. The second part

73-- contains a sequence pf escaped values `\{`. The third part contains a

74-- sequence of `}`.

75{-# INLINE sourceEscapedFrames #-}

76sourceEscapedFrames ::

77 Monad m

78 => Int

79 -> Int

80 -> Stream m Char

81sourceEscapedFrames value n = Stream.unfoldrM step n

82 where

84 bs = '\\'

85 cbOpen = '{'

86 cbClose = '}'

87 value1 = value `div` 4

89 step cnt

90 | cnt > 4 * value1 = return Nothing

91 | cnt <= value1 = return $ Just (cbOpen, cnt + 1)

92 | cnt > 3 * value1 = return $ Just (cbClose, cnt + 1)

93 | otherwise =

94 return

95 $ Just

96 $ if (cnt - value1) `mod` 2 == 1

97 then (bs, cnt + 1)

98 else (cbOpen, cnt + 1)

100{-# INLINE benchIOSrc #-}

101benchIOSrc

102 :: NFData b

103 => (Int -> Int -> Stream IO a)

104 -> Int

105 -> String

106 -> (Stream IO a -> IO b)

107 -> Benchmark

108benchIOSrc src value name f =

109 bench name $ nfIO $ randomRIO (1,1) >>= f . src value

110

111-- | Takes a fold method, and uses it with a default source.

112{-# INLINE benchIOSink #-}

113benchIOSink

114 :: NFData b

115 => Int -> String -> (Stream IO Int -> IO b) -> Benchmark

116benchIOSink value name f =

117 bench name $ nfIO $ randomRIO (1,1) >>= f . sourceUnfoldrM value

118

119-------------------------------------------------------------------------------

120-- Parsers

121-------------------------------------------------------------------------------

122

123{-# INLINE takeBetween #-}

124takeBetween :: Monad m => Int -> Stream m a -> m (Either ParseError ())

125takeBetween value = Stream.parse (PR.takeBetween 0 value Fold.drain)

126

127{-# INLINE takeEQ #-}

128takeEQ :: Monad m => Int -> Stream m a -> m (Either ParseError ())

129takeEQ value = Stream.parse (PR.takeEQ value Fold.drain)

130

131{-# INLINE takeGE #-}

132takeGE :: Monad m => Int -> Stream m a -> m (Either ParseError ())

133takeGE value = Stream.parse (PR.takeGE value Fold.drain)

134

135{-# INLINE dropWhile #-}

136dropWhile :: Monad m => Int -> Stream m Int -> m (Either ParseError ())

137dropWhile value = Stream.parse (PR.dropWhile (<= value))

138

139{-# INLINE takeStartBy #-}

140takeStartBy :: Monad m => Int -> Stream m Int -> m (Either ParseError ())

141takeStartBy value stream = do

142 let stream2 = value `Stream.cons` stream

143 Stream.parse (PR.takeStartBy (== value) Fold.drain) stream2

144

145takeFramedByEsc_ :: Monad m => Int -> Stream m Char -> m (Either ParseError ())

146takeFramedByEsc_ _ = Stream.parse parser

147

148 where

149

150 isEsc = (== '\\')

151 isBegin = (== '{')

152 isEnd = (== '}')

153

154 parser = PR.takeFramedByEsc_ isEsc isBegin isEnd Fold.drain

155

156{-# INLINE listEqBy #-}

157listEqBy :: Int -> Stream IO Int -> IO (Either ParseError [Int])

158listEqBy len = Stream.parse (PR.listEqBy (==) [1 .. len])

159

160{-# INLINE streamEqBy #-}

161streamEqBy :: Int -> Stream IO Int -> IO (Either ParseError ())

162streamEqBy len = Stream.parse (PR.streamEqBy (==) (Stream.enumerateFromTo 1 len))

163

164{-# INLINE takeWhile #-}

165takeWhile :: Monad m => Int -> Stream m Int -> m (Either ParseError ())

166takeWhile value = Stream.parse (PR.takeWhile (<= value) Fold.drain)

167

168takeWhileP :: Monad m => Int -> Stream m Int -> m (Either ParseError ())

169takeWhileP value =

170 Stream.parse (PR.takeWhileP (<= value) (PR.takeWhile (<= value - 1) Fold.drain))

171

172{-# INLINE takeP #-}

173takeP :: Monad m => Int -> Stream m a -> m (Either ParseError ())

174takeP value = Stream.parse (PR.takeP value (PR.fromFold Fold.drain))

175

176{-# INLINE groupBy #-}

177groupBy :: Monad m => Stream m Int -> m (Either ParseError ())

178groupBy = Stream.parse (PR.groupBy (<=) Fold.drain)

179

180{-# INLINE groupByRolling #-}

181groupByRolling :: Monad m => Stream m Int -> m (Either ParseError ())

182groupByRolling = Stream.parse (PR.groupByRolling (<=) Fold.drain)

183

184{-# INLINE wordBy #-}

185wordBy :: Monad m => Int -> Stream m Int -> m (Either ParseError ())

186wordBy value = Stream.parse (PR.wordBy (>= value) Fold.drain)

187

188{-# INLINE sepByWords #-}

189sepByWords :: Monad m => Stream m Int -> m (Either ParseError ())

190sepByWords = Stream.parse (wrds even Fold.drain)

191 where

192 wrds p = PR.sepBy (PR.takeWhile (not . p) Fold.drain) (PR.dropWhile p)

193

194{-# INLINE sepByAllWords #-}

195sepByAllWords :: Monad m => Stream m Int -> m (Either ParseError ())

196sepByAllWords = Stream.parse (wrds even Fold.drain)

197 where

198 wrds p = PR.sepByAll (PR.takeWhile (not . p) Fold.drain) (PR.dropWhile p)

199

200-- Returning a list to compare with the sepBy1 in ParserK

201{-# INLINE sepBy1 #-}

202sepBy1 :: Monad m => Stream m Int -> m (Either ParseError [Int])

203sepBy1 xs = do

204 Stream.parse (PR.sepBy1 (PR.satisfy odd) (PR.satisfy even) Fold.toList) xs

205

206{-# INLINE sepByWords1 #-}

207sepByWords1 :: Monad m => Stream m Int -> m (Either ParseError ())

208sepByWords1 = Stream.parse (wrds even Fold.drain)

209 where

210 wrds p = PR.sepBy1 (PR.takeWhile (not . p) Fold.drain) (PR.dropWhile p)

211

212{-# INLINE deintercalate #-}

213deintercalate :: Monad m => Int -> Stream m Int -> m (Either ParseError ())

214deintercalate _ = Stream.parse (partition even)

215

216 where

217

218 partition p =

219 PR.deintercalate

220 (PR.takeWhile (not . p) Fold.sum) (PR.takeWhile p Fold.sum) Fold.drain

221

222{-# INLINE deintercalate1 #-}

223deintercalate1 :: Monad m => Int -> Stream m Int -> m (Either ParseError ())

224deintercalate1 _ = Stream.parse (partition even)

225

226 where

227

228 partition p =

229 PR.deintercalate1

230 (PR.takeWhile (not . p) Fold.sum) (PR.takeWhile p Fold.sum) Fold.drain

231

232{-# INLINE deintercalateAll #-}

233deintercalateAll :: Monad m => Int -> Stream m Int -> m (Either ParseError ())

234deintercalateAll _ = Stream.parse (partition even)

235

236 where

237

238 partition p =

239 PR.deintercalateAll

240 (PR.takeWhile (not . p) Fold.sum) (PR.takeWhile p Fold.sum) Fold.drain

241

242{-# INLINE manyWordByEven #-}

243manyWordByEven :: Monad m => Stream m Int -> m (Either ParseError ())

244manyWordByEven = Stream.parse (PR.many (PR.wordBy even Fold.drain) Fold.drain)

245

246{-# INLINE many #-}

247many :: Monad m => Stream m Int -> m (Either ParseError Int)

248many = Stream.parse (PR.many (PR.satisfy (> 0)) Fold.length)

249

250{-# INLINE manyAlt #-}

251manyAlt :: Monad m => Stream m Int -> m Int

252manyAlt xs = do

253 x <- Stream.parse (AP.many (PR.satisfy (> 0))) xs

254 return $ Prelude.length x

255

256{-# INLINE some #-}

257some :: Monad m => Stream m Int -> m (Either ParseError Int)

258some = Stream.parse (PR.some (PR.satisfy (> 0)) Fold.length)

259

260{-# INLINE someAlt #-}

261someAlt :: Monad m => Stream m Int -> m Int

262someAlt xs = do

263 x <- Stream.parse (AP.some (PR.satisfy (> 0))) xs

264 return $ Prelude.length x

265

266{-# INLINE manyTill #-}

267manyTill :: Monad m => Int -> Stream m Int -> m (Either ParseError Int)

268manyTill value =

269 Stream.parse (PR.manyTill (PR.satisfy (> 0)) (PR.satisfy (== value)) Fold.length)

270

271{-# INLINE splitAp2 #-}

272splitAp2 :: Monad m

273 => Int -> Stream m Int -> m (Either ParseError ((), ()))

274splitAp2 value =

275 Stream.parse

276 ((,)

277 <$> PR.dropWhile (<= (value `div` 2))

278 <*> PR.dropWhile (<= value)

279 )

280

281{-# INLINE splitAp4 #-}

282splitAp4 :: Monad m

283 => Int -> Stream m Int -> m (Either ParseError ())

284splitAp4 value =

285 Stream.parse

286 ( (\() () () () -> ())

287 <$> PR.dropWhile (<= (value * 1 `div` 4))

288 <*> PR.dropWhile (<= (value * 2 `div` 4))

289 <*> PR.dropWhile (<= (value * 3 `div` 4))

290 <*> PR.dropWhile (<= value)

291 )

292

293{-# INLINE splitAp8 #-}

294splitAp8 :: Monad m

295 => Int -> Stream m Int -> m (Either ParseError ())

296splitAp8 value =

297 Stream.parse

298 ( (\() () () () () () () () -> ())

299 <$> PR.dropWhile (<= (value * 1 `div` 8))

300 <*> PR.dropWhile (<= (value * 2 `div` 8))

301 <*> PR.dropWhile (<= (value * 3 `div` 8))

302 <*> PR.dropWhile (<= (value * 4 `div` 8))

303 <*> PR.dropWhile (<= (value * 5 `div` 8))

304 <*> PR.dropWhile (<= (value * 6 `div` 8))

305 <*> PR.dropWhile (<= (value * 7 `div` 8))

306 <*> PR.dropWhile (<= value)

307 )

308

309{-# INLINE splitApBefore #-}

310splitApBefore :: Monad m

311 => Int -> Stream m Int -> m (Either ParseError ())

312splitApBefore value =

313 Stream.parse

314 ( PR.dropWhile (<= (value `div` 2))

315 *> PR.dropWhile (<= value)

316 )

317

318{-# INLINE splitApAfter #-}

319splitApAfter :: Monad m

320 => Int -> Stream m Int -> m (Either ParseError ())

321splitApAfter value =

322 Stream.parse

323 ( PR.dropWhile (<= (value `div` 2))

324 <* PR.dropWhile (<= value)

325 )

326

327{-# INLINE splitWith2 #-}

328splitWith2 :: Monad m

329 => Int -> Stream m Int -> m (Either ParseError ((), ()))

330splitWith2 value =

331 Stream.parse

332 (PR.splitWith (,)

333 (PR.dropWhile (<= (value `div` 2)))

334 (PR.dropWhile (<= value))

335 )

336

337{-# INLINE split_ #-}

338split_ :: Monad m

339 => Int -> Stream m Int -> m (Either ParseError ())

340split_ value =

341 Stream.parse

342 (PR.split_

343 (PR.dropWhile (<= (value `div` 2)))

344 (PR.dropWhile (<= value))

345 )

346

347-- XXX dropWhile with applicative does not fuse

348-- PR.dropWhile (<= (value * 1 `div` 4)) *> PR.die "alt"

349{-# INLINE takeWhileFail #-}

350takeWhileFail :: Monad m => (a -> Bool) -> Fold m a b -> Parser a m b

351takeWhileFail predicate (Fold fstep finitial fextract) =

352 Parser step initial extract

353

354 where

355

356 initial = do

357 res <- finitial

358 return $ case res of

359 Fold.Partial s -> IPartial s

360 Fold.Done b -> IDone b

361

362 step s a =

363 if predicate a

364 then do

365 fres <- fstep s a

366 return

367 $ case fres of

368 Fold.Partial s1 -> Partial 0 s1

369 Fold.Done b -> Done 0 b

370 else return $ Error "fail"

371

372 extract s = fmap (Done 0) (fextract s)

373

374{-# INLINE alt2 #-}

375alt2 :: Monad m

376 => Int -> Stream m Int -> m (Either ParseError ())

377alt2 value =

378 Stream.parse

379 (PR.alt

380 (takeWhileFail (<= (value `div` 2)) Fold.drain)

381 (PR.dropWhile (<= value))

382 )

383

384{-# INLINE alt4 #-}

385alt4 :: Monad m

386 => Int -> Stream m Int -> m (Either ParseError ())

387alt4 value =

388 Stream.parse

389 ( takeWhileFail (<= (value * 1 `div` 4)) Fold.drain

390 <|> takeWhileFail (<= (value * 2 `div` 4)) Fold.drain

391 <|> takeWhileFail (<= (value * 3 `div` 4)) Fold.drain

392 <|> PR.dropWhile (<= value)

393 )

394

395{-# INLINE alt8 #-}

396alt8 :: Monad m

397 => Int -> Stream m Int -> m (Either ParseError ())

398alt8 value =

399 Stream.parse

400 ( takeWhileFail (<= (value * 1 `div` 8)) Fold.drain

401 <|> takeWhileFail (<= (value * 2 `div` 8)) Fold.drain

402 <|> takeWhileFail (<= (value * 3 `div` 8)) Fold.drain

403 <|> takeWhileFail (<= (value * 4 `div` 8)) Fold.drain

404 <|> takeWhileFail (<= (value * 5 `div` 8)) Fold.drain

405 <|> takeWhileFail (<= (value * 6 `div` 8)) Fold.drain

406 <|> takeWhileFail (<= (value * 7 `div` 8)) Fold.drain

407 <|> PR.dropWhile (<= value)

408 )

409

410{-# INLINE alt16 #-}

411alt16 :: Monad m

412 => Int -> Stream m Int -> m (Either ParseError ())

413alt16 value =

414 Stream.parse

415 ( takeWhileFail (<= (value * 1 `div` 16)) Fold.drain

416 <|> takeWhileFail (<= (value * 2 `div` 16)) Fold.drain

417 <|> takeWhileFail (<= (value * 3 `div` 16)) Fold.drain

418 <|> takeWhileFail (<= (value * 4 `div` 16)) Fold.drain

419 <|> takeWhileFail (<= (value * 5 `div` 16)) Fold.drain

420 <|> takeWhileFail (<= (value * 6 `div` 16)) Fold.drain

421 <|> takeWhileFail (<= (value * 8 `div` 16)) Fold.drain

422 <|> takeWhileFail (<= (value * 9 `div` 16)) Fold.drain

423 <|> takeWhileFail (<= (value * 10 `div` 16)) Fold.drain

424 <|> takeWhileFail (<= (value * 11 `div` 16)) Fold.drain

425 <|> takeWhileFail (<= (value * 12 `div` 16)) Fold.drain

426 <|> takeWhileFail (<= (value * 13 `div` 16)) Fold.drain

427 <|> takeWhileFail (<= (value * 14 `div` 16)) Fold.drain

428 <|> takeWhileFail (<= (value * 15 `div` 16)) Fold.drain

429 <|> PR.dropWhile (<= value)

430 )

431

432{-# INLINE altSmall #-}

433altSmall :: Monad m

434 => Int -> Stream m Int -> m ()

435altSmall value =

436 Stream.fold Fold.drain .

437 Stream.parseMany

438 (PR.alt

439 (PR.satisfy (>= value) *> PR.die "alt")

440 (PR.satisfy (<= value))

441 )

442

443{-# INLINE monad #-}

444monad :: Monad m

445 => Int -> Stream m Int -> m (Either ParseError ())

446monad value =

447 Stream.parse

448 $ do

449 PR.dropWhile (<= (value `div` 2))

450 PR.dropWhile (<= value)

451

452{-# INLINE monad4 #-}

453monad4 :: Monad m

454 => Int -> Stream m Int -> m (Either ParseError ())

455monad4 value =

456 Stream.parse $ do

457 PR.dropWhile (<= (value `div` 4))

458 PR.dropWhile (<= (value `div` 2))

459 PR.dropWhile (<= (value * 3 `div` 4))

460 PR.dropWhile (<= value)

461

462{-# INLINE monad8 #-}

463monad8 :: Monad m

464 => Int -> Stream m Int -> m (Either ParseError ())

465monad8 value =

466 Stream.parse $ do

467 PR.dropWhile (<= (value * 1 `div` 8))

468 PR.dropWhile (<= (value * 2 `div` 8))

469 PR.dropWhile (<= (value * 3 `div` 8))

470 PR.dropWhile (<= (value * 4 `div` 8))

471 PR.dropWhile (<= (value * 5 `div` 8))

472 PR.dropWhile (<= (value * 6 `div` 8))

473 PR.dropWhile (<= (value * 7 `div` 8))

474 PR.dropWhile (<= value)

475

476{-# INLINE monad16 #-}

477monad16 :: Monad m

478 => Int -> Stream m Int -> m (Either ParseError ())

479monad16 value =

480 Stream.parse $ do

481 PR.dropWhile (<= (value * 1 `div` 16))

482 PR.dropWhile (<= (value * 2 `div` 16))

483 PR.dropWhile (<= (value * 3 `div` 16))

484 PR.dropWhile (<= (value * 4 `div` 16))

485 PR.dropWhile (<= (value * 5 `div` 16))

486 PR.dropWhile (<= (value * 6 `div` 16))

487 PR.dropWhile (<= (value * 7 `div` 16))

488 PR.dropWhile (<= (value * 8 `div` 16))

489 PR.dropWhile (<= (value * 9 `div` 16))

490 PR.dropWhile (<= (value * 10 `div` 16))

491 PR.dropWhile (<= (value * 11 `div` 16))

492 PR.dropWhile (<= (value * 12 `div` 16))

493 PR.dropWhile (<= (value * 13 `div` 16))

494 PR.dropWhile (<= (value * 14 `div` 16))

495 PR.dropWhile (<= (value * 15 `div` 16))

496 PR.dropWhile (<= value)

497

498{-# INLINE takeEndBy_ #-}

499takeEndBy_ :: Monad m

500 => Int -> Stream m Int -> m (Either ParseError ())

501takeEndBy_ value = Stream.parse (PR.takeEndBy_ (>= value) (PR.fromFold Fold.drain))

502

503{-

504{-# INLINE teeAllAny #-}

505teeAllAny :: Monad m

506 => Int -> Stream m Int -> m ((), ())

507teeAllAny value =

508 Stream.parse

509 (PR.teeWith (,)

510 (PR.dropWhile (<= value))

511 (PR.dropWhile (<= value))

512 )

513

514{-# INLINE teeFstAllAny #-}

515teeFstAllAny :: Monad m

516 => Int -> Stream m Int -> m ((), ())

517teeFstAllAny value =

518 Stream.parse

519 (PR.teeWithFst (,)

520 (PR.dropWhile (<= value))

521 (PR.dropWhile (<= value))

522 )

523

524{-# INLINE shortestAllAny #-}

525shortestAllAny :: Monad m

526 => Int -> Stream m Int -> m (Either ParseError ())

527shortestAllAny value =

528 Stream.parse

529 (PR.shortest

530 (PR.dropWhile (<= value))

531 (PR.dropWhile (<= value))

532 )

533

534{-# INLINE longestAllAny #-}

535longestAllAny :: Monad m

536 => Int -> Stream m Int -> m (Either ParseError ())

537longestAllAny value =

538 Stream.parse

539 (PR.longest

540 (PR.dropWhile (<= value))

541 (PR.dropWhile (<= value))

542 )

543-}

544

545-------------------------------------------------------------------------------

546-- Spanning

547-------------------------------------------------------------------------------

548

549{-# INLINE span #-}

550span :: Monad m => Int -> Stream m Int -> m (Either ParseError ((), ()))

551span value = Stream.parse (PR.span (<= (value `div` 2)) Fold.drain Fold.drain)

552

553{-# INLINE spanBy #-}

554spanBy :: Monad m => Int -> Stream m Int -> m (Either ParseError ((), ()))

555spanBy value =

556 Stream.parse (PR.spanBy (\_ i -> i <= (value `div` 2)) Fold.drain Fold.drain)

557

558{-# INLINE spanByRolling #-}

559spanByRolling :: Monad m => Int -> Stream m Int -> m (Either ParseError ((), ()))

560spanByRolling value =

561 Stream.parse (PR.spanByRolling (\_ i -> i <= value `div` 2) Fold.drain Fold.drain)

562

563parseManyChunksOfSum :: Int -> Handle -> IO Int

564parseManyChunksOfSum n inh =

565 Stream.fold Fold.length

566 $ Stream.parseMany

567 (PR.fromFold $ Fold.take n Fold.sum)

568 (Stream.unfold Handle.reader inh)

569

570-------------------------------------------------------------------------------

571-- Parsers in which -fspec-constr-recursive=16 is problematic

572-------------------------------------------------------------------------------

573

574-- XXX -fspec-constr-recursive=16 makes GHC go beserk when compiling these.

575-- We need to fix GHC so that we can have better control over that option or do

576-- not have to rely on it.

577--

578{-# INLINE lookAhead #-}

579lookAhead :: Monad m => Int -> Stream m Int -> m (Either ParseError ())

580lookAhead value =

581 Stream.parse (PR.lookAhead (PR.takeWhile (<= value) Fold.drain) $> ())

582

583-- XXX The timing of this increased 3x after the stepify extract changes.

584{-# INLINE sequenceA_ #-}

585sequenceA_ :: Monad m => Int -> Stream m Int -> m (Either ParseError ())

586sequenceA_ value =

587 Stream.parse (F.sequenceA_ $ replicate value (PR.satisfy (> 0)))

588

589-- quadratic complexity

590{-# INLINE sequenceA #-}

591sequenceA :: Monad m => Int -> Stream m Int -> m Int

592sequenceA value xs = do

593 x <- Stream.parse (TR.sequenceA (replicate value (PR.satisfy (> 0)))) xs

594 return $ length x

595

596-- quadratic complexity

597{-# INLINE sequence #-}

598sequence :: Monad m => Int -> Stream m Int -> m Int

599sequence value xs = do

600 x <- Stream.parse (TR.sequence (replicate value (PR.satisfy (> 0)))) xs

601 return $ length x

602

603{-# INLINE sequence_ #-}

604sequence_ :: Monad m => Int -> Stream m Int -> m (Either ParseError ())

605sequence_ value xs =

606 Stream.parse (foldr f (return ()) (replicate value (PR.takeBetween 0 1 Fold.drain))) xs

607

608 where

609

610 {-# INLINE f #-}

611 f m k = m >>= (\_ -> k)

612

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

614-- quadratic performance complexity.

615--

616{-# INLINE choiceAsum #-}

617choiceAsum :: Monad m => Int -> Stream m Int -> m (Either ParseError Int)

618choiceAsum value =

619 Stream.parse (F.asum (replicate value (PR.satisfy (< 0)))

620 AP.<|> PR.satisfy (> 0))

621

622{-

623{-# INLINE choice #-}

624choice :: Monad m => Int -> Stream m Int -> m (Either ParseError Int)

625choice value =

626 Stream.parse

627 (PR.choice (replicate value (PR.satisfy (< 0))) AP.<|> PR.satisfy (> 0))

628-}

629

630-------------------------------------------------------------------------------

631-- Parsing with unfolds

632-------------------------------------------------------------------------------

633

634{-# INLINE parseManyUnfoldArrays #-}

635parseManyUnfoldArrays :: Int -> [Array.Array Int] -> IO ()

636parseManyUnfoldArrays count arrays = do

637 let src = Producer.source (Just (Producer.OuterLoop arrays))

638 let parser = PR.fromFold (Fold.take count Fold.drain)

639 let readSrc =

640 Producer.producer

641 $ Producer.concat Producer.fromList Array.producer

642 let streamParser =

643 Producer.simplify (Producer.parseMany parser readSrc)

644 Stream.fold Fold.drain $ Stream.unfold streamParser src

645

646-------------------------------------------------------------------------------

647-- Stream transformation

648-------------------------------------------------------------------------------

649

650{-# INLINE parseMany #-}

651parseMany :: Monad m => Int -> Stream m Int -> m ()

652parseMany n =

653 Stream.fold Fold.drain

654 . fmap getSum

655 . Stream.catRights . Stream.parseMany (PR.fromFold $ Fold.take n Fold.mconcat)

656 . fmap Sum

657

658{-# INLINE parseManyGroupBy #-}

659parseManyGroupBy :: Monad m => (Int -> Int -> Bool) -> Stream m Int -> m ()

660parseManyGroupBy cmp =

661 Stream.fold Fold.drain . Stream.parseMany (PR.groupBy cmp Fold.drain)

662

663{-# INLINE parseManyGroupsRolling #-}

664parseManyGroupsRolling :: Monad m => Bool -> Stream m Int -> m ()

665parseManyGroupsRolling b =

666 Stream.fold Fold.drain

667 . Stream.parseMany (PR.groupByRolling (\_ _ -> b) Fold.drain)

668

669{-# INLINE parseManyGroupsRollingEither #-}

670parseManyGroupsRollingEither :: Monad m =>

671 (Int -> Int -> Bool) -> Int -> m ()

672parseManyGroupsRollingEither cmp value = do

673 sourceUnfoldrM value 1

674 & Stream.parseMany (PR.groupByRollingEither cmp Fold.drain Fold.drain)

675 & Stream.fold Fold.drain

676

677{-# INLINE parseManyGroupsRollingEitherAlt #-}

678parseManyGroupsRollingEitherAlt :: Monad m =>

679 (Int -> Int -> Bool) -> Int -> m ()

680parseManyGroupsRollingEitherAlt cmp value = do

681 sourceUnfoldrM value 1

682 -- Make the input unsorted.

683 & fmap (\x -> if even x then x + 2 else x)

684 & Stream.parseMany (PR.groupByRollingEither cmp Fold.drain Fold.drain)

685 & Stream.fold Fold.drain

686

687{-# INLINE parseIterate #-}

688parseIterate :: Monad m => Int -> Stream m Int -> m ()

689parseIterate n =

690 Stream.fold Fold.drain

691 . fmap getSum

692 . Stream.catRights

693 . Stream.parseIterate

694 (PR.fromFold . Fold.take n . Fold.sconcat)

695 (Sum 0)

696 . fmap Sum

697

698{-# INLINE concatSequence #-}

699concatSequence :: Monad m => Stream m Int -> m (Either ParseError ())

700concatSequence =

701 Stream.parse $ PR.sequence (Stream.repeat PR.one) Fold.drain

702

703-------------------------------------------------------------------------------

704-- Benchmarks

705-------------------------------------------------------------------------------

706

707moduleName :: String

708moduleName = "Data.Parser"

709

710instance NFData ParseError where

711 {-# INLINE rnf #-}

712 rnf (ParseError x) = rnf x

713

714o_1_space_serial :: Int -> [Benchmark]

715o_1_space_serial value =

716 [ benchIOSink value "takeBetween" $ takeBetween value

717 , benchIOSink value "takeEQ" $ takeEQ value

718 , benchIOSink value "takeGE" $ takeGE value

719 , benchIOSink value "takeWhile" $ takeWhile value

720 , benchIOSink value "takeWhileP" $ takeWhileP value

721 , benchIOSink value "takeP" $ takeP value

722 , benchIOSink value "dropWhile" $ dropWhile value

723 , benchIOSink value "takeStartBy" $ takeStartBy value

724 , benchIOSink value "takeEndBy_" $ takeEndBy_ value

725 , benchIOSink value "groupBy" $ groupBy

726 , benchIOSink value "groupByRolling" $ groupByRolling

727 , benchIOSink value "wordBy" $ wordBy value

728 , benchIOSink value "sepBy (words)" sepByWords

729 , benchIOSink value "sepByAll (words)" sepByAllWords

730 , benchIOSink value "sepBy1 (words)" sepByWords1

731 , benchIOSink value "deintercalate" $ deintercalate value

732 , benchIOSink value "deintercalate1" $ deintercalate1 value

733 , benchIOSink value "deintercalateAll" $ deintercalateAll value

734 -- Applicative and Monad

735 , benchIOSink value "splitAp2" $ splitAp2 value

736 , benchIOSink value "splitAp4" $ splitAp4 value

737 , benchIOSink value "splitAp8" $ splitAp8 value

738 , benchIOSink value "splitApBefore" $ splitApBefore value

739 , benchIOSink value "splitApAfter" $ splitApAfter value

740 , benchIOSink value "splitWith2" $ splitWith2 value

741 , benchIOSink value "span" $ span value

742 , benchIOSink value "spanBy" $ spanBy value

743 , benchIOSink value "spanByRolling" $ spanByRolling value

744 , benchIOSink value "monad2" $ monad value

745 , benchIOSink value "monad4" $ monad4 value

746 , benchIOSink value "monad8" $ monad8 value

747 -- Alternative

748 , benchIOSink value "alt2parseMany" $ altSmall value

749 , benchIOSink value "alt2" $ alt2 value

750 , benchIOSink value "alt4" $ alt4 value

751 , benchIOSink value "alt8" $ alt8 value

752 , benchIOSink value "alt16" $ alt16 value

753 , benchIOSink value "many" many

754 , benchIOSink value "many (wordBy even)" $ manyWordByEven

755 , benchIOSink value "some" some

756 , benchIOSink value "manyTill" $ manyTill value

757 , benchIOSink value "parseMany" $ parseMany value

758 , benchIOSink value "parseMany (take 1)" (parseMany 1)

759 , benchIOSink value "parseMany (take all)" (parseMany value)

760 , benchIOSink value "parseMany (groupBy (<))" (parseManyGroupBy (<))

761 , benchIOSink value "parseMany (groupBy (==))" (parseManyGroupBy (==))

762 , benchIOSink value "parseMany groupRollingBy (bound groups)"

763 $ parseManyGroupsRolling False

764 , benchIOSink value "parseMany groupRollingBy (1 group)"

765 $ parseManyGroupsRolling True

766 , bench "parseMany groupRollingByEither (Left)"

767 $ nfIO $ parseManyGroupsRollingEitherLeft

768 , bench "parseMany groupRollingByEither (Right)"

769 $ nfIO $ parseManyGroupsRollingEitherRight

770 , bench "parseMany groupRollingByEither (Alternating)"

771 $ nfIO $ parseManyGroupsRollingEitherAlt1

772 , benchIOSink value "parseIterate (take 1)" (parseIterate 1)

773 , benchIOSink value "parseIterate (take all)" (parseIterate value)

774 , benchIOSink value "concatSequence" concatSequence

775 {-

776 , benchIOSink value "tee" $ teeAllAny value

777 , benchIOSink value "teeFst" $ teeFstAllAny value

778 , benchIOSink value "shortest" $ shortestAllAny value

779 , benchIOSink value "longest" $ longestAllAny value

780 -}

781 , benchIOSink value "streamEqBy" (streamEqBy value)

782 ]

783

784 where

785

786 {-# NOINLINE parseManyGroupsRollingEitherLeft #-}

787 parseManyGroupsRollingEitherLeft = parseManyGroupsRollingEither (<) value

788

789 {-# NOINLINE parseManyGroupsRollingEitherRight #-}

790 parseManyGroupsRollingEitherRight = parseManyGroupsRollingEither (>) value

791

792 {-# NOINLINE parseManyGroupsRollingEitherAlt1 #-}

793 parseManyGroupsRollingEitherAlt1 =

794 parseManyGroupsRollingEitherAlt (>) value

795

796o_1_space_filesystem :: BenchEnv -> [Benchmark]

797o_1_space_filesystem env =

798 [ mkBench ("S.parseMany (Fold.take " ++ show (bigSize env) ++ " Fold.sum)") env

799 $ \inh _ -> noinline parseManyChunksOfSum (bigSize env) inh

800 , mkBench "S.parseMany (Fold.take 1 Fold.sum)" env

801 $ \inh _ -> inline parseManyChunksOfSum 1 inh

802 ]

803

804o_1_space_serial_unfold :: Int -> [Array.Array Int] -> [Benchmark]

805o_1_space_serial_unfold bound arrays =

806 [ bench "parseMany/Unfold/1000 arrays/take all"

807 $ nfIO $ parseManyUnfoldArrays bound arrays

808 , bench "parseMany/Unfold/1000 arrays/take 1"

809 $ nfIO $ parseManyUnfoldArrays 1 arrays

810 ]

811

812o_n_heap_serial :: Int -> [Benchmark]

813o_n_heap_serial value =

814 [

815 -- lookahead benchmark holds the entire input till end

816 benchIOSink value "lookAhead" $ lookAhead value

817

818 -- o-n-heap because of backtracking

819 , benchIOSrc sourceEscapedFrames value "takeFramedByEsc_"

820 $ takeFramedByEsc_ value

821

822 -- non-linear time complexity (parserD)

823 , benchIOSink value "split_" $ split_ value

824 -- XXX Takes lot of space when run on a long stream, why?

825 , benchIOSink value "monad16" $ monad16 value

826

827 -- These show non-linear time complexity.

828 -- They accumulate the results in a list.

829 , benchIOSink value "sepBy1" sepBy1

830 , benchIOSink value "manyAlt" manyAlt

831 , benchIOSink value "someAlt" someAlt

832 , benchIOSink value "listEqBy" (listEqBy value)

833 ]

834

835-- accumulate results in a list in IO

836o_n_space_serial :: Int -> [Benchmark]

837o_n_space_serial value =

838 [ benchIOSink value "sequenceA/100" $ sequenceA (value `div` 100)

839 , benchIOSink value "sequenceA_/100" $ sequenceA_ (value `div` 100)

840 , benchIOSink value "sequence/100" $ sequence (value `div` 100)

841 , benchIOSink value "sequence_/100" $ sequence_ (value `div` 100)

842 , benchIOSink value "choice (asum)/100" $ choiceAsum (value `div` 100)

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

844 ]

845

846-------------------------------------------------------------------------------

847-- Driver

848-------------------------------------------------------------------------------

849

850main :: IO ()

851main = do

852#ifndef FUSION_CHECK

853 env <- mkHandleBenchEnv

854 runWithCLIOptsEnv defaultStreamSize alloc (allBenchmarks env)

855

856 where

857

858 alloc value = Stream.fold Fold.toList $ Stream.chunksOf 100 $ sourceUnfoldrM value 0

859

860 allBenchmarks env arrays value =

861 [ bgroup (o_1_space_prefix moduleName) (o_1_space_serial value)

862 , bgroup

863 (o_1_space_prefix moduleName ++ "/filesystem")

864 (o_1_space_filesystem env)

865 , bgroup (o_1_space_prefix moduleName)

866 (o_1_space_serial_unfold value arrays)

867 , bgroup (o_n_heap_prefix moduleName) (o_n_heap_serial value)

868 , bgroup (o_n_space_prefix moduleName) (o_n_space_serial value)

869 ]

870#else

871 -- Enable FUSION_CHECK macro at the beginning of the file

872 -- Enable one benchmark below, and run the benchmark

873 -- Check the .dump-simpl output

874 let value = 100000

875 -- let input = sourceUnfoldrM value 1

876 -- manyTill value input

877 -- deintercalate value input

878 -- deintercalate1 value input

879 -- deintercalateAll value input

880 -- sepByWords input

881 -- sepByAllWords input

882 -- sepBy1 input

883 -- sepByWords1 input

884 takeFramedByEsc_ value (sourceEscapedFrames value 1)

885 return ()

886#endif