88e55f7 · streamly · git.iko.soy

git.iko.soy/streamly

on master help sign in

Add Monad and MonadPlus instances

88e55f7Harendra Kumar7 years ago

benchmark/Streamly/Benchmark/Data/Parser.hs+23−4

compare with master

unifiedsplit

@@ -16,8 +16,9 @@ import Control.DeepSeq (NFData(..))

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

17-- import Data.Foldable (asum)

18import System.Random (randomRIO)

19−import Prelude hiding (any, all, take)

19+import Prelude hiding (any, all, take, sequence, sequenceA)

21+-- import qualified Data.Traversable as TR

21import qualified Control.Applicative as AP

22import qualified Control.Applicative as AP

22import qualified Streamly as S hiding (runStream)

23import qualified Streamly as S hiding (runStream)

23import qualified Streamly.Prelude as S

24import qualified Streamly.Prelude as S

@@ -71,6 +72,21 @@ all value = IP.parse (PR.all (<= value))

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

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

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

73take value = IP.parse (PR.take value FL.drain)

75+{-

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

77+{-# INLINE sequenceA #-}

78+sequenceA :: MonadThrow m => Int -> SerialT m Int -> m Int

79+sequenceA value xs = do

80+ x <- IP.parse (TR.sequenceA (replicate value (PR.satisfy (> 0)))) xs

81+ return $ length x

82+

83+{-# INLINE sequence #-}

84+sequence :: MonadThrow m => Int -> SerialT m Int -> m Int

85+sequence value xs = do

86+ x <- IP.parse (TR.sequence (replicate value (PR.satisfy (> 0)))) xs

87+ return $ length x

88+-}

89+

74{-# INLINE many #-}

90{-# INLINE many #-}

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

91many :: MonadCatch m => SerialT m Int -> m Int

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

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

@@ -112,9 +128,10 @@ choice value = do

112-}

128-}

113

129

114{-# INLINE splitAllAny #-}

130{-# INLINE splitAllAny #-}

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

131+splitAllAny :: MonadThrow m

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

132+ => Int -> SerialT m Int -> m (Bool, Bool)

133+splitAllAny value =

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

134+ IP.parse ((,) <$> PR.all (<= (value `div` 2)) <*> PR.any (> value))

118

135

119{-# INLINE teeAllAny #-}

136{-# INLINE teeAllAny #-}

120teeAllAny :: (MonadThrow m, Ord a)

137teeAllAny :: (MonadThrow m, Ord a)

@@ -160,6 +177,8 @@ o_1_space_serial_parse value =

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

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

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

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

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

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

180+ -- , benchIOSink value "sequenceA/100" $ sequenceA (value `div` 100)

181+ -- , benchIOSink value "sequence/100" $ sequence (value `div` 100)

163 ]

182 ]

164

183

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

184-------------------------------------------------------------------------------

src/Streamly/Internal/Data/Parser/Types.hs+100−2

@@ -59,8 +59,9 @@ module Streamly.Internal.Data.Parser.Types

59 )

60where

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

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

62import Control.Applicative (Alternative(..))

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

64+import Control.Monad (MonadPlus(..))

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

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

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

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

@@ -454,7 +455,7 @@ dieM err =

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

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

455-- argument. The following code will fail:

456-- argument. The following code will fail:

456--

457--

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

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

458--

459--

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

460instance MonadCatch m => Alternative (Parser m a) where

460 {-# INLINE empty #-}

461 {-# INLINE empty #-}

@@ -468,3 +469,100 @@ instance MonadCatch m => Alternative (Parser m a) where

468

469

469 {-# INLINE some #-}

470 {-# INLINE some #-}

470 some = splitSome toList

471 some = splitSome toList

472+

473+{-# ANN type ConcatParseState Fuse #-}

474+data ConcatParseState sl p = ConcatParseL sl | ConcatParseR p

475+

476+-- Note: The monad instance has quadratic performance complexity. It works fine

477+-- for small number of compositions but for a scalable implementation we need a

478+-- CPS version.

479+

480+-- | Monad composition can be used for lookbehind parsers, we can make the

481+-- future parses depend on the previously parsed values.

482+--

483+-- If we have to parse "a9" or "9a" but not "99" or "aa" we can use the

484+-- following parser:

485+--

486+-- @

487+-- backtracking :: MonadCatch m => PR.Parser m Char String

488+-- backtracking =

489+-- sequence [PR.satisfy isDigit, PR.satisfy isAlpha]

490+-- '<|>'

491+-- sequence [PR.satisfy isAlpha, PR.satisfy isDigit]

492+-- @

493+--

494+-- We know that if the first parse resulted in a digit at the first place then

495+-- the second parse is going to fail. However, we waste that information and

496+-- parse the first character again in the second parse only to know that it is

497+-- not an alphabetic char. By using lookbehind in a 'Monad' composition we can

498+-- avoid redundant work:

499+--

500+-- @

501+-- data DigitOrAlpha = Digit Char | Alpha Char

502+--

503+-- lookbehind :: MonadCatch m => PR.Parser m Char String

504+-- lookbehind = do

505+-- x1 \<- Digit '<$>' PR.satisfy isDigit

506+-- '<|>' Alpha '<$>' PR.satisfy isAlpha

507+--

508+-- -- Note: the parse depends on what we parsed already

509+-- x2 <- case x1 of

510+-- Digit _ -> PR.satisfy isAlpha

511+-- Alpha _ -> PR.satisfy isDigit

512+--

513+-- return $ case x1 of

514+-- Digit x -> [x,x2]

515+-- Alpha x -> [x,x2]

516+-- @

517+--

518+instance Monad m => Monad (Parser m a) where

519+ {-# INLINE return #-}

520+ return = pure

521+

522+ -- (>>=) :: Parser m a b -> (b -> Parser m a c) -> Parser m a c

523+ {-# INLINE (>>=) #-}

524+ (Parser stepL initialL extractL) >>= func = Parser step initial extract

525+

526+ where

527+

528+ initial = ConcatParseL <$> initialL

529+

530+ step (ConcatParseL st) a = do

531+ r <- stepL st a

532+ return $ case r of

533+ Yield _ s -> Skip 0 (ConcatParseL s)

534+ Skip n s -> Skip n (ConcatParseL s)

535+ Stop n b -> Skip n (ConcatParseR (func b))

536+ Error err -> Error err

537+

538+ step (ConcatParseR (Parser stepR initialR extractR)) a = do

539+ st <- initialR

540+ r <- stepR st a

541+ return $ case r of

542+ Yield n s ->

543+ Yield n (ConcatParseR (Parser stepR (return s) extractR))

544+ Skip n s ->

545+ Skip n (ConcatParseR (Parser stepR (return s) extractR))

546+ Stop n b -> Stop n b

547+ Error err -> Error err

548+

549+ extract (ConcatParseR (Parser _ initialR extractR)) =

550+ initialR >>= extractR

551+

552+ extract (ConcatParseL sL) = extractL sL >>= f . func

553+

554+ where

555+

556+ f (Parser _ initialR extractR) = initialR >>= extractR

557+

558+-- | 'mzero' is same as 'empty', it aborts the parser. 'mplus' is same as

559+-- '<|>', it selects the first succeeding parser.

560+--

561+-- /Internal/

562+--

563+instance MonadCatch m => MonadPlus (Parser m a) where

564+ {-# INLINE mzero #-}

565+ mzero = die "mzero"

566+

567+ {-# INLINE mplus #-}

568+ mplus = alt