{-# LANGUAGE BangPatterns #-}
module HaskellWorks.Control.Monad.Lazy
( interleaveSequenceIO
, interleaveSequenceM
, interleaveUnfoldrM
, interleaveTraverseM
, interleaveForM
, forceM
) where
import Control.DeepSeq
import Control.Monad
import Control.Monad.IO.Unlift
import qualified System.IO.Unsafe as IO
interleaveSequenceIO :: [IO a] -> IO [a]
interleaveSequenceIO :: forall a. [IO a] -> IO [a]
interleaveSequenceIO [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
interleaveSequenceIO (IO a
fa:[IO a]
fas) = do
a
a <- IO a
fa
[a]
as <- forall a. IO a -> IO a
IO.unsafeInterleaveIO (forall a. [IO a] -> IO [a]
interleaveSequenceIO [IO a]
fas)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
aforall a. a -> [a] -> [a]
:[a]
as)
interleaveSequenceM :: MonadUnliftIO m => [m a] -> m [a]
interleaveSequenceM :: forall (m :: * -> *) a. MonadUnliftIO m => [m a] -> m [a]
interleaveSequenceM [m a]
as = do
UnliftIO m
f <- forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
askUnliftIO
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. [IO a] -> IO [a]
interleaveSequenceIO (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO m
f) [m a]
as)
interleaveUnfoldrM :: MonadUnliftIO m => (b -> m (Maybe (a, b))) -> b -> m [a]
interleaveUnfoldrM :: forall (m :: * -> *) b a.
MonadUnliftIO m =>
(b -> m (Maybe (a, b))) -> b -> m [a]
interleaveUnfoldrM b -> m (Maybe (a, b))
f b
z = do
UnliftIO m
u <- forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
askUnliftIO
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
IO.unsafeInterleaveIO (UnliftIO m -> b -> IO [a]
go UnliftIO m
u b
z)
where
go :: UnliftIO m -> b -> IO [a]
go !UnliftIO m
u !b
b = do
Maybe (a, b)
m <- forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO m
u (b -> m (Maybe (a, b))
f b
b)
case Maybe (a, b)
m of
Maybe (a, b)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
Just (!a
a, b
b') -> do
[a]
rest <- forall a. IO a -> IO a
IO.unsafeInterleaveIO (UnliftIO m -> b -> IO [a]
go UnliftIO m
u b
b')
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
aforall a. a -> [a] -> [a]
:[a]
rest)
interleaveTraverseM :: MonadUnliftIO m => (a -> m b) -> [a] -> m [b]
interleaveTraverseM :: forall (m :: * -> *) a b.
MonadUnliftIO m =>
(a -> m b) -> [a] -> m [b]
interleaveTraverseM a -> m b
f [a]
as = do
UnliftIO m
u <- forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
askUnliftIO
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
IO.unsafeInterleaveIO (UnliftIO m -> [a] -> IO [b]
go UnliftIO m
u [a]
as)
where
go :: UnliftIO m -> [a] -> IO [b]
go UnliftIO m
_ [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
go !UnliftIO m
u (a
v:[a]
vs) = do
!b
res <- forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO m
u (a -> m b
f a
v)
[b]
rest <- forall a. IO a -> IO a
IO.unsafeInterleaveIO (UnliftIO m -> [a] -> IO [b]
go UnliftIO m
u [a]
vs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b
resforall a. a -> [a] -> [a]
:[b]
rest)
interleaveForM :: MonadUnliftIO m => [a] -> (a -> m b) -> m [b]
interleaveForM :: forall (m :: * -> *) a b.
MonadUnliftIO m =>
[a] -> (a -> m b) -> m [b]
interleaveForM = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a b.
MonadUnliftIO m =>
(a -> m b) -> [a] -> m [b]
interleaveTraverseM
forceM :: (Monad m, NFData a) => m a -> m a
forceM :: forall (m :: * -> *) a. (Monad m, NFData a) => m a -> m a
forceM = (forall a. NFData a => a -> a
force forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!>)