9d68f58 · streamly · git.iko.soy

git.iko.soy/streamly

on master help sign in

Implement concatSequence for parser

9d68f58Ishan Bhanuka4 years ago

benchmark/Streamly/Benchmark/Data/Parser.hs+5

compare with master

unifiedsplit

@@ -413,6 +413,10 @@ parseBreak s = do

413 Left (_ :: SomeException) -> return ()

414 Right (_, s1) -> parseBreak s1

415

416+{-# INLINE concatSequence #-}

417+concatSequence :: MonadCatch m => SerialT m Int -> m ()

418+concatSequence = IP.parse $ PR.concatSequence FL.drain $ S.repeat PR.one

419+

416-------------------------------------------------------------------------------

420-------------------------------------------------------------------------------

417-- Benchmarks

421-- Benchmarks

418-------------------------------------------------------------------------------

422-------------------------------------------------------------------------------

@@ -455,6 +459,7 @@ o_1_space_serial value =

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

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

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

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

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

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

462+ , benchIOSink value "concatSequence" concatSequence

458 ]

463 ]

459

464

460o_1_space_filesystem :: BenchEnv -> [Benchmark]

465o_1_space_filesystem :: BenchEnv -> [Benchmark]

benchmark/Streamly/Benchmark/Data/Parser/ParserD.hs+6

@@ -32,6 +32,7 @@ import qualified Streamly.Internal.Data.Parser.ParserD as PR

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

33import qualified Streamly.Internal.Data.Producer.Source as Source

34import qualified Streamly.Internal.Data.Stream.IsStream as IP

35+import qualified Streamly.Internal.Data.Stream.StreamD as D

36import Gauge

37import Gauge

37import Streamly.Prelude (SerialT, MonadAsync, IsStream)

38import Streamly.Prelude (SerialT, MonadAsync, IsStream)

@@ -196,6 +197,10 @@ longestAllAny value =

196 (drainWhile (<= value))

197 (drainWhile (<= value))

197 )

198 )

198

199

200+{-# INLINE sequenceParser #-}

201+sequenceParser :: MonadCatch m => SerialT m Int -> m ()

202+sequenceParser = IP.parseD (PR.sequence FL.drain (D.repeat (PR.satisfy $ const True)))

203+

199-------------------------------------------------------------------------------

204-------------------------------------------------------------------------------

200-- Spanning

205-- Spanning

201-------------------------------------------------------------------------------

206-------------------------------------------------------------------------------

@@ -337,6 +342,7 @@ o_1_space_serial value =

337 , benchIOSink value "teeFst (all,any)" $ teeFstAllAny value

342 , benchIOSink value "teeFst (all,any)" $ teeFstAllAny value

338 , benchIOSink value "shortest (all,any)" $ shortestAllAny value

343 , benchIOSink value "shortest (all,any)" $ shortestAllAny value

339 , benchIOSink value "longest (all,any)" $ longestAllAny value

344 , benchIOSink value "longest (all,any)" $ longestAllAny value

345+ , benchIOSink value "sequenceParser" sequenceParser

340 ]

346 ]

341

347

342o_1_space_serial_spanning :: Int -> [Benchmark]

348o_1_space_serial_spanning :: Int -> [Benchmark]

core/src/Streamly/Internal/Data/Parser.hs+13−8

@@ -245,10 +245,12 @@ import Prelude hiding

245

246import Streamly.Internal.Data.Fold.Type (Fold(..))

247import Streamly.Internal.Data.Parser.ParserK.Type (Parser)

248+import Streamly.Internal.Data.Stream.Serial (SerialT(getSerialT))

248

249

249import qualified Streamly.Internal.Data.Fold.Type as FL

250import qualified Streamly.Internal.Data.Fold.Type as FL

250import qualified Streamly.Internal.Data.Parser.ParserD as D

251import qualified Streamly.Internal.Data.Parser.ParserD as D

251import qualified Streamly.Internal.Data.Parser.ParserK.Type as K

252import qualified Streamly.Internal.Data.Parser.ParserK.Type as K

253+import qualified Streamly.Internal.Data.Stream.StreamD.Type as SD

252

254

253--

255--

254-- $setup

256-- $setup

@@ -1193,19 +1195,22 @@ takeP i p = D.toParserK $ D.takeP i $ D.fromParserK p

1193-- Sequential Collection

1195-- Sequential Collection

1194-------------------------------------------------------------------------------

1196-------------------------------------------------------------------------------

1195--

1197--

1196−-- | @concatSequence f t@ collects sequential parses of parsers in the

1198+-- | @concatSequence f p@ collects sequential parses of parsers in a

1197−-- container @t@ using the fold @f@. Fails if the input ends or any of the

1199+-- serial stream @p@ using the fold @f@. Fails if the input ends or any

1198−-- parsers fail.

1200+-- of the parsers fail.

1199--

1201--

1200−-- This is same as 'Data.Traversable.sequence' but more efficient.

1202+-- An even more efficient implementation can use ParserD type Parser in

1203+-- the SerialT stream.

1201--

1204--

1202−-- /Unimplemented/

1205+-- /Pre-release/

1203--

1206--

1204{-# INLINE concatSequence #-}

1207{-# INLINE concatSequence #-}

1205concatSequence ::

1208concatSequence ::

1206− -- Foldable t =>

1209+ MonadCatch m =>

1207− Fold m b c -> t (Parser m a b) -> Parser m a c

1210+ Fold m b c -> SerialT m (Parser m a b) -> Parser m a c

1208−concatSequence _f _p = undefined

1211+concatSequence f p =

1212+ let sp = fmap D.fromParserK $ SD.fromStreamK $ getSerialT p

1213+ in D.toParserK $ D.sequence f sp

1209

1214

1210-- | Map a 'Parser' returning function on the result of a 'Parser'.

1215-- | Map a 'Parser' returning function on the result of a 'Parser'.

1211--

1216--

core/src/Streamly/Internal/Data/Parser/ParserD.hs+72−7

@@ -1901,14 +1901,79 @@ sepBy

1901-------------------------------------------------------------------------------

1902--

1903-- | See 'Streamly.Internal.Data.Parser.sequence'.

1904−--

1905−-- /Unimplemented/

1906−--

1907{-# INLINE sequence #-}

1904{-# INLINE sequence #-}

1908−sequence ::

1905+sequence :: MonadThrow m =>

1909− -- Foldable t =>

1910− Fold m b c -> t (Parser m a b) -> Parser m a c

1906+ Fold m b c -> D.Stream m (Parser m a b) -> Parser m a c

1911−sequence _f _p = undefined

1907+sequence (Fold fstep finitial fextract) (D.Stream sstep sstate) =

1908+ Parser step initial extract

1909+

1910+ where

1911+

1912+ initial = do

1913+ fres <- finitial

1914+ case fres of

1915+ FL.Partial fs -> return $ IPartial (Nothing', sstate, fs)

1916+ FL.Done c -> return $ IDone c

1917+

1918+ -- state does not contain any parser

1919+ -- yield a new parser from the stream

1920+ step (Nothing', ss, fs) _ = do

1921+ sres <- sstep defState ss

1922+ case sres of

1923+ D.Yield p ss1 -> return $ Continue 1 (Just' p, ss1, fs)

1924+ D.Stop -> do

1925+ c <- fextract fs

1926+ return $ Done 1 c

1927+ D.Skip ss1 -> return $ Continue 1 (Nothing', ss1, fs)

1928+

1929+ -- state holds a parser that may or may not have been

1930+ -- initialized. pinit holds the initial parser state

1931+ -- or modified parser state respectively

1932+ step (Just' (Parser pstep pinit pextr), ss, fs) a = do

1933+ ps <- pinit

1934+ case ps of

1935+ IPartial ps1 -> do

1936+ pres <- pstep ps1 a

1937+ case pres of

1938+ Partial n ps2 ->

1939+ let newP =

1940+ Just' $ Parser pstep (return $ IPartial ps2) pextr

1941+ in return $ Partial n (newP, ss, fs)

1942+ Continue n ps2 ->

1943+ let newP =

1944+ Just' $ Parser pstep (return $ IPartial ps2) pextr

1945+ in return $ Continue n (newP, ss, fs)

1946+ Done n b -> do

1947+ fres <- fstep fs b

1948+ case fres of

1949+ FL.Partial fs1 ->

1950+ return $ Partial n (Nothing', ss, fs1)

1951+ FL.Done c -> return $ Done n c

1952+ Error msg -> return $ Error msg

1953+ IDone b -> do

1954+ fres <- fstep fs b

1955+ case fres of

1956+ FL.Partial fs1 ->

1957+ return $ Partial 1 (Nothing', ss, fs1)

1958+ FL.Done c -> return $ Done 1 c

1959+ IError err -> return $ Error err

1960+

1961+ extract (Nothing', _, fs) = fextract fs

1962+ extract (Just' (Parser _ pinit pextr), _, fs) = do

1963+ ps <- pinit

1964+ case ps of

1965+ IPartial ps1 -> do

1966+ b <- pextr ps1

1967+ fres <- fstep fs b

1968+ case fres of

1969+ FL.Partial fs1 -> fextract fs1

1970+ FL.Done c -> return c

1971+ IDone b -> do

1972+ fres <- fstep fs b

1973+ case fres of

1974+ FL.Partial fs1 -> fextract fs1

1975+ FL.Done c -> return c

1976+ IError err -> throwM $ ParseError err

1912

1977

1913-------------------------------------------------------------------------------

1978-------------------------------------------------------------------------------

1914-- Alternative Collection

1979-- Alternative Collection

test/Streamly/Test/Data/Parser/ParserD.hs+15−1

@@ -2,7 +2,7 @@ module Main (main) where

3import Control.Exception (SomeException(..))

4import Data.Word (Word8, Word32, Word64)

5−import Streamly.Test.Common (listEquals, checkListEqual, chooseInt)

5+import Streamly.Test.Common (listEquals, checkListEqual, chooseInt, equals)

6import Test.Hspec (Spec, hspec, describe)

7import Test.Hspec.QuickCheck

8import Test.QuickCheck

@@ -18,6 +18,7 @@ import qualified Streamly.Internal.Data.Parser.ParserD as P

18import qualified Streamly.Internal.Data.Producer.Source as Source

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

20import qualified Streamly.Internal.Data.Stream.IsStream as S

21+import qualified Streamly.Internal.Data.Stream.StreamD as D

21import qualified Streamly.Internal.Data.Unfold as Unfold

22import qualified Streamly.Internal.Data.Unfold as Unfold

22import qualified Test.Hspec as H

23import qualified Test.Hspec as H

@@ -635,6 +636,18 @@ parseUnfold = do

635

636

636 listEquals (==) xs ls

637 listEquals (==) xs ls

637

638

639+parserSequence :: Property

640+parserSequence =

641+ forAll (vectorOf 11 (listOf (chooseAny :: Gen Int))) $ \ins ->

642+ monadicIO $ do

643+ let parsers = D.fromList

644+ $ fmap (\xs -> P.fromFold $ FL.take (length xs) FL.sum) ins

645+ let sequencedParser = P.sequence FL.sum parsers

646+ outs <-

647+ run $

648+ S.parseD sequencedParser $ S.concatMap S.fromList (S.fromList ins)

649+ equals (==) outs (sum $ map sum ins)

650+

638-------------------------------------------------------------------------------

651-------------------------------------------------------------------------------

639-- Test for a particular case hit during fs events testing

652-- Test for a particular case hit during fs events testing

640-------------------------------------------------------------------------------

653-------------------------------------------------------------------------------

@@ -720,6 +733,7 @@ main =

720 prop "parseMany" parseMany

733 prop "parseMany" parseMany

721 prop "parseMany2Events" parseMany2Events

734 prop "parseMany2Events" parseMany2Events

722 prop "parseUnfold" parseUnfold

735 prop "parseUnfold" parseUnfold

736+ prop "parserSequence" parserSequence

723

737

724 describe "test for accumulator" $ do

738 describe "test for accumulator" $ do

725 prop "P.fromFold FL.sum = FL.sum" fromFold

739 prop "P.fromFold FL.sum = FL.sum" fromFold