mirror of
https://github.com/composewell/streamly.git
synced 2024-09-11 11:37:22 +03:00
Add Monad instance for Unfold
This commit is contained in:
Harendra Kumar
parent
4f9fc7d2c9
commit
77d11d37bb
@ -18,14 +18,6 @@ concatCount :: Int -> Int
|
||||
concatCount linearCount =
|
||||
round (((1 + 8 * fromIntegral linearCount)**(1/2::Double) - 1) / 2)
|
||||
|
||||
-- double nested loop
|
||||
nestedCount2 :: Int -> Int
|
||||
nestedCount2 linearCount = round (fromIntegral linearCount**(1/2::Double))
|
||||
|
||||
-- triple nested loop
|
||||
nestedCount3 :: Int -> Int
|
||||
nestedCount3 linearCount = round (fromIntegral linearCount**(1/3::Double))
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Stream generation and elimination
|
||||
-------------------------------------------------------------------------------
|
||||
@ -39,26 +31,6 @@ source n = UF.enumerateFromToIntegral n
|
||||
-- Benchmark ops
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
{-# INLINE toNull #-}
|
||||
toNull :: MonadIO m => Int -> Int -> m ()
|
||||
toNull linearCount start = do
|
||||
let end = start + nestedCount2 linearCount
|
||||
UF.fold
|
||||
(UF.map (\(x, y) -> x + y)
|
||||
$ UF.outerProduct (source end) (source end))
|
||||
FL.drain (start, start)
|
||||
|
||||
{-# INLINE toNull3 #-}
|
||||
toNull3 :: MonadIO m => Int -> Int -> m ()
|
||||
toNull3 linearCount start = do
|
||||
let end = start + nestedCount3 linearCount
|
||||
UF.fold
|
||||
(UF.map (\(x, y) -> x + y)
|
||||
$ UF.outerProduct (source end)
|
||||
((UF.map (\(x, y) -> x + y)
|
||||
$ UF.outerProduct (source end) (source end))))
|
||||
FL.drain (start, (start, start))
|
||||
|
||||
{-# INLINE concat #-}
|
||||
concat :: MonadIO m => Int -> Int -> m ()
|
||||
concat linearCount start = do
|
||||
@ -66,61 +38,3 @@ concat linearCount start = do
|
||||
UF.fold
|
||||
(UF.concat (source end) (source end))
|
||||
FL.drain start
|
||||
|
||||
{-# INLINE toList #-}
|
||||
toList :: MonadIO m => Int -> Int -> m [Int]
|
||||
toList linearCount start = do
|
||||
let end = start + nestedCount2 linearCount
|
||||
UF.fold
|
||||
(UF.map (\(x, y) -> x + y)
|
||||
$ UF.outerProduct (source end) (source end))
|
||||
FL.toList (start, start)
|
||||
|
||||
{-# INLINE toListSome #-}
|
||||
toListSome :: MonadIO m => Int -> Int -> m [Int]
|
||||
toListSome linearCount start = do
|
||||
let end = start + nestedCount2 linearCount
|
||||
UF.fold
|
||||
(UF.take 1000 $ (UF.map (\(x, y) -> x + y)
|
||||
$ UF.outerProduct (source end) (source end)))
|
||||
FL.toList (start, start)
|
||||
|
||||
{-# INLINE filterAllOut #-}
|
||||
filterAllOut :: MonadIO m => Int -> Int -> m ()
|
||||
filterAllOut linearCount start = do
|
||||
let end = start + nestedCount2 linearCount
|
||||
UF.fold
|
||||
(UF.filter (< 0)
|
||||
$ UF.map (\(x, y) -> x + y)
|
||||
$ UF.outerProduct (source end) (source end))
|
||||
FL.drain (start, start)
|
||||
|
||||
{-# INLINE filterAllIn #-}
|
||||
filterAllIn :: MonadIO m => Int -> Int -> m ()
|
||||
filterAllIn linearCount start = do
|
||||
let end = start + nestedCount2 linearCount
|
||||
UF.fold
|
||||
(UF.filter (> 0)
|
||||
$ UF.map (\(x, y) -> x + y)
|
||||
$ UF.outerProduct (source end) (source end))
|
||||
FL.drain (start, start)
|
||||
|
||||
{-# INLINE filterSome #-}
|
||||
filterSome :: MonadIO m => Int -> Int -> m ()
|
||||
filterSome linearCount start = do
|
||||
let end = start + nestedCount2 linearCount
|
||||
UF.fold
|
||||
(UF.filter (> 1100000)
|
||||
$ UF.map (\(x, y) -> x + y)
|
||||
$ UF.outerProduct (source end) (source end))
|
||||
FL.drain (start, start)
|
||||
|
||||
{-# INLINE breakAfterSome #-}
|
||||
breakAfterSome :: MonadIO m => Int -> Int -> m ()
|
||||
breakAfterSome linearCount start = do
|
||||
let end = start + nestedCount2 linearCount
|
||||
UF.fold
|
||||
(UF.takeWhile (<= 1100000)
|
||||
$ UF.map (\(x, y) -> x + y)
|
||||
$ UF.outerProduct (source end) (source end))
|
||||
FL.drain (start, start)
|
||||
|
||||
@ -20,7 +20,7 @@
|
||||
module Main (main) where
|
||||
|
||||
import Control.DeepSeq (NFData(..))
|
||||
import Control.Exception (SomeException)
|
||||
import Control.Exception (SomeException, ErrorCall, try)
|
||||
import Streamly.Internal.Data.Unfold (Unfold)
|
||||
import System.IO (Handle, hClose)
|
||||
import System.Random (randomRIO)
|
||||
@ -397,29 +397,13 @@ teeZipWith size start =
|
||||
drainProductDefault (size + start) (UF.teeZipWith (+)) start
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Nested
|
||||
-- Applicative
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
{-# INLINE concatMapM #-}
|
||||
concatMapM :: Monad m => Int -> Int -> m ()
|
||||
concatMapM size start =
|
||||
drainGeneration (UF.concatMapM unfoldInGen unfoldOut) start
|
||||
|
||||
where
|
||||
|
||||
sizeOuter = 100
|
||||
sizeInner = size `div` sizeOuter
|
||||
|
||||
unfoldInGen i =
|
||||
return
|
||||
$ UF.supply (UF.enumerateFromToIntegral (i + sizeInner)) i
|
||||
|
||||
unfoldOut = UF.enumerateFromToIntegral (start + sizeOuter)
|
||||
|
||||
{-# INLINE toNullAp #-}
|
||||
toNullAp :: Monad m => Int -> Int -> m ()
|
||||
toNullAp linearCount start =
|
||||
let end = start + Nested.nestedCount2 linearCount
|
||||
toNullAp value start =
|
||||
let end = start + nthRoot 2 value
|
||||
s = Nested.source end
|
||||
in UF.fold ((+) <$> s <*> s) FL.drain start
|
||||
|
||||
@ -431,6 +415,128 @@ _apDiscardFst = undefined
|
||||
_apDiscardSnd :: Int -> Int -> m ()
|
||||
_apDiscardSnd = undefined
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Monad
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
nthRoot :: Double -> Int -> Int
|
||||
nthRoot n value = round (fromIntegral value**(1/n))
|
||||
|
||||
{-# INLINE concatMapM #-}
|
||||
concatMapM :: Monad m => Int -> Int -> m ()
|
||||
concatMapM value start =
|
||||
val `seq` drainGeneration (UF.concatMapM unfoldInGen unfoldOut) start
|
||||
|
||||
where
|
||||
|
||||
val = nthRoot 2 value
|
||||
unfoldInGen i = return (UF.enumerateFromToIntegral (i + val))
|
||||
unfoldOut = UF.enumerateFromToIntegral (start + val)
|
||||
|
||||
{-# INLINE toNull #-}
|
||||
toNull :: Monad m => Int -> Int -> m ()
|
||||
toNull value start =
|
||||
let end = start + nthRoot 2 value
|
||||
src = Nested.source end
|
||||
u = do
|
||||
x <- src
|
||||
y <- src
|
||||
return (x + y)
|
||||
in UF.fold u FL.drain start
|
||||
|
||||
|
||||
{-# INLINE toNull3 #-}
|
||||
toNull3 :: Monad m => Int -> Int -> m ()
|
||||
toNull3 value start =
|
||||
let end = start + nthRoot 3 value
|
||||
src = Nested.source end
|
||||
u = do
|
||||
x <- src
|
||||
y <- src
|
||||
z <- src
|
||||
return (x + y + z)
|
||||
in UF.fold u FL.drain start
|
||||
|
||||
{-# INLINE toList #-}
|
||||
toList :: Monad m => Int -> Int -> m [Int]
|
||||
toList value start = do
|
||||
let end = start + nthRoot 2 value
|
||||
src = Nested.source end
|
||||
u = do
|
||||
x <- src
|
||||
y <- src
|
||||
return (x + y)
|
||||
in UF.fold u FL.toList start
|
||||
|
||||
{-# INLINE toListSome #-}
|
||||
toListSome :: Monad m => Int -> Int -> m [Int]
|
||||
toListSome value start = do
|
||||
let end = start + nthRoot 2 value
|
||||
src = Nested.source end
|
||||
u = do
|
||||
x <- src
|
||||
y <- src
|
||||
return (x + y)
|
||||
in UF.fold (UF.take 1000 u) FL.toList start
|
||||
|
||||
{-# INLINE filterAllOut #-}
|
||||
filterAllOut :: Monad m => Int -> Int -> m ()
|
||||
filterAllOut value start = do
|
||||
let end = start + nthRoot 2 value
|
||||
src = Nested.source end
|
||||
u = do
|
||||
x <- src
|
||||
y <- src
|
||||
let s = x + y
|
||||
if s < 0
|
||||
then return s
|
||||
else UF.nilM (return . const ())
|
||||
in UF.fold u FL.drain start
|
||||
|
||||
{-# INLINE filterAllIn #-}
|
||||
filterAllIn :: Monad m => Int -> Int -> m ()
|
||||
filterAllIn value start = do
|
||||
let end = start + nthRoot 2 value
|
||||
src = Nested.source end
|
||||
u = do
|
||||
x <- src
|
||||
y <- src
|
||||
let s = x + y
|
||||
if s > 0
|
||||
then return s
|
||||
else UF.nilM (return . const ())
|
||||
in UF.fold u FL.drain start
|
||||
|
||||
{-# INLINE filterSome #-}
|
||||
filterSome :: Monad m => Int -> Int -> m ()
|
||||
filterSome value start = do
|
||||
let end = start + nthRoot 2 value
|
||||
src = Nested.source end
|
||||
u = do
|
||||
x <- src
|
||||
y <- src
|
||||
let s = x + y
|
||||
if s > 1100000
|
||||
then return s
|
||||
else UF.nilM (return . const ())
|
||||
in UF.fold u FL.drain start
|
||||
|
||||
{-# INLINE breakAfterSome #-}
|
||||
breakAfterSome :: Int -> Int -> IO ()
|
||||
breakAfterSome value start =
|
||||
let end = start + nthRoot 2 value
|
||||
src = Nested.source end
|
||||
u = do
|
||||
x <- src
|
||||
y <- src
|
||||
let s = x + y
|
||||
if s > 1100000
|
||||
then error "break"
|
||||
else return s
|
||||
in do
|
||||
(_ :: Either ErrorCall ()) <- try $ UF.fold u FL.drain start
|
||||
return ()
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Benchmarks
|
||||
-------------------------------------------------------------------------------
|
||||
@ -529,29 +635,30 @@ o_1_space_zip size =
|
||||
o_1_space_nested :: Int -> [Benchmark]
|
||||
o_1_space_nested size =
|
||||
[ bgroup
|
||||
"outer-product"
|
||||
[ benchIO "toNullAp" $ toNullAp size
|
||||
, benchIO "toNull" $ Nested.toNull size
|
||||
, benchIO "toNull3" $ Nested.toNull3 size
|
||||
, benchIO "concat" $ Nested.concat size
|
||||
, benchIO "breakAfterSome" $ Nested.breakAfterSome size
|
||||
, benchIO "filterAllOut" $ Nested.filterAllOut size
|
||||
, benchIO "filterAllIn" $ Nested.filterAllIn size
|
||||
, benchIO "filterSome" $ Nested.filterSome size
|
||||
, benchIO "concatMapM (100 x n/100)" $ concatMapM size
|
||||
"nested"
|
||||
[ benchIO "(<*>) (sqrt n x sqrt n)" $ toNullAp size
|
||||
-- Unimplemented
|
||||
-- , benchIO "ap" $ ap size
|
||||
-- , benchIO "apDiscardFst" $ apDiscardFst size
|
||||
-- , benchIO "apDiscardSnd" $ apDiscardSnd size
|
||||
|
||||
, benchIO "concatMapM (sqrt n x sqrt n)" $ concatMapM size
|
||||
, benchIO "(>>=) (sqrt n x sqrt n)" $ toNull size
|
||||
, benchIO "(>>=) (cubert n x cubert n x cubert n)" $ toNull3 size
|
||||
, benchIO "breakAfterSome" $ breakAfterSome size
|
||||
, benchIO "filterAllOut" $ filterAllOut size
|
||||
, benchIO "filterAllIn" $ filterAllIn size
|
||||
, benchIO "filterSome" $ filterSome size
|
||||
|
||||
, benchIO "concat" $ Nested.concat size
|
||||
]
|
||||
]
|
||||
|
||||
o_n_space_nested :: Int -> [Benchmark]
|
||||
o_n_space_nested size =
|
||||
[ bgroup
|
||||
"outer-product"
|
||||
[ benchIO "toList" $ Nested.toList size
|
||||
, benchIO "toListSome" $ Nested.toListSome size
|
||||
"nested"
|
||||
[ benchIO "toList" $ toList size
|
||||
, benchIO "toListSome" $ toListSome size
|
||||
]
|
||||
]
|
||||
|
||||
|
||||
@ -156,7 +156,8 @@ import Streamly.Internal.Data.IOFinalizer
|
||||
(newIOFinalizer, runIOFinalizer, clearingIOFinalizer)
|
||||
import Streamly.Internal.Data.Stream.StreamD.Type (Stream(..), Step(..))
|
||||
import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime)
|
||||
import Streamly.Internal.Data.Unfold.Types (Unfold(..), lmap, map, const)
|
||||
import Streamly.Internal.Data.Unfold.Types
|
||||
(Unfold(..), lmap, map, const, concatMapM)
|
||||
import System.Mem (performMajorGC)
|
||||
|
||||
import qualified Prelude
|
||||
@ -973,41 +974,6 @@ outerProduct (Unfold step1 inject1) (Unfold step2 inject2) = Unfold step inject
|
||||
Skip s -> Skip (OuterProductInner ost sy s x)
|
||||
Stop -> Skip (OuterProductOuter ost sy)
|
||||
|
||||
-- XXX This can be used to implement a Monad instance for "Unfold m ()".
|
||||
|
||||
data ConcatMapState s1 s2 = ConcatMapOuter s1 | ConcatMapInner s1 s2
|
||||
|
||||
-- | Map an unfold generating action to each element of an unfold and
|
||||
-- flatten the results into a single stream.
|
||||
--
|
||||
{-# INLINE_NORMAL concatMapM #-}
|
||||
concatMapM :: Monad m
|
||||
=> (b -> m (Unfold m Void c)) -> Unfold m a b -> Unfold m a c
|
||||
concatMapM f (Unfold step1 inject1) = Unfold step inject
|
||||
where
|
||||
inject x = do
|
||||
s <- inject1 x
|
||||
return $ ConcatMapOuter s
|
||||
|
||||
{-# INLINE_LATE step #-}
|
||||
step (ConcatMapOuter st) = do
|
||||
r <- step1 st
|
||||
case r of
|
||||
Yield x s -> do
|
||||
Unfold step2 inject2 <- f x
|
||||
innerSt <- inject2 undefined
|
||||
return $ Skip (ConcatMapInner s (Stream (\_ ss -> step2 ss)
|
||||
innerSt))
|
||||
Skip s -> return $ Skip (ConcatMapOuter s)
|
||||
Stop -> return Stop
|
||||
|
||||
step (ConcatMapInner ost (UnStream istep ist)) = do
|
||||
r <- istep defState ist
|
||||
return $ case r of
|
||||
Yield x s -> Yield x (ConcatMapInner ost (Stream istep s))
|
||||
Skip s -> Skip (ConcatMapInner ost (Stream istep s))
|
||||
Stop -> Skip (ConcatMapOuter ost)
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- Exceptions
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
@ -14,6 +14,8 @@ module Streamly.Internal.Data.Unfold.Types
|
||||
, apSequence
|
||||
, apDiscardSnd
|
||||
, cross
|
||||
, concatMapM
|
||||
, concatMap
|
||||
)
|
||||
where
|
||||
|
||||
@ -21,7 +23,7 @@ where
|
||||
|
||||
import Streamly.Internal.Data.Stream.StreamD.Step (Step(..))
|
||||
|
||||
import Prelude hiding (const, map)
|
||||
import Prelude hiding (const, map, concatMap)
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- Monadic Unfolds
|
||||
@ -150,3 +152,67 @@ instance Monad m => Applicative (Unfold m a) where
|
||||
|
||||
-- {-# INLINE (<*) #-}
|
||||
-- (<*) = apDiscardSnd
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- Monad
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
data ConcatMapState m b s1 x =
|
||||
ConcatMapOuter x s1
|
||||
| forall s2. ConcatMapInner x s1 s2 (s2 -> m (Step s2 b))
|
||||
|
||||
-- | Map an unfold generating action to each element of an unfold and
|
||||
-- flatten the results into a single stream.
|
||||
--
|
||||
{-# INLINE_NORMAL concatMapM #-}
|
||||
concatMapM :: Monad m
|
||||
=> (b -> m (Unfold m a c)) -> Unfold m a b -> Unfold m a c
|
||||
concatMapM f (Unfold step1 inject1) = Unfold step inject
|
||||
|
||||
where
|
||||
|
||||
inject x = do
|
||||
s <- inject1 x
|
||||
return $ ConcatMapOuter x s
|
||||
|
||||
{-# INLINE_LATE step #-}
|
||||
step (ConcatMapOuter seed st) = do
|
||||
r <- step1 st
|
||||
case r of
|
||||
Yield x s -> do
|
||||
Unfold step2 inject2 <- f x
|
||||
innerSt <- inject2 seed
|
||||
return $ Skip (ConcatMapInner seed s innerSt step2)
|
||||
Skip s -> return $ Skip (ConcatMapOuter seed s)
|
||||
Stop -> return Stop
|
||||
|
||||
step (ConcatMapInner seed ost ist istep) = do
|
||||
r <- istep ist
|
||||
return $ case r of
|
||||
Yield x s -> Yield x (ConcatMapInner seed ost s istep)
|
||||
Skip s -> Skip (ConcatMapInner seed ost s istep)
|
||||
Stop -> Skip (ConcatMapOuter seed ost)
|
||||
|
||||
{-# INLINE concatMap #-}
|
||||
concatMap :: Monad m => (b -> Unfold m a c) -> Unfold m a b -> Unfold m a c
|
||||
concatMap f = concatMapM (return . f)
|
||||
|
||||
-- Note: concatMap and Monad instance for unfolds have performance comparable
|
||||
-- to Stream. In fact, concatMap is slower than Stream, that may be some
|
||||
-- optimization issue though.
|
||||
--
|
||||
-- | Example:
|
||||
--
|
||||
-- >>> u = do { x <- Unfold.lmap fst Unfold.fromList; y <- Unfold.lmap snd Unfold.fromList; return (x,y); }
|
||||
-- >>> Stream.toList $ Stream.unfold u ([1,2],[3,4])
|
||||
-- [(1,3),(1,4),(2,3),(2,4)]
|
||||
--
|
||||
instance Monad m => Monad (Unfold m a) where
|
||||
{-# INLINE return #-}
|
||||
return = pure
|
||||
|
||||
{-# INLINE (>>=) #-}
|
||||
(>>=) = flip concatMap
|
||||
|
||||
-- {-# INLINE (>>) #-}
|
||||
-- (>>) = (*>)
|
||||
|
||||
@ -347,14 +347,11 @@ outerProduct =
|
||||
|
||||
concatMapM :: Bool
|
||||
concatMapM =
|
||||
let unfInF b =
|
||||
modify (+ 1)
|
||||
>> return
|
||||
(UF.supply (UF.replicateM 10) (modify (+ 1) >> return b))
|
||||
listInF b = replicate 10 b
|
||||
unfOut = UF.enumerateFromToIntegral 10
|
||||
unf = UF.concatMapM unfInF unfOut
|
||||
list = List.concatMap listInF [1 .. 10]
|
||||
let inner b =
|
||||
let u = UF.lmap (\_ -> modify (+ 1) >> return b) (UF.replicateM 10)
|
||||
in modify (+ 1) >> return u
|
||||
unf = UF.concatMapM inner (UF.enumerateFromToIntegral 10)
|
||||
list = List.concatMap (replicate 10) [1 .. 10]
|
||||
in testUnfoldMD unf 1 0 110 list
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
Loading…
Reference in New Issue
Block a user