mirror of
https://github.com/composewell/streamly.git
synced 2024-09-11 11:37:22 +03:00
Implement some undefined functions in Fold module
Implement Some undefined in Internal.Data.Fold module Add test cases for newly added functions Add bench marks for newly added Data.Fold functions
This commit is contained in:
Ranjeet Kumar Ranjan
Harendra Kumar
parent
9b8398668a
commit
878d734dd7
@ -98,6 +98,14 @@ splitAllAny value =
|
||||
(FL.any (> value))
|
||||
)
|
||||
|
||||
{-# INLINE shortest #-}
|
||||
shortest :: Monad m => SerialT m Int -> m (Either Int Int)
|
||||
shortest = IP.fold (FL.shortest FL.sum FL.length)
|
||||
|
||||
{-# INLINE longest #-}
|
||||
longest :: Monad m => SerialT m Int -> m (Either Int Int)
|
||||
longest = IP.fold (FL.longest FL.sum FL.length)
|
||||
|
||||
{-
|
||||
{-# INLINE split_ #-}
|
||||
split_ :: Monad m
|
||||
@ -127,6 +135,14 @@ teeAllAny value = IP.fold (FL.teeWith (,) all_ any_)
|
||||
all_ = FL.all (<= value)
|
||||
any_ = FL.any (> value)
|
||||
|
||||
{-# INLINE teeWithFst #-}
|
||||
teeWithFst :: Monad m => SerialT m Int -> m (Int, Int)
|
||||
teeWithFst = IP.fold (FL.teeWithFst (,) FL.sum FL.length)
|
||||
|
||||
{-# INLINE teeWithMin #-}
|
||||
teeWithMin :: Monad m => SerialT m Int -> m (Int, Int)
|
||||
teeWithMin = IP.fold (FL.teeWithMin (,) FL.sum FL.length)
|
||||
|
||||
{-# INLINE distribute #-}
|
||||
distribute :: Monad m => SerialT m Int -> m [Int]
|
||||
distribute = IP.fold (FL.distribute [FL.sum, FL.length])
|
||||
@ -144,6 +160,18 @@ partition =
|
||||
else Right a
|
||||
in IP.fold $ FL.lmap f (FL.partition FL.sum FL.length)
|
||||
|
||||
{-# INLINE partitionByFstM #-}
|
||||
partitionByFstM :: Monad m => SerialT m Int -> m (Int, Int)
|
||||
partitionByFstM = do
|
||||
let f x = if odd x then return (Left x) else return (Right x)
|
||||
IP.fold (FL.partitionByFstM f FL.length FL.length)
|
||||
|
||||
{-# INLINE partitionByMinM #-}
|
||||
partitionByMinM :: Monad m => SerialT m Int -> m (Int, Int)
|
||||
partitionByMinM = do
|
||||
let f x = if odd x then return (Left x) else return (Right x)
|
||||
IP.fold (FL.partitionByMinM f FL.length FL.length)
|
||||
|
||||
{-# INLINE demuxWith #-}
|
||||
demuxWith ::
|
||||
(Monad m, Ord k)
|
||||
@ -175,6 +203,18 @@ classifyWith f = S.fold (FL.classifyWith f FL.sum)
|
||||
unzip :: Monad m => SerialT m Int -> m (Int, Int)
|
||||
unzip = IP.fold $ FL.lmap (\a -> (a, a)) (FL.unzip FL.sum FL.length)
|
||||
|
||||
{-# INLINE unzipWithFstM #-}
|
||||
unzipWithFstM :: Monad m => SerialT m Int -> m (Int, Int)
|
||||
unzipWithFstM = do
|
||||
let f = \a -> return (a+1, a)
|
||||
IP.fold (FL.unzipWithFstM f FL.sum FL.length)
|
||||
|
||||
{-# INLINE unzipWithMinM #-}
|
||||
unzipWithMinM :: Monad m => SerialT m Int -> m (Int, Int)
|
||||
unzipWithMinM = do
|
||||
let f = \a -> return (a+1, a)
|
||||
IP.fold (FL.unzipWithMinM f FL.sum FL.length)
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Benchmarks
|
||||
-------------------------------------------------------------------------------
|
||||
@ -278,10 +318,18 @@ o_1_space_serial_composition value =
|
||||
[ benchIOSink value "serialWith (all, any)" $ splitAllAny value
|
||||
, benchIOSink value "tee (all, any)" $ teeAllAny value
|
||||
, benchIOSink value "many drain (take 1)" many
|
||||
, benchIOSink value "shortest (sum, length)" shortest
|
||||
, benchIOSink value "longest (sum, length)" longest
|
||||
, benchIOSink value "tee (sum, length)" teeSumLength
|
||||
, benchIOSink value "teeWithFst (sum, length)" teeWithFst
|
||||
, benchIOSink value "teeWithMin (sum, length)" teeWithMin
|
||||
, benchIOSink value "distribute [sum, length]" distribute
|
||||
, benchIOSink value "partition (sum, length)" partition
|
||||
, benchIOSink value "partitionByFstM (length, length)" partitionByFstM
|
||||
, benchIOSink value "partitionByMinM (length, length)" partitionByMinM
|
||||
, benchIOSink value "unzip (sum, length)" unzip
|
||||
, benchIOSink value "unzipWithFstM (sum, length)" unzipWithFstM
|
||||
, benchIOSink value "unzipWithMinM (sum, length)" unzipWithMinM
|
||||
, benchIOSink value "demuxDefaultWith [sum, length] sum"
|
||||
$ demuxDefaultWith fn mp
|
||||
, benchIOSink value "demuxWith [sum, length]" $ demuxWith fn mp
|
||||
|
||||
@ -241,6 +241,8 @@ module Streamly.Data.Fold
|
||||
-- "Streamly.Internal.Data.Fold.Tee".
|
||||
|
||||
, teeWith
|
||||
--, teeWithFst
|
||||
--, teeWithMin
|
||||
, tee
|
||||
, distribute
|
||||
|
||||
@ -249,6 +251,10 @@ module Streamly.Data.Fold
|
||||
-- fold selector.
|
||||
|
||||
, partition
|
||||
--, partitionByM
|
||||
--, partitionByFstM
|
||||
--, partitionByMinM
|
||||
--, partitionBy
|
||||
|
||||
-- ** Unzipping
|
||||
, unzip
|
||||
|
||||
@ -1225,21 +1225,111 @@ partitionByM f (Fold stepL beginL doneL) (Fold stepR beginR doneR) =
|
||||
|
||||
-- | Similar to 'partitionByM' but terminates when the first fold terminates.
|
||||
--
|
||||
-- /Unimplemented/
|
||||
--
|
||||
{-# INLINE partitionByFstM #-}
|
||||
partitionByFstM :: -- Monad m =>
|
||||
(a -> m (Either b c)) -> Fold m b x -> Fold m c y -> Fold m a (x, y)
|
||||
partitionByFstM = undefined
|
||||
partitionByFstM :: Monad m
|
||||
=> (a -> m (Either b c)) -> Fold m b x -> Fold m c y -> Fold m a (x, y)
|
||||
partitionByFstM f (Fold stepL beginL doneL) (Fold stepR beginR doneR) =
|
||||
Fold step begin done
|
||||
|
||||
where
|
||||
|
||||
begin = do
|
||||
resL <- beginL
|
||||
resR <- beginR
|
||||
case resL of
|
||||
Partial sL -> return $
|
||||
case resR of
|
||||
Partial sR -> Partial $ RunFstBoth sL sR
|
||||
Done bR -> Partial $ RunFstLeft sL bR
|
||||
Done bL -> do
|
||||
case resR of
|
||||
Partial sR -> do
|
||||
bR <- doneR sR
|
||||
return $ Done (bL, bR)
|
||||
Done bR -> return $ Done (bL, bR)
|
||||
|
||||
step (RunFstBoth sL sR) a = do
|
||||
r <- f a
|
||||
case r of
|
||||
Left b -> do
|
||||
res <- stepL sL b
|
||||
case res of
|
||||
Partial sres -> return $ Partial $ RunFstBoth sres sR
|
||||
Done bL -> do
|
||||
bR <- doneR sR
|
||||
return $ Done (bL, bR)
|
||||
|
||||
Right c -> do
|
||||
res <- stepR sR c
|
||||
return
|
||||
$ Partial
|
||||
$ case res of
|
||||
Partial sres -> RunFstBoth sL sres
|
||||
Done bres -> RunFstLeft sL bres
|
||||
step (RunFstLeft sL bR) a = do
|
||||
r <- f a
|
||||
case r of
|
||||
Left b -> do
|
||||
res <- stepL sL b
|
||||
return
|
||||
$ case res of
|
||||
Partial sres -> Partial $ RunFstLeft sres bR
|
||||
Done bres -> Done (bres, bR)
|
||||
Right _ -> return $ Partial $ RunFstLeft sL bR
|
||||
|
||||
done (RunFstBoth sL sR) = (,) <$> doneL sL <*> doneR sR
|
||||
|
||||
done (RunFstLeft sL bR) = (,bR) <$> doneL sL
|
||||
|
||||
-- | Similar to 'partitionByM' but terminates when any fold terminates.
|
||||
--
|
||||
-- /Unimplemented/
|
||||
--
|
||||
{-# INLINE partitionByMinM #-}
|
||||
partitionByMinM :: -- Monad m =>
|
||||
(a -> m (Either b c)) -> Fold m b x -> Fold m c y -> Fold m a (x, y)
|
||||
partitionByMinM = undefined
|
||||
partitionByMinM :: Monad m =>
|
||||
(a -> m (Either b c)) -> Fold m b x -> Fold m c y -> Fold m a (x, y)
|
||||
partitionByMinM f (Fold stepL beginL doneL) (Fold stepR beginR doneR) =
|
||||
Fold step begin done
|
||||
|
||||
where
|
||||
|
||||
begin = do
|
||||
resL <- beginL
|
||||
resR <- beginR
|
||||
case resL of
|
||||
Partial sL ->
|
||||
case resR of
|
||||
Partial sR -> return $ Partial $ Tuple' sL sR
|
||||
Done bR -> do
|
||||
bL <- doneL sL
|
||||
return $ Done (bL, bR)
|
||||
Done bL -> do
|
||||
case resR of
|
||||
Partial sR -> do
|
||||
bR <- doneR sR
|
||||
return $ Done (bL, bR)
|
||||
Done bR -> return $ Done (bL, bR)
|
||||
|
||||
step (Tuple' sL sR) a = do
|
||||
r <- f a
|
||||
case r of
|
||||
Left b -> do
|
||||
res <- stepL sL b
|
||||
case res of
|
||||
Partial sres -> return $ Partial $ Tuple' sres sR
|
||||
Done bL -> do
|
||||
bR <- doneR sR
|
||||
return $ Done (bL, bR)
|
||||
|
||||
Right c -> do
|
||||
res <- stepR sR c
|
||||
case res of
|
||||
Partial sres -> return $ Partial $ Tuple' sL sres
|
||||
Done bR -> do
|
||||
bL <- doneL sL
|
||||
return $ Done (bL, bR)
|
||||
|
||||
done (Tuple' sL sR) = (,) <$> doneL sL <*> doneR sR
|
||||
|
||||
-- Note: we could use (a -> Bool) instead of (a -> Either b c), but the latter
|
||||
-- makes the signature clearer as to which case belongs to which fold.
|
||||
@ -1625,21 +1715,105 @@ unzipWithM f (Fold stepL beginL doneL) (Fold stepR beginR doneR) =
|
||||
|
||||
-- | Similar to 'unzipWithM' but terminates when the first fold terminates.
|
||||
--
|
||||
-- /Unimplemented/
|
||||
--
|
||||
{-# INLINE unzipWithFstM #-}
|
||||
unzipWithFstM :: -- Monad m =>
|
||||
(a -> m (b,c)) -> Fold m b x -> Fold m c y -> Fold m a (x,y)
|
||||
unzipWithFstM = undefined
|
||||
unzipWithFstM :: Monad m =>
|
||||
(a -> m (b, c)) -> Fold m b x -> Fold m c y -> Fold m a (x, y)
|
||||
unzipWithFstM f (Fold stepL beginL doneL) (Fold stepR beginR doneR) =
|
||||
Fold step begin done
|
||||
|
||||
where
|
||||
|
||||
begin = do
|
||||
resL <- beginL
|
||||
resR <- beginR
|
||||
case resL of
|
||||
Partial sL -> return $ Partial $
|
||||
case resR of
|
||||
Partial sR -> RunFstBoth sL sR
|
||||
Done bR -> RunFstLeft sL bR
|
||||
Done bL -> do
|
||||
case resR of
|
||||
Partial sR -> do
|
||||
bR <- doneR sR
|
||||
return $ Done (bL, bR)
|
||||
Done bR -> return $ Done (bL, bR)
|
||||
|
||||
step (RunFstBoth sL sR) a = do
|
||||
(b, c) <- f a
|
||||
resL <- stepL sL b
|
||||
resR <- stepR sR c
|
||||
case resL of
|
||||
Partial sresL -> return $ Partial $
|
||||
case resR of
|
||||
Partial sresR -> RunFstBoth sresL sresR
|
||||
Done bresR -> RunFstLeft sresL bresR
|
||||
Done bL -> do
|
||||
case resR of
|
||||
Partial sresR -> do
|
||||
bR <- doneR sresR
|
||||
return $ Done (bL, bR)
|
||||
Done bR -> return $ Done (bL, bR)
|
||||
|
||||
step (RunFstLeft sL bR) a = do
|
||||
(b, _) <- f a
|
||||
resL <- stepL sL b
|
||||
return
|
||||
$ case resL of
|
||||
Partial sresL -> Partial $ RunFstLeft sresL bR
|
||||
Done bresL -> Done (bresL, bR)
|
||||
|
||||
done (RunFstBoth sL sR) = (,) <$> doneL sL <*> doneR sR
|
||||
done (RunFstLeft sL bR) = (,bR) <$> doneL sL
|
||||
|
||||
-- | Similar to 'unzipWithM' but terminates when any fold terminates.
|
||||
--
|
||||
-- /Unimplemented/
|
||||
--
|
||||
{-# INLINE unzipWithMinM #-}
|
||||
unzipWithMinM :: -- Monad m =>
|
||||
(a -> m (b,c)) -> Fold m b x -> Fold m c y -> Fold m a (x,y)
|
||||
unzipWithMinM = undefined
|
||||
unzipWithMinM :: Monad m =>
|
||||
(a -> m (b,c)) -> Fold m b x -> Fold m c y -> Fold m a (x,y)
|
||||
unzipWithMinM f (Fold stepL beginL doneL) (Fold stepR beginR doneR) =
|
||||
Fold step begin done
|
||||
|
||||
where
|
||||
|
||||
begin = do
|
||||
resL <- beginL
|
||||
resR <- beginR
|
||||
case resL of
|
||||
Partial sL ->
|
||||
case resR of
|
||||
Partial sR -> return $ Partial $ Tuple' sL sR
|
||||
Done bR -> do
|
||||
bL <- doneL sL
|
||||
return $ Done (bL, bR)
|
||||
Done bL -> do
|
||||
case resR of
|
||||
Partial sR -> do
|
||||
bR <- doneR sR
|
||||
return $ Done (bL, bR)
|
||||
Done bR -> return $ Done (bL, bR)
|
||||
|
||||
step (Tuple' sL sR) a = do
|
||||
(b, c) <- f a
|
||||
resL <- stepL sL b
|
||||
resR <- stepR sR c
|
||||
case resL of
|
||||
Partial sresL ->
|
||||
case resR of
|
||||
Partial sresR -> return $ Partial $ Tuple' sresL sresR
|
||||
Done bR -> do
|
||||
bL <- doneL sL
|
||||
return $ Done (bL, bR)
|
||||
Done bL -> do
|
||||
case resR of
|
||||
Partial sresR -> do
|
||||
bR <- doneR sresR
|
||||
return $ Done (bL, bR)
|
||||
Done bR -> return $ Done (bL, bR)
|
||||
|
||||
done (Tuple' sL sR) = (,) <$> doneL sL <*> doneR sR
|
||||
|
||||
|
||||
-- | Split elements in the input stream into two parts using a pure splitter
|
||||
-- function, direct each part to a different fold and zip the results.
|
||||
|
||||
@ -236,6 +236,7 @@ module Streamly.Internal.Data.Fold.Type
|
||||
|
||||
-- ** Parallel Distribution
|
||||
, GenericRunner(..)
|
||||
, FstRunner(..)
|
||||
, teeWith
|
||||
, teeWithFst
|
||||
, teeWithMin
|
||||
@ -708,12 +709,44 @@ serialWith func (Fold stepL initialL extractL) (Fold stepR initialR extractR) =
|
||||
-- | Same as applicative '*>'. Run two folds serially one after the other
|
||||
-- discarding the result of the first.
|
||||
--
|
||||
-- /Unimplemented/
|
||||
--
|
||||
{-# INLINE serial_ #-}
|
||||
serial_ :: -- Monad m =>
|
||||
serial_ :: Monad m =>
|
||||
Fold m x a -> Fold m x b -> Fold m x b
|
||||
serial_ _f1 _f2 = undefined
|
||||
serial_ (Fold stepL initialL _) (Fold stepR initialR extractR) =
|
||||
Fold step initial extract
|
||||
|
||||
where
|
||||
|
||||
func _ b = b
|
||||
|
||||
initial = do
|
||||
resL <- initialL
|
||||
case resL of
|
||||
Partial sl -> return $ Partial $ SeqFoldL sl
|
||||
Done bl -> do
|
||||
resR <- initialR
|
||||
return $ first (SeqFoldR (func bl)) resR
|
||||
|
||||
step (SeqFoldL st) a = do
|
||||
r <- stepL st a
|
||||
case r of
|
||||
Partial s -> return $ Partial (SeqFoldL s)
|
||||
Done b -> do
|
||||
res <- initialR
|
||||
return $ first (SeqFoldR (func b)) res
|
||||
step (SeqFoldR f st) a = do
|
||||
r <- stepR st a
|
||||
return $
|
||||
case r of
|
||||
Partial s -> Partial (SeqFoldR f s)
|
||||
Done b -> Done b
|
||||
|
||||
extract (SeqFoldR _ sR) = extractR sR
|
||||
extract (SeqFoldL _) = do
|
||||
res <- initialR
|
||||
case res of
|
||||
Partial sR -> extractR sR
|
||||
Done rR -> return rR
|
||||
|
||||
{-# ANN type GenericRunner Fuse #-}
|
||||
data GenericRunner sL sR bL bR
|
||||
@ -721,6 +754,11 @@ data GenericRunner sL sR bL bR
|
||||
| RunLeft !sL !bR
|
||||
| RunRight !bL !sR
|
||||
|
||||
{-# ANN type FstRunner Fuse #-}
|
||||
data FstRunner sL sR b
|
||||
= RunFstBoth !sL !sR
|
||||
| RunFstLeft !sL !b
|
||||
|
||||
-- | @teeWith k f1 f2@ distributes its input to both @f1@ and @f2@ until both
|
||||
-- of them terminate and combines their output using @k@.
|
||||
--
|
||||
@ -797,42 +835,223 @@ teeWith f (Fold stepL beginL doneL) (Fold stepR beginR doneR) =
|
||||
|
||||
-- | Like 'teeWith' but terminates as soon as the first fold terminates.
|
||||
--
|
||||
-- /Unimplemented/
|
||||
-- /Pre-release/
|
||||
--
|
||||
{-# INLINE teeWithFst #-}
|
||||
teeWithFst :: (b -> c -> d) -> Fold m a b -> Fold m a c -> Fold m a d
|
||||
teeWithFst = undefined
|
||||
teeWithFst :: Monad m => (b -> c -> d) -> Fold m a b -> Fold m a c -> Fold m a d
|
||||
teeWithFst f (Fold stepL beginL doneL) (Fold stepR beginR doneR) =
|
||||
Fold step begin done
|
||||
|
||||
where
|
||||
|
||||
begin = do
|
||||
resL <- beginL
|
||||
resR <- beginR
|
||||
|
||||
case resL of
|
||||
Partial sl ->
|
||||
return $ Partial $
|
||||
case resR of
|
||||
Partial sr -> RunFstBoth sl sr
|
||||
Done br -> RunFstLeft sl br
|
||||
Done bl -> do
|
||||
case resR of
|
||||
Partial sr -> do
|
||||
br <- doneR sr
|
||||
return $ Done $ f bl br
|
||||
Done br -> return $ Done $ f bl br
|
||||
|
||||
step (RunFstBoth sL sR) a = do
|
||||
resL <- stepL sL a
|
||||
resR <- stepR sR a
|
||||
case resL of
|
||||
Partial sL1 ->
|
||||
return
|
||||
$ Partial
|
||||
$ case resR of
|
||||
Partial sR1 -> RunFstBoth sL1 sR1
|
||||
Done bR -> RunFstLeft sL1 bR
|
||||
Done bL ->
|
||||
case resR of
|
||||
Partial sR1 -> do
|
||||
br <- doneR sR1
|
||||
return $ Done $ f bL br
|
||||
Done bR -> return $ Done $ f bL bR
|
||||
|
||||
step (RunFstLeft sL bR) a = do
|
||||
resL <- stepL sL a
|
||||
return
|
||||
$ case resL of
|
||||
Partial sL1 -> Partial $ RunFstLeft sL1 bR
|
||||
Done bL -> Done $ f bL bR
|
||||
|
||||
done (RunFstBoth sL sR) = do
|
||||
bL <- doneL sL
|
||||
bR <- doneR sR
|
||||
return $ f bL bR
|
||||
done (RunFstLeft sL bR) = do
|
||||
bL <- doneL sL
|
||||
return $ f bL bR
|
||||
|
||||
-- | Like 'teeWith' but terminates as soon as any one of the two folds
|
||||
-- terminates.
|
||||
--
|
||||
-- /Unimplemented/
|
||||
-- /Pre-release/
|
||||
--
|
||||
{-# INLINE teeWithMin #-}
|
||||
teeWithMin :: (b -> c -> d) -> Fold m a b -> Fold m a c -> Fold m a d
|
||||
teeWithMin = undefined
|
||||
teeWithMin :: Monad m => (b -> c -> d) -> Fold m a b -> Fold m a c -> Fold m a d
|
||||
teeWithMin f (Fold stepL beginL doneL) (Fold stepR beginR doneR) =
|
||||
Fold step begin done
|
||||
|
||||
where
|
||||
|
||||
begin = do
|
||||
resL <- beginL
|
||||
resR <- beginR
|
||||
case resL of
|
||||
Partial sL1 -> do
|
||||
case resR of
|
||||
Partial sR1 -> return $ Partial $ Tuple' sL1 sR1
|
||||
Done br -> do
|
||||
bl <- doneL sL1
|
||||
return $ Done $ f bl br
|
||||
|
||||
Done bl -> do
|
||||
case resR of
|
||||
Partial sr -> do
|
||||
br <- doneR sr
|
||||
return $ Done $ f bl br
|
||||
Done br -> return $ Done $ f bl br
|
||||
|
||||
step (Tuple' sL sR) a = do
|
||||
resL <- stepL sL a
|
||||
resR <- stepR sR a
|
||||
case resL of
|
||||
Partial sL1 ->
|
||||
case resR of
|
||||
Partial sR1 -> return $ Partial $ Tuple' sL1 sR1
|
||||
Done bR -> do
|
||||
bL <- doneL sL1
|
||||
return $ Done $ f bL bR
|
||||
Done bL ->
|
||||
case resR of
|
||||
Partial sR1 -> do
|
||||
br <- doneR sR1
|
||||
return $ Done $ f bL br
|
||||
Done bR -> return $ Done $ f bL bR
|
||||
|
||||
done (Tuple' sL sR) = do
|
||||
bL <- doneL sL
|
||||
bR <- doneR sR
|
||||
return $ f bL bR
|
||||
|
||||
-- | Shortest alternative. Apply both folds in parallel but choose the result
|
||||
-- from the one which consumed least input i.e. take the shortest succeeding
|
||||
-- fold.
|
||||
--
|
||||
-- /Unimplemented/
|
||||
-- /Pre-release/
|
||||
--
|
||||
{-# INLINE shortest #-}
|
||||
shortest :: -- Monad m =>
|
||||
Fold m x a -> Fold m x a -> Fold m x a
|
||||
shortest _f1 _f2 = undefined
|
||||
shortest :: Monad m => Fold m x a -> Fold m x b -> Fold m x (Either a b)
|
||||
shortest (Fold stepL beginL doneL) (Fold stepR beginR _) =
|
||||
Fold step begin done
|
||||
|
||||
where
|
||||
|
||||
begin = do
|
||||
resL <- beginL
|
||||
resR <- beginR
|
||||
return $
|
||||
case resL of
|
||||
Partial sL ->
|
||||
case resR of
|
||||
Partial sR -> Partial $ Tuple' sL sR
|
||||
Done bR -> Done $ Right bR
|
||||
Done bL -> Done $ Left bL
|
||||
|
||||
step (Tuple' sL sR) a = do
|
||||
resL <- stepL sL a
|
||||
resR <- stepR sR a
|
||||
return $
|
||||
case resL of
|
||||
Partial sL1 ->
|
||||
case resR of
|
||||
Partial sR1 -> Partial $ Tuple' sL1 sR1
|
||||
Done bR -> Done $ Right bR
|
||||
Done bL -> Done $ Left bL
|
||||
|
||||
done (Tuple' sL _) = do
|
||||
x <- doneL sL
|
||||
return $ Left x
|
||||
|
||||
{-# ANN type LongestRunner Fuse #-}
|
||||
data LongestRunner sL sR bL bR
|
||||
= LongestRunBoth !sL !sR
|
||||
| LongestRunLeft !sL !bR
|
||||
| LongestRunRight !bL !sR
|
||||
|
||||
-- | Longest alternative. Apply both folds in parallel but choose the result
|
||||
-- from the one which consumed more input i.e. take the longest succeeding
|
||||
-- fold.
|
||||
--
|
||||
-- /Unimplemented/
|
||||
-- /Pre-release/
|
||||
--
|
||||
{-# INLINE longest #-}
|
||||
longest :: -- Monad m =>
|
||||
Fold m x a -> Fold m x a -> Fold m x a
|
||||
longest _f1 _f2 = undefined
|
||||
longest :: Monad m => Fold m x a -> Fold m x b -> Fold m x (Either a b)
|
||||
longest (Fold stepL beginL doneL) (Fold stepR beginR doneR) =
|
||||
Fold step begin done
|
||||
|
||||
where
|
||||
|
||||
begin = do
|
||||
resL <- beginL
|
||||
resR <- beginR
|
||||
return $
|
||||
case resL of
|
||||
Partial sL ->
|
||||
Partial $
|
||||
case resR of
|
||||
Partial sR -> LongestRunBoth sL sR
|
||||
Done bR -> LongestRunLeft sL bR
|
||||
Done bL ->
|
||||
case resR of
|
||||
Partial sR -> Partial $ LongestRunRight bL sR
|
||||
Done bR -> Done $ Right bR
|
||||
|
||||
step (LongestRunBoth sL sR) a = do
|
||||
resL <- stepL sL a
|
||||
resR <- stepR sR a
|
||||
case resL of
|
||||
Partial sL1 ->
|
||||
return
|
||||
$ Partial
|
||||
$ case resR of
|
||||
Partial sR1 -> LongestRunBoth sL1 sR1
|
||||
Done bR -> LongestRunLeft sL1 bR
|
||||
Done bL ->
|
||||
return
|
||||
$ case resR of
|
||||
Partial sR1 -> Partial $ LongestRunRight bL sR1
|
||||
Done bR -> Done $ Right bR
|
||||
|
||||
step (LongestRunLeft sL bR) a = do
|
||||
resL <- stepL sL a
|
||||
return $
|
||||
case resL of
|
||||
Partial sL1 -> Partial $ LongestRunLeft sL1 bR
|
||||
Done bL -> Done $ Left bL
|
||||
|
||||
step (LongestRunRight bL sR) a = do
|
||||
resR <- stepR sR a
|
||||
return
|
||||
$ case resR of
|
||||
Partial sR1 -> Partial $ LongestRunRight bL sR1
|
||||
Done bR -> Done $ Right bR
|
||||
|
||||
done (LongestRunLeft sL _) = Left <$> doneL sL
|
||||
|
||||
done (LongestRunRight _ sR) = Right <$> doneR sR
|
||||
|
||||
done (LongestRunBoth sL _) = Left <$> doneL sL
|
||||
|
||||
data ConcatMapState m sa a c
|
||||
= B !sa
|
||||
|
||||
@ -377,6 +377,101 @@ teeWithLength =
|
||||
v3 = Prelude.length ls
|
||||
assert (v1 == (v2, v3))
|
||||
|
||||
teeWithFstLength :: Property
|
||||
teeWithFstLength =
|
||||
forAll (listOf1 (chooseInt (intMin, intMax)))
|
||||
$ \ls0 -> monadicIO $ action ls0
|
||||
|
||||
where
|
||||
|
||||
action ls = do
|
||||
v1 <- run $ S.fold (F.teeWithFst (,) (FL.take 5 FL.sum) FL.length) $ S.fromList ls
|
||||
let v2 = Prelude.sum (Prelude.take 5 ls)
|
||||
v3 = Prelude.length (Prelude.take 5 ls)
|
||||
assert (v1 == (v2, v3))
|
||||
|
||||
partitionByM :: Property
|
||||
partitionByM =
|
||||
forAll (listOf1 (chooseInt (intMin, intMax)))
|
||||
$ \ls0 -> monadicIO $ action ls0
|
||||
|
||||
where
|
||||
|
||||
action ls = do
|
||||
let f = \x -> if odd x then return (Left x) else return (Right x)
|
||||
v1 <- run $ S.fold (F.partitionByM f FL.length FL.length) $ S.fromList ls
|
||||
let v2 = foldl (\b a -> if odd a then b+1 else b) 0 ls
|
||||
v3 = foldl (\b a -> if even a then b+1 else b) 0 ls
|
||||
assert (v1 == (v2, v3))
|
||||
|
||||
partitionByFstM :: Property
|
||||
partitionByFstM =
|
||||
forAll (listOf1 (chooseInt (intMin, intMax)))
|
||||
$ \ls0 -> monadicIO $ action ls0
|
||||
|
||||
where
|
||||
|
||||
action _ = do
|
||||
let f = \x -> if odd x then return (Left x) else return (Right x)
|
||||
v1 <- run $ S.fold (F.partitionByFstM f (FL.take 25 FL.length) FL.length) (S.fromList ([1..100]:: [Int]))
|
||||
let v2 = foldl (\b a -> if odd a then b+1 else b) 0 ([1..49] :: [Int])
|
||||
v3 = foldl (\b a -> if even a then b+1 else b) 0 ([1..49] :: [Int])
|
||||
assert (v1 == (v2, v3))
|
||||
|
||||
partitionByMinM1 :: Property
|
||||
partitionByMinM1 =
|
||||
forAll (listOf1 (chooseInt (intMin, intMax)))
|
||||
$ \ls0 -> monadicIO $ action ls0
|
||||
|
||||
where
|
||||
|
||||
action _ = do
|
||||
let f = \x -> if odd x then return (Left x) else return (Right x)
|
||||
v1 <- run $ S.fold (F.partitionByMinM f FL.length (FL.take 25 FL.length)) (S.fromList ([1..100]:: [Int]))
|
||||
let v2 = foldl (\b a -> if odd a then b+1 else b) 0 ([1..50] :: [Int])
|
||||
v3 = foldl (\b a -> if even a then b+1 else b) 0 ([1..50] :: [Int])
|
||||
assert (v1 == (v2, v3))
|
||||
|
||||
partitionByMinM2 :: Property
|
||||
partitionByMinM2 =
|
||||
forAll (listOf1 (chooseInt (intMin, intMax)))
|
||||
$ \ls0 -> monadicIO $ action ls0
|
||||
|
||||
where
|
||||
|
||||
action _ = do
|
||||
let f = \x -> if odd x then return (Left x) else return (Right x)
|
||||
v1 <- run $ S.fold (F.partitionByMinM f (FL.take 25 FL.length) FL.length) (S.fromList ([1..100]:: [Int]))
|
||||
let v2 = foldl (\b a -> if odd a then b+1 else b) 0 ([1..49] :: [Int])
|
||||
v3 = foldl (\b a -> if even a then b+1 else b) 0 ([1..49] :: [Int])
|
||||
assert (v1 == (v2, v3))
|
||||
|
||||
teeWithMinLength1 :: Property
|
||||
teeWithMinLength1 =
|
||||
forAll (listOf1 (chooseInt (intMin, intMax)))
|
||||
$ \ls0 -> monadicIO $ action ls0
|
||||
|
||||
where
|
||||
|
||||
action ls = do
|
||||
v1 <- run $ S.fold (F.teeWithMin (,) (FL.take 5 FL.sum) FL.length) $ S.fromList ls
|
||||
let v2 = Prelude.sum (Prelude.take 5 ls)
|
||||
v3 = Prelude.length (Prelude.take 5 ls)
|
||||
assert (v1 == (v2, v3))
|
||||
|
||||
|
||||
teeWithMinLength2 :: Property
|
||||
teeWithMinLength2 =
|
||||
forAll (listOf1 (chooseInt (intMin, intMax)))
|
||||
$ \ls0 -> monadicIO $ action ls0
|
||||
|
||||
where
|
||||
|
||||
action ls = do
|
||||
v1 <- run $ S.fold (F.teeWithMin (,) FL.sum (FL.take 5 FL.length)) $ S.fromList ls
|
||||
let v2 = Prelude.sum (Prelude.take 5 ls)
|
||||
v3 = Prelude.length (Prelude.take 5 ls)
|
||||
assert (v1 == (v2, v3))
|
||||
teeWithMax :: Property
|
||||
teeWithMax =
|
||||
forAll (listOf1 (chooseInt (intMin, intMax)))
|
||||
@ -451,23 +546,6 @@ headAndRest ls = monadicIO $ do
|
||||
taill [] = []
|
||||
taill (_:xs) = xs
|
||||
|
||||
partitionByM :: Property
|
||||
partitionByM =
|
||||
forAll (listOf1 (chooseInt (intMin, intMax)))
|
||||
$ \ls0 -> monadicIO $ action ls0
|
||||
|
||||
where
|
||||
|
||||
action ls = do
|
||||
let f = \x -> if odd x then return (Left x) else return (Right x)
|
||||
v1 <-
|
||||
run
|
||||
$ S.fold (F.partitionByM f FL.length FL.length)
|
||||
$ S.fromList ls
|
||||
let v2 = Prelude.length $ filter odd ls
|
||||
v3 = Prelude.length $ filter even ls
|
||||
assert (v1 == (v2, v3))
|
||||
|
||||
demux :: Expectation
|
||||
demux =
|
||||
let table = Data.Map.fromList [("SUM", FL.sum), ("PRODUCT", FL.product)]
|
||||
@ -667,7 +745,14 @@ main = hspec $ do
|
||||
-- Distributing
|
||||
-- tee
|
||||
prop "teeWithLength" Main.teeWithLength
|
||||
prop "teeWithFstLength" Main.teeWithFstLength
|
||||
prop "teeWithMinLength1" Main.teeWithMinLength1
|
||||
prop "teeWithMinLength2" Main.teeWithMinLength2
|
||||
prop "teeWithMax" Main.teeWithMax
|
||||
prop "partitionByM" Main.partitionByM
|
||||
prop "partitionByFstM" Main.partitionByFstM
|
||||
prop "partitionByMinM1" Main.partitionByMinM1
|
||||
prop "partitionByMinM2" Main.partitionByMinM2
|
||||
prop "distribute" Main.distribute
|
||||
|
||||
-- Partitioning
|
||||
|
||||
Loading…
Reference in New Issue
Block a user