{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-inline-rule-shadowing #-}
module Foundation.Conduit.Internal
( Pipe(..)
, Conduit(..)
, ZipSink(..)
, ResourceT(..)
, MonadResource(..)
, runResourceT
, await
, awaitForever
, yield
, yieldOr
, leftover
, runConduit
, runConduitRes
, runConduitPure
, fuse
, bracketConduit
) where
import Basement.Imports hiding (throw)
import Foundation.Monad
import Foundation.Numerical
import Basement.Monad
import Control.Monad ((>=>), liftM, void, mapM_, join)
import Control.Exception (SomeException, mask_)
import Data.IORef (atomicModifyIORef)
data Pipe leftOver input output upstream monad result =
Yield (Pipe leftOver input output upstream monad result) (monad ()) output
| Await (input -> Pipe leftOver input output upstream monad result)
(upstream -> Pipe leftOver input output upstream monad result)
| Done result
| PipeM (monad (Pipe leftOver input output upstream monad result))
| Leftover (Pipe leftOver input output upstream monad result) leftOver
instance Applicative m => Functor (Pipe l i o u m) where
fmap :: forall a b. (a -> b) -> Pipe l i o u m a -> Pipe l i o u m b
fmap = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
(<$>)
{-# INLINE fmap #-}
instance Applicative m => Applicative (Pipe l i o u m) where
pure :: forall a. a -> Pipe l i o u m a
pure = forall leftOver input output upstream (monad :: * -> *) result.
result -> Pipe leftOver input output upstream monad result
Done
{-# INLINE pure #-}
Yield Pipe l i o u m (a -> b)
p m ()
c o
o <*> :: forall a b.
Pipe l i o u m (a -> b) -> Pipe l i o u m a -> Pipe l i o u m b
<*> Pipe l i o u m a
fa = forall leftOver input output upstream (monad :: * -> *) result.
Pipe leftOver input output upstream monad result
-> monad ()
-> output
-> Pipe leftOver input output upstream monad result
Yield (Pipe l i o u m (a -> b)
p forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pipe l i o u m a
fa) m ()
c o
o
Await i -> Pipe l i o u m (a -> b)
p u -> Pipe l i o u m (a -> b)
c <*> Pipe l i o u m a
fa = forall leftOver input output upstream (monad :: * -> *) result.
(input -> Pipe leftOver input output upstream monad result)
-> (upstream -> Pipe leftOver input output upstream monad result)
-> Pipe leftOver input output upstream monad result
Await (\i
i -> i -> Pipe l i o u m (a -> b)
p i
i forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pipe l i o u m a
fa) (\u
o -> u -> Pipe l i o u m (a -> b)
c u
o forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pipe l i o u m a
fa)
Done a -> b
r <*> Pipe l i o u m a
fa = a -> b
r forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pipe l i o u m a
fa
PipeM m (Pipe l i o u m (a -> b))
mp <*> Pipe l i o u m a
fa = forall leftOver input output upstream (monad :: * -> *) result.
monad (Pipe leftOver input output upstream monad result)
-> Pipe leftOver input output upstream monad result
PipeM ((forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pipe l i o u m a
fa) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Pipe l i o u m (a -> b))
mp)
Leftover Pipe l i o u m (a -> b)
p l
i <*> Pipe l i o u m a
fa = forall leftOver input output upstream (monad :: * -> *) result.
Pipe leftOver input output upstream monad result
-> leftOver -> Pipe leftOver input output upstream monad result
Leftover (Pipe l i o u m (a -> b)
p forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pipe l i o u m a
fa) l
i
{-# INLINE (<*>) #-}
instance (Functor m, Monad m) => Monad (Pipe l i o u m) where
return :: forall a. a -> Pipe l i o u m a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE return #-}
Yield Pipe l i o u m a
p m ()
c o
o >>= :: forall a b.
Pipe l i o u m a -> (a -> Pipe l i o u m b) -> Pipe l i o u m b
>>= a -> Pipe l i o u m b
fp = forall leftOver input output upstream (monad :: * -> *) result.
Pipe leftOver input output upstream monad result
-> monad ()
-> output
-> Pipe leftOver input output upstream monad result
Yield (Pipe l i o u m a
p forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Pipe l i o u m b
fp) m ()
c o
o
Await i -> Pipe l i o u m a
p u -> Pipe l i o u m a
c >>= a -> Pipe l i o u m b
fp = forall leftOver input output upstream (monad :: * -> *) result.
(input -> Pipe leftOver input output upstream monad result)
-> (upstream -> Pipe leftOver input output upstream monad result)
-> Pipe leftOver input output upstream monad result
Await (i -> Pipe l i o u m a
p forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> a -> Pipe l i o u m b
fp) (u -> Pipe l i o u m a
c forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> a -> Pipe l i o u m b
fp)
Done a
x >>= a -> Pipe l i o u m b
fp = a -> Pipe l i o u m b
fp a
x
PipeM m (Pipe l i o u m a)
mp >>= a -> Pipe l i o u m b
fp = forall leftOver input output upstream (monad :: * -> *) result.
monad (Pipe leftOver input output upstream monad result)
-> Pipe leftOver input output upstream monad result
PipeM ((forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Pipe l i o u m b
fp) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Pipe l i o u m a)
mp)
Leftover Pipe l i o u m a
p l
i >>= a -> Pipe l i o u m b
fp = forall leftOver input output upstream (monad :: * -> *) result.
Pipe leftOver input output upstream monad result
-> leftOver -> Pipe leftOver input output upstream monad result
Leftover (Pipe l i o u m a
p forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Pipe l i o u m b
fp) l
i
newtype Conduit input output monad result = Conduit
{ forall input output (monad :: * -> *) result.
Conduit input output monad result
-> forall a.
(result -> Pipe input input output () monad a)
-> Pipe input input output () monad a
unConduit :: forall a . (result -> Pipe input input output () monad a) -> Pipe input input output () monad a
}
instance Functor (Conduit i o m) where
fmap :: forall a b. (a -> b) -> Conduit i o m a -> Conduit i o m b
fmap a -> b
f (Conduit forall a. (a -> Pipe i i o () m a) -> Pipe i i o () m a
c) = forall input output (monad :: * -> *) result.
(forall a.
(result -> Pipe input input output () monad a)
-> Pipe input input output () monad a)
-> Conduit input output monad result
Conduit forall a b. (a -> b) -> a -> b
$ \b -> Pipe i i o () m a
resPipe -> forall a. (a -> Pipe i i o () m a) -> Pipe i i o () m a
c (b -> Pipe i i o () m a
resPipe forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> b
f)
instance Applicative (Conduit i o m) where
pure :: forall a. a -> Conduit i o m a
pure a
x = forall input output (monad :: * -> *) result.
(forall a.
(result -> Pipe input input output () monad a)
-> Pipe input input output () monad a)
-> Conduit input output monad result
Conduit (forall a b. (a -> b) -> a -> b
$ a
x)
{-# INLINE pure #-}
Conduit i o m (a -> b)
fab <*> :: forall a b.
Conduit i o m (a -> b) -> Conduit i o m a -> Conduit i o m b
<*> Conduit i o m a
fa = Conduit i o m (a -> b)
fab forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a -> b
ab -> Conduit i o m a
fa forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> b
ab a
a)
{-# INLINE (<*>) #-}
instance Monad (Conduit i o m) where
return :: forall a. a -> Conduit i o m a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
Conduit forall a. (a -> Pipe i i o () m a) -> Pipe i i o () m a
f >>= :: forall a b.
Conduit i o m a -> (a -> Conduit i o m b) -> Conduit i o m b
>>= a -> Conduit i o m b
g = forall input output (monad :: * -> *) result.
(forall a.
(result -> Pipe input input output () monad a)
-> Pipe input input output () monad a)
-> Conduit input output monad result
Conduit forall a b. (a -> b) -> a -> b
$ \b -> Pipe i i o () m a
h -> forall a. (a -> Pipe i i o () m a) -> Pipe i i o () m a
f forall a b. (a -> b) -> a -> b
$ \a
a -> forall input output (monad :: * -> *) result.
Conduit input output monad result
-> forall a.
(result -> Pipe input input output () monad a)
-> Pipe input input output () monad a
unConduit (a -> Conduit i o m b
g a
a) b -> Pipe i i o () m a
h
instance MonadTrans (Conduit i o) where
lift :: forall (m :: * -> *) a. Monad m => m a -> Conduit i o m a
lift m a
m = forall input output (monad :: * -> *) result.
(forall a.
(result -> Pipe input input output () monad a)
-> Pipe input input output () monad a)
-> Conduit input output monad result
Conduit forall a b. (a -> b) -> a -> b
$ \a -> Pipe i i o () m a
rest -> forall leftOver input output upstream (monad :: * -> *) result.
monad (Pipe leftOver input output upstream monad result)
-> Pipe leftOver input output upstream monad result
PipeM forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> Pipe i i o () m a
rest m a
m
instance MonadIO m => MonadIO (Conduit i o m) where
liftIO :: forall a. IO a -> Conduit i o m a
liftIO = forall (trans :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans trans, Monad m) =>
m a -> trans m a
lift forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
instance MonadFailure m => MonadFailure (Conduit i o m) where
type Failure (Conduit i o m) = Failure m
mFail :: Failure (Conduit i o m) -> Conduit i o m ()
mFail = forall (trans :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans trans, Monad m) =>
m a -> trans m a
lift forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (m :: * -> *). MonadFailure m => Failure m -> m ()
mFail
instance MonadThrow m => MonadThrow (Conduit i o m) where
throw :: forall e a. Exception e => e -> Conduit i o m a
throw = forall (trans :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans trans, Monad m) =>
m a -> trans m a
lift forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw
instance MonadCatch m => MonadCatch (Conduit i o m) where
catch :: forall e a.
Exception e =>
Conduit i o m a -> (e -> Conduit i o m a) -> Conduit i o m a
catch (Conduit forall a. (a -> Pipe i i o () m a) -> Pipe i i o () m a
c0) e -> Conduit i o m a
onExc = forall input output (monad :: * -> *) result.
(forall a.
(result -> Pipe input input output () monad a)
-> Pipe input input output () monad a)
-> Conduit input output monad result
Conduit forall a b. (a -> b) -> a -> b
$ \a -> Pipe i i o () m a
rest -> let
go :: Pipe i i o () m a -> Pipe i i o () m a
go (PipeM m (Pipe i i o () m a)
m) =
forall leftOver input output upstream (monad :: * -> *) result.
monad (Pipe leftOver input output upstream monad result)
-> Pipe leftOver input output upstream monad result
PipeM forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Pipe i i o () m a -> Pipe i i o () m a
go m (Pipe i i o () m a)
m) (\e
x -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall input output (monad :: * -> *) result.
Conduit input output monad result
-> forall a.
(result -> Pipe input input output () monad a)
-> Pipe input input output () monad a
unConduit (e -> Conduit i o m a
onExc e
x) a -> Pipe i i o () m a
rest)
go (Done a
r) = a -> Pipe i i o () m a
rest a
r
go (Await i -> Pipe i i o () m a
p () -> Pipe i i o () m a
c) = forall leftOver input output upstream (monad :: * -> *) result.
(input -> Pipe leftOver input output upstream monad result)
-> (upstream -> Pipe leftOver input output upstream monad result)
-> Pipe leftOver input output upstream monad result
Await (Pipe i i o () m a -> Pipe i i o () m a
go forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. i -> Pipe i i o () m a
p) (Pipe i i o () m a -> Pipe i i o () m a
go forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. () -> Pipe i i o () m a
c)
go (Yield Pipe i i o () m a
p m ()
m o
o) = forall leftOver input output upstream (monad :: * -> *) result.
Pipe leftOver input output upstream monad result
-> monad ()
-> output
-> Pipe leftOver input output upstream monad result
Yield (Pipe i i o () m a -> Pipe i i o () m a
go Pipe i i o () m a
p) m ()
m o
o
go (Leftover Pipe i i o () m a
p i
i) = forall leftOver input output upstream (monad :: * -> *) result.
Pipe leftOver input output upstream monad result
-> leftOver -> Pipe leftOver input output upstream monad result
Leftover (Pipe i i o () m a -> Pipe i i o () m a
go Pipe i i o () m a
p) i
i
in Pipe i i o () m a -> Pipe i i o () m a
go (forall a. (a -> Pipe i i o () m a) -> Pipe i i o () m a
c0 forall leftOver input output upstream (monad :: * -> *) result.
result -> Pipe leftOver input output upstream monad result
Done)
await :: Conduit i o m (Maybe i)
await :: forall i o (m :: * -> *). Conduit i o m (Maybe i)
await = forall input output (monad :: * -> *) result.
(forall a.
(result -> Pipe input input output () monad a)
-> Pipe input input output () monad a)
-> Conduit input output monad result
Conduit forall a b. (a -> b) -> a -> b
$ \Maybe i -> Pipe i i o () m a
f -> forall leftOver input output upstream (monad :: * -> *) result.
(input -> Pipe leftOver input output upstream monad result)
-> (upstream -> Pipe leftOver input output upstream monad result)
-> Pipe leftOver input output upstream monad result
Await (Maybe i -> Pipe i i o () m a
f forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. a -> Maybe a
Just) (forall a b. a -> b -> a
const (Maybe i -> Pipe i i o () m a
f forall a. Maybe a
Nothing))
{-# NOINLINE[1] await #-}
await' :: Conduit i o m r
-> (i -> Conduit i o m r)
-> Conduit i o m r
await' :: forall i o (m :: * -> *) r.
Conduit i o m r -> (i -> Conduit i o m r) -> Conduit i o m r
await' Conduit i o m r
f i -> Conduit i o m r
g = forall input output (monad :: * -> *) result.
(forall a.
(result -> Pipe input input output () monad a)
-> Pipe input input output () monad a)
-> Conduit input output monad result
Conduit forall a b. (a -> b) -> a -> b
$ \r -> Pipe i i o () m a
rest -> forall leftOver input output upstream (monad :: * -> *) result.
(input -> Pipe leftOver input output upstream monad result)
-> (upstream -> Pipe leftOver input output upstream monad result)
-> Pipe leftOver input output upstream monad result
Await
(\i
i -> forall input output (monad :: * -> *) result.
Conduit input output monad result
-> forall a.
(result -> Pipe input input output () monad a)
-> Pipe input input output () monad a
unConduit (i -> Conduit i o m r
g i
i) r -> Pipe i i o () m a
rest)
(forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall input output (monad :: * -> *) result.
Conduit input output monad result
-> forall a.
(result -> Pipe input input output () monad a)
-> Pipe input input output () monad a
unConduit Conduit i o m r
f r -> Pipe i i o () m a
rest)
{-# INLINE await' #-}
{-# RULES "conduit: await >>= maybe" [2] forall x y. await >>= maybe x y = await' x y #-}
awaitForever :: (input -> Conduit input output monad b) -> Conduit input output monad ()
awaitForever :: forall input output (monad :: * -> *) b.
(input -> Conduit input output monad b)
-> Conduit input output monad ()
awaitForever input -> Conduit input output monad b
f = forall input output (monad :: * -> *) result.
(forall a.
(result -> Pipe input input output () monad a)
-> Pipe input input output () monad a)
-> Conduit input output monad result
Conduit forall a b. (a -> b) -> a -> b
$ \() -> Pipe input input output () monad a
rest ->
let go :: Pipe input input output () monad a
go = forall leftOver input output upstream (monad :: * -> *) result.
(input -> Pipe leftOver input output upstream monad result)
-> (upstream -> Pipe leftOver input output upstream monad result)
-> Pipe leftOver input output upstream monad result
Await (\input
i -> forall input output (monad :: * -> *) result.
Conduit input output monad result
-> forall a.
(result -> Pipe input input output () monad a)
-> Pipe input input output () monad a
unConduit (input -> Conduit input output monad b
f input
i) (forall a b. a -> b -> a
const Pipe input input output () monad a
go)) () -> Pipe input input output () monad a
rest
in Pipe input input output () monad a
go
yield :: Monad m => o -> Conduit i o m ()
yield :: forall (m :: * -> *) o i. Monad m => o -> Conduit i o m ()
yield o
o = forall input output (monad :: * -> *) result.
(forall a.
(result -> Pipe input input output () monad a)
-> Pipe input input output () monad a)
-> Conduit input output monad result
Conduit forall a b. (a -> b) -> a -> b
$ \() -> Pipe i i o () m a
f -> forall leftOver input output upstream (monad :: * -> *) result.
Pipe leftOver input output upstream monad result
-> monad ()
-> output
-> Pipe leftOver input output upstream monad result
Yield (() -> Pipe i i o () m a
f ()) (forall (m :: * -> *) a. Monad m => a -> m a
return ()) o
o
yieldOr :: o
-> m ()
-> Conduit i o m ()
yieldOr :: forall o (m :: * -> *) i. o -> m () -> Conduit i o m ()
yieldOr o
o m ()
m = forall input output (monad :: * -> *) result.
(forall a.
(result -> Pipe input input output () monad a)
-> Pipe input input output () monad a)
-> Conduit input output monad result
Conduit forall a b. (a -> b) -> a -> b
$ \() -> Pipe i i o () m a
f -> forall leftOver input output upstream (monad :: * -> *) result.
Pipe leftOver input output upstream monad result
-> monad ()
-> output
-> Pipe leftOver input output upstream monad result
Yield (() -> Pipe i i o () m a
f ()) m ()
m o
o
leftover :: i -> Conduit i o m ()
leftover :: forall i o (m :: * -> *). i -> Conduit i o m ()
leftover i
i = forall input output (monad :: * -> *) result.
(forall a.
(result -> Pipe input input output () monad a)
-> Pipe input input output () monad a)
-> Conduit input output monad result
Conduit forall a b. (a -> b) -> a -> b
$ \() -> Pipe i i o () m a
f -> forall leftOver input output upstream (monad :: * -> *) result.
Pipe leftOver input output upstream monad result
-> leftOver -> Pipe leftOver input output upstream monad result
Leftover (() -> Pipe i i o () m a
f ()) i
i
runConduit :: Monad m => Conduit () () m r -> m r
runConduit :: forall (m :: * -> *) r. Monad m => Conduit () () m r -> m r
runConduit (Conduit forall a. (r -> Pipe () () () () m a) -> Pipe () () () () m a
f) = forall (m :: * -> *) r. Monad m => Pipe () () () () m r -> m r
runPipe (forall a. (r -> Pipe () () () () m a) -> Pipe () () () () m a
f forall leftOver input output upstream (monad :: * -> *) result.
result -> Pipe leftOver input output upstream monad result
Done)
runConduitPure :: Conduit () () Identity r -> r
runConduitPure :: forall r. Conduit () () Identity r -> r
runConduitPure = forall a. Identity a -> a
runIdentity forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (m :: * -> *) r. Monad m => Conduit () () m r -> m r
runConduit
runConduitRes :: (MonadBracket m, MonadIO m) => Conduit () () (ResourceT m) r -> m r
runConduitRes :: forall (m :: * -> *) r.
(MonadBracket m, MonadIO m) =>
Conduit () () (ResourceT m) r -> m r
runConduitRes = forall (m :: * -> *) a.
(MonadBracket m, MonadIO m) =>
ResourceT m a -> m a
runResourceT forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (m :: * -> *) r. Monad m => Conduit () () m r -> m r
runConduit
bracketConduit :: MonadResource m
=> IO a
-> (a -> IO b)
-> (a -> Conduit i o m r)
-> Conduit i o m r
bracketConduit :: forall (m :: * -> *) a b i o r.
MonadResource m =>
IO a -> (a -> IO b) -> (a -> Conduit i o m r) -> Conduit i o m r
bracketConduit IO a
acquire a -> IO b
cleanup a -> Conduit i o m r
inner = do
(a
resource, Conduit i o m ()
release) <- forall (m :: * -> *) (n :: * -> *) a b.
(MonadResource m, MonadIO n) =>
IO a -> (a -> IO b) -> m (a, n ())
allocate IO a
acquire a -> IO b
cleanup
r
result <- a -> Conduit i o m r
inner a
resource
Conduit i o m ()
release
forall (m :: * -> *) a. Monad m => a -> m a
return r
result
runPipe :: Monad m => Pipe () () () () m r -> m r
runPipe :: forall (m :: * -> *) r. Monad m => Pipe () () () () m r -> m r
runPipe =
forall {m :: * -> *} {input} {a}.
Monad m =>
Pipe () input () () m a -> m a
go
where
go :: Pipe () input () () m a -> m a
go (Yield Pipe () input () () m a
p m ()
_ ()) = Pipe () input () () m a -> m a
go Pipe () input () () m a
p
go (Await input -> Pipe () input () () m a
_ () -> Pipe () input () () m a
p) = Pipe () input () () m a -> m a
go (() -> Pipe () input () () m a
p ())
go (Done a
r) = forall (m :: * -> *) a. Monad m => a -> m a
return a
r
go (PipeM m (Pipe () input () () m a)
mp) = m (Pipe () input () () m a)
mp forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Pipe () input () () m a -> m a
go
go (Leftover Pipe () input () () m a
p ()) = Pipe () input () () m a -> m a
go Pipe () input () () m a
p
fuse :: Monad m => Conduit a b m () -> Conduit b c m r -> Conduit a c m r
fuse :: forall (m :: * -> *) a b c r.
Monad m =>
Conduit a b m () -> Conduit b c m r -> Conduit a c m r
fuse (Conduit forall a. (() -> Pipe a a b () m a) -> Pipe a a b () m a
left0) (Conduit forall a. (r -> Pipe b b c () m a) -> Pipe b b c () m a
right0) = forall input output (monad :: * -> *) result.
(forall a.
(result -> Pipe input input output () monad a)
-> Pipe input input output () monad a)
-> Conduit input output monad result
Conduit forall a b. (a -> b) -> a -> b
$ \r -> Pipe a a c () m a
rest ->
let goRight :: m ()
-> Pipe a a b () m () -> Pipe b b c () m r -> Pipe a a c () m a
goRight m ()
final Pipe a a b () m ()
left Pipe b b c () m r
right =
case Pipe b b c () m r
right of
Yield Pipe b b c () m r
p m ()
c c
o -> forall leftOver input output upstream (monad :: * -> *) result.
Pipe leftOver input output upstream monad result
-> monad ()
-> output
-> Pipe leftOver input output upstream monad result
Yield (Pipe b b c () m r -> Pipe a a c () m a
recurse Pipe b b c () m r
p) (m ()
c forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
final) c
o
Await b -> Pipe b b c () m r
rp () -> Pipe b b c () m r
rc -> (b -> Pipe b b c () m r)
-> (() -> Pipe b b c () m r)
-> m ()
-> Pipe a a b () m ()
-> Pipe a a c () m a
goLeft b -> Pipe b b c () m r
rp () -> Pipe b b c () m r
rc m ()
final Pipe a a b () m ()
left
Done r
r2 -> forall leftOver input output upstream (monad :: * -> *) result.
monad (Pipe leftOver input output upstream monad result)
-> Pipe leftOver input output upstream monad result
PipeM (m ()
final forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (r -> Pipe a a c () m a
rest r
r2))
PipeM m (Pipe b b c () m r)
mp -> forall leftOver input output upstream (monad :: * -> *) result.
monad (Pipe leftOver input output upstream monad result)
-> Pipe leftOver input output upstream monad result
PipeM (forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Pipe b b c () m r -> Pipe a a c () m a
recurse m (Pipe b b c () m r)
mp)
Leftover Pipe b b c () m r
right' b
i -> m ()
-> Pipe a a b () m () -> Pipe b b c () m r -> Pipe a a c () m a
goRight m ()
final (forall leftOver input output upstream (monad :: * -> *) result.
Pipe leftOver input output upstream monad result
-> monad ()
-> output
-> Pipe leftOver input output upstream monad result
Yield Pipe a a b () m ()
left m ()
final b
i) Pipe b b c () m r
right'
where
recurse :: Pipe b b c () m r -> Pipe a a c () m a
recurse = m ()
-> Pipe a a b () m () -> Pipe b b c () m r -> Pipe a a c () m a
goRight m ()
final Pipe a a b () m ()
left
goLeft :: (b -> Pipe b b c () m r)
-> (() -> Pipe b b c () m r)
-> m ()
-> Pipe a a b () m ()
-> Pipe a a c () m a
goLeft b -> Pipe b b c () m r
rp () -> Pipe b b c () m r
rc m ()
final Pipe a a b () m ()
left =
case Pipe a a b () m ()
left of
Yield Pipe a a b () m ()
left' m ()
final' b
o -> m ()
-> Pipe a a b () m () -> Pipe b b c () m r -> Pipe a a c () m a
goRight m ()
final' Pipe a a b () m ()
left' (b -> Pipe b b c () m r
rp b
o)
Await a -> Pipe a a b () m ()
left' () -> Pipe a a b () m ()
lc -> forall leftOver input output upstream (monad :: * -> *) result.
(input -> Pipe leftOver input output upstream monad result)
-> (upstream -> Pipe leftOver input output upstream monad result)
-> Pipe leftOver input output upstream monad result
Await (Pipe a a b () m () -> Pipe a a c () m a
recurse forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> Pipe a a b () m ()
left') (Pipe a a b () m () -> Pipe a a c () m a
recurse forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. () -> Pipe a a b () m ()
lc)
Done ()
r1 -> m ()
-> Pipe a a b () m () -> Pipe b b c () m r -> Pipe a a c () m a
goRight (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (forall leftOver input output upstream (monad :: * -> *) result.
result -> Pipe leftOver input output upstream monad result
Done ()
r1) (() -> Pipe b b c () m r
rc ()
r1)
PipeM m (Pipe a a b () m ())
mp -> forall leftOver input output upstream (monad :: * -> *) result.
monad (Pipe leftOver input output upstream monad result)
-> Pipe leftOver input output upstream monad result
PipeM (forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Pipe a a b () m () -> Pipe a a c () m a
recurse m (Pipe a a b () m ())
mp)
Leftover Pipe a a b () m ()
left' a
i -> forall leftOver input output upstream (monad :: * -> *) result.
Pipe leftOver input output upstream monad result
-> leftOver -> Pipe leftOver input output upstream monad result
Leftover (Pipe a a b () m () -> Pipe a a c () m a
recurse Pipe a a b () m ()
left') a
i
where
recurse :: Pipe a a b () m () -> Pipe a a c () m a
recurse = (b -> Pipe b b c () m r)
-> (() -> Pipe b b c () m r)
-> m ()
-> Pipe a a b () m ()
-> Pipe a a c () m a
goLeft b -> Pipe b b c () m r
rp () -> Pipe b b c () m r
rc m ()
final
in m ()
-> Pipe a a b () m () -> Pipe b b c () m r -> Pipe a a c () m a
goRight (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (forall a. (() -> Pipe a a b () m a) -> Pipe a a b () m a
left0 forall leftOver input output upstream (monad :: * -> *) result.
result -> Pipe leftOver input output upstream monad result
Done) (forall a. (r -> Pipe b b c () m a) -> Pipe b b c () m a
right0 forall leftOver input output upstream (monad :: * -> *) result.
result -> Pipe leftOver input output upstream monad result
Done)
newtype ZipSink i m r = ZipSink { forall i (m :: * -> *) r. ZipSink i m r -> Conduit i () m r
getZipSink :: Conduit i () m r }
instance Monad m => Functor (ZipSink i m) where
fmap :: forall a b. (a -> b) -> ZipSink i m a -> ZipSink i m b
fmap a -> b
f (ZipSink Conduit i () m a
x) = forall i (m :: * -> *) r. Conduit i () m r -> ZipSink i m r
ZipSink (forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> b
f Conduit i () m a
x)
instance Monad m => Applicative (ZipSink i m) where
pure :: forall a. a -> ZipSink i m a
pure = forall i (m :: * -> *) r. Conduit i () m r -> ZipSink i m r
ZipSink forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (m :: * -> *) a. Monad m => a -> m a
return
ZipSink (Conduit forall a. ((a -> b) -> Pipe i i () () m a) -> Pipe i i () () m a
f0) <*> :: forall a b. ZipSink i m (a -> b) -> ZipSink i m a -> ZipSink i m b
<*> ZipSink (Conduit forall a. (a -> Pipe i i () () m a) -> Pipe i i () () m a
x0) =
forall i (m :: * -> *) r. Conduit i () m r -> ZipSink i m r
ZipSink forall a b. (a -> b) -> a -> b
$ forall input output (monad :: * -> *) result.
(forall a.
(result -> Pipe input input output () monad a)
-> Pipe input input output () monad a)
-> Conduit input output monad result
Conduit forall a b. (a -> b) -> a -> b
$ \b -> Pipe i i () () m a
rest -> let
go :: Pipe Void i () () m (a -> b)
-> Pipe Void i () () m a -> Pipe i i () () m a
go (Leftover Pipe Void i () () m (a -> b)
_ Void
i) Pipe Void i () () m a
_ = forall a. Void -> a
absurd Void
i
go Pipe Void i () () m (a -> b)
_ (Leftover Pipe Void i () () m a
_ Void
i) = forall a. Void -> a
absurd Void
i
go (Yield Pipe Void i () () m (a -> b)
f m ()
_ ()) Pipe Void i () () m a
x = Pipe Void i () () m (a -> b)
-> Pipe Void i () () m a -> Pipe i i () () m a
go Pipe Void i () () m (a -> b)
f Pipe Void i () () m a
x
go Pipe Void i () () m (a -> b)
f (Yield Pipe Void i () () m a
x m ()
_ ()) = Pipe Void i () () m (a -> b)
-> Pipe Void i () () m a -> Pipe i i () () m a
go Pipe Void i () () m (a -> b)
f Pipe Void i () () m a
x
go (PipeM m (Pipe Void i () () m (a -> b))
mf) Pipe Void i () () m a
x = forall leftOver input output upstream (monad :: * -> *) result.
monad (Pipe leftOver input output upstream monad result)
-> Pipe leftOver input output upstream monad result
PipeM (forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Pipe Void i () () m (a -> b)
-> Pipe Void i () () m a -> Pipe i i () () m a
`go` Pipe Void i () () m a
x) m (Pipe Void i () () m (a -> b))
mf)
go Pipe Void i () () m (a -> b)
f (PipeM m (Pipe Void i () () m a)
mx) = forall leftOver input output upstream (monad :: * -> *) result.
monad (Pipe leftOver input output upstream monad result)
-> Pipe leftOver input output upstream monad result
PipeM (forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Pipe Void i () () m (a -> b)
-> Pipe Void i () () m a -> Pipe i i () () m a
go Pipe Void i () () m (a -> b)
f) m (Pipe Void i () () m a)
mx)
go (Done a -> b
f) (Done a
x) = b -> Pipe i i () () m a
rest (a -> b
f a
x)
go (Await i -> Pipe Void i () () m (a -> b)
pf () -> Pipe Void i () () m (a -> b)
cf) (Await i -> Pipe Void i () () m a
px () -> Pipe Void i () () m a
cx) = forall leftOver input output upstream (monad :: * -> *) result.
(input -> Pipe leftOver input output upstream monad result)
-> (upstream -> Pipe leftOver input output upstream monad result)
-> Pipe leftOver input output upstream monad result
Await
(\i
i -> Pipe Void i () () m (a -> b)
-> Pipe Void i () () m a -> Pipe i i () () m a
go (i -> Pipe Void i () () m (a -> b)
pf i
i) (i -> Pipe Void i () () m a
px i
i))
(\() -> Pipe Void i () () m (a -> b)
-> Pipe Void i () () m a -> Pipe i i () () m a
go (() -> Pipe Void i () () m (a -> b)
cf ()) (() -> Pipe Void i () () m a
cx ()))
go (Await i -> Pipe Void i () () m (a -> b)
pf () -> Pipe Void i () () m (a -> b)
cf) x :: Pipe Void i () () m a
x@Done{} = forall leftOver input output upstream (monad :: * -> *) result.
(input -> Pipe leftOver input output upstream monad result)
-> (upstream -> Pipe leftOver input output upstream monad result)
-> Pipe leftOver input output upstream monad result
Await
(\i
i -> Pipe Void i () () m (a -> b)
-> Pipe Void i () () m a -> Pipe i i () () m a
go (i -> Pipe Void i () () m (a -> b)
pf i
i) Pipe Void i () () m a
x)
(\() -> Pipe Void i () () m (a -> b)
-> Pipe Void i () () m a -> Pipe i i () () m a
go (() -> Pipe Void i () () m (a -> b)
cf ()) Pipe Void i () () m a
x)
go f :: Pipe Void i () () m (a -> b)
f@Done{} (Await i -> Pipe Void i () () m a
px () -> Pipe Void i () () m a
cx) = forall leftOver input output upstream (monad :: * -> *) result.
(input -> Pipe leftOver input output upstream monad result)
-> (upstream -> Pipe leftOver input output upstream monad result)
-> Pipe leftOver input output upstream monad result
Await
(\i
i -> Pipe Void i () () m (a -> b)
-> Pipe Void i () () m a -> Pipe i i () () m a
go Pipe Void i () () m (a -> b)
f (i -> Pipe Void i () () m a
px i
i))
(\() -> Pipe Void i () () m (a -> b)
-> Pipe Void i () () m a -> Pipe i i () () m a
go Pipe Void i () () m (a -> b)
f (() -> Pipe Void i () () m a
cx ()))
in Pipe Void i () () m (a -> b)
-> Pipe Void i () () m a -> Pipe i i () () m a
go (forall (m :: * -> *) i o u r l.
Monad m =>
Pipe i i o u m r -> Pipe l i o u m r
injectLeftovers (forall a. ((a -> b) -> Pipe i i () () m a) -> Pipe i i () () m a
f0 forall leftOver input output upstream (monad :: * -> *) result.
result -> Pipe leftOver input output upstream monad result
Done)) (forall (m :: * -> *) i o u r l.
Monad m =>
Pipe i i o u m r -> Pipe l i o u m r
injectLeftovers (forall a. (a -> Pipe i i () () m a) -> Pipe i i () () m a
x0 forall leftOver input output upstream (monad :: * -> *) result.
result -> Pipe leftOver input output upstream monad result
Done))
data Void
absurd :: Void -> a
absurd :: forall a. Void -> a
absurd Void
_ = forall a. HasCallStack => String -> a
error String
"Foundation.Conduit.Internal.absurd"
injectLeftovers :: Monad m => Pipe i i o u m r -> Pipe l i o u m r
injectLeftovers :: forall (m :: * -> *) i o u r l.
Monad m =>
Pipe i i o u m r -> Pipe l i o u m r
injectLeftovers =
forall {monad :: * -> *} {input} {output} {upstream} {result}
{leftOver}.
Monad monad =>
[input]
-> Pipe input input output upstream monad result
-> Pipe leftOver input output upstream monad result
go []
where
go :: [input]
-> Pipe input input output upstream monad result
-> Pipe leftOver input output upstream monad result
go [input]
ls (Yield Pipe input input output upstream monad result
p monad ()
c output
o) = forall leftOver input output upstream (monad :: * -> *) result.
Pipe leftOver input output upstream monad result
-> monad ()
-> output
-> Pipe leftOver input output upstream monad result
Yield ([input]
-> Pipe input input output upstream monad result
-> Pipe leftOver input output upstream monad result
go [input]
ls Pipe input input output upstream monad result
p) monad ()
c output
o
go (input
l:[input]
ls) (Await input -> Pipe input input output upstream monad result
p upstream -> Pipe input input output upstream monad result
_) = [input]
-> Pipe input input output upstream monad result
-> Pipe leftOver input output upstream monad result
go [input]
ls forall a b. (a -> b) -> a -> b
$ input -> Pipe input input output upstream monad result
p input
l
go [] (Await input -> Pipe input input output upstream monad result
p upstream -> Pipe input input output upstream monad result
c) = forall leftOver input output upstream (monad :: * -> *) result.
(input -> Pipe leftOver input output upstream monad result)
-> (upstream -> Pipe leftOver input output upstream monad result)
-> Pipe leftOver input output upstream monad result
Await ([input]
-> Pipe input input output upstream monad result
-> Pipe leftOver input output upstream monad result
go [] forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. input -> Pipe input input output upstream monad result
p) ([input]
-> Pipe input input output upstream monad result
-> Pipe leftOver input output upstream monad result
go [] forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. upstream -> Pipe input input output upstream monad result
c)
go [input]
_ (Done result
r) = forall leftOver input output upstream (monad :: * -> *) result.
result -> Pipe leftOver input output upstream monad result
Done result
r
go [input]
ls (PipeM monad (Pipe input input output upstream monad result)
mp) = forall leftOver input output upstream (monad :: * -> *) result.
monad (Pipe leftOver input output upstream monad result)
-> Pipe leftOver input output upstream monad result
PipeM (forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ([input]
-> Pipe input input output upstream monad result
-> Pipe leftOver input output upstream monad result
go [input]
ls) monad (Pipe input input output upstream monad result)
mp)
go [input]
ls (Leftover Pipe input input output upstream monad result
p input
l) = [input]
-> Pipe input input output upstream monad result
-> Pipe leftOver input output upstream monad result
go (input
lforall a. a -> [a] -> [a]
:[input]
ls) Pipe input input output upstream monad result
p
newtype ResourceT m a = ResourceT { forall (m :: * -> *) a.
ResourceT m a -> PrimVar IO ReleaseMap -> m a
unResourceT :: PrimVar IO ReleaseMap -> m a }
instance Functor m => Functor (ResourceT m) where
fmap :: forall a b. (a -> b) -> ResourceT m a -> ResourceT m b
fmap a -> b
f (ResourceT PrimVar IO ReleaseMap -> m a
m) = forall (m :: * -> *) a.
(PrimVar IO ReleaseMap -> m a) -> ResourceT m a
ResourceT forall a b. (a -> b) -> a -> b
$ \PrimVar IO ReleaseMap
r -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (PrimVar IO ReleaseMap -> m a
m PrimVar IO ReleaseMap
r)
instance Applicative m => Applicative (ResourceT m) where
pure :: forall a. a -> ResourceT m a
pure = forall (m :: * -> *) a.
(PrimVar IO ReleaseMap -> m a) -> ResourceT m a
ResourceT forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. a -> b -> a
const forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
ResourceT PrimVar IO ReleaseMap -> m (a -> b)
mf <*> :: forall a b. ResourceT m (a -> b) -> ResourceT m a -> ResourceT m b
<*> ResourceT PrimVar IO ReleaseMap -> m a
ma = forall (m :: * -> *) a.
(PrimVar IO ReleaseMap -> m a) -> ResourceT m a
ResourceT forall a b. (a -> b) -> a -> b
$ \PrimVar IO ReleaseMap
r ->
PrimVar IO ReleaseMap -> m (a -> b)
mf PrimVar IO ReleaseMap
r forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PrimVar IO ReleaseMap -> m a
ma PrimVar IO ReleaseMap
r
instance Monad m => Monad (ResourceT m) where
#if !MIN_VERSION_base(4,8,0)
return = ResourceT . const . return
#endif
ResourceT PrimVar IO ReleaseMap -> m a
ma >>= :: forall a b. ResourceT m a -> (a -> ResourceT m b) -> ResourceT m b
>>= a -> ResourceT m b
f = forall (m :: * -> *) a.
(PrimVar IO ReleaseMap -> m a) -> ResourceT m a
ResourceT forall a b. (a -> b) -> a -> b
$ \PrimVar IO ReleaseMap
r -> do
a
a <- PrimVar IO ReleaseMap -> m a
ma PrimVar IO ReleaseMap
r
let ResourceT PrimVar IO ReleaseMap -> m b
f' = a -> ResourceT m b
f a
a
PrimVar IO ReleaseMap -> m b
f' PrimVar IO ReleaseMap
r
instance MonadTrans ResourceT where
lift :: forall (m :: * -> *) a. Monad m => m a -> ResourceT m a
lift = forall (m :: * -> *) a.
(PrimVar IO ReleaseMap -> m a) -> ResourceT m a
ResourceT forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. a -> b -> a
const
instance MonadIO m => MonadIO (ResourceT m) where
liftIO :: forall a. IO a -> ResourceT m a
liftIO = forall (trans :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans trans, Monad m) =>
m a -> trans m a
lift forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
instance MonadThrow m => MonadThrow (ResourceT m) where
throw :: forall e a. Exception e => e -> ResourceT m a
throw = forall (trans :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans trans, Monad m) =>
m a -> trans m a
lift forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw
instance MonadCatch m => MonadCatch (ResourceT m) where
catch :: forall e a.
Exception e =>
ResourceT m a -> (e -> ResourceT m a) -> ResourceT m a
catch (ResourceT PrimVar IO ReleaseMap -> m a
f) e -> ResourceT m a
g = forall (m :: * -> *) a.
(PrimVar IO ReleaseMap -> m a) -> ResourceT m a
ResourceT forall a b. (a -> b) -> a -> b
$ \PrimVar IO ReleaseMap
env -> PrimVar IO ReleaseMap -> m a
f PrimVar IO ReleaseMap
env forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \e
e -> forall (m :: * -> *) a.
ResourceT m a -> PrimVar IO ReleaseMap -> m a
unResourceT (e -> ResourceT m a
g e
e) PrimVar IO ReleaseMap
env
instance MonadBracket m => MonadBracket (ResourceT m) where
generalBracket :: forall a b ignored1 ignored2.
ResourceT m a
-> (a -> b -> ResourceT m ignored1)
-> (a -> SomeException -> ResourceT m ignored2)
-> (a -> ResourceT m b)
-> ResourceT m b
generalBracket ResourceT m a
acquire a -> b -> ResourceT m ignored1
onSuccess a -> SomeException -> ResourceT m ignored2
onExc a -> ResourceT m b
inner = forall (m :: * -> *) a.
(PrimVar IO ReleaseMap -> m a) -> ResourceT m a
ResourceT forall a b. (a -> b) -> a -> b
$ \PrimVar IO ReleaseMap
env -> forall (m :: * -> *) a b ignored1 ignored2.
MonadBracket m =>
m a
-> (a -> b -> m ignored1)
-> (a -> SomeException -> m ignored2)
-> (a -> m b)
-> m b
generalBracket
(forall (m :: * -> *) a.
ResourceT m a -> PrimVar IO ReleaseMap -> m a
unResourceT ResourceT m a
acquire PrimVar IO ReleaseMap
env)
(\a
x b
y -> forall (m :: * -> *) a.
ResourceT m a -> PrimVar IO ReleaseMap -> m a
unResourceT (a -> b -> ResourceT m ignored1
onSuccess a
x b
y) PrimVar IO ReleaseMap
env)
(\a
x SomeException
y -> forall (m :: * -> *) a.
ResourceT m a -> PrimVar IO ReleaseMap -> m a
unResourceT (a -> SomeException -> ResourceT m ignored2
onExc a
x SomeException
y) PrimVar IO ReleaseMap
env)
(\a
x -> forall (m :: * -> *) a.
ResourceT m a -> PrimVar IO ReleaseMap -> m a
unResourceT (a -> ResourceT m b
inner a
x) PrimVar IO ReleaseMap
env)
data ReleaseMap =
ReleaseMap !NextKey !RefCount ![(Word, (ReleaseType -> IO ()))]
| ReleaseMapClosed
data ReleaseType = ReleaseEarly
| ReleaseNormal
| ReleaseException
type RefCount = Word
type NextKey = Word
runResourceT :: (MonadBracket m, MonadIO m) => ResourceT m a -> m a
runResourceT :: forall (m :: * -> *) a.
(MonadBracket m, MonadIO m) =>
ResourceT m a -> m a
runResourceT (ResourceT PrimVar IO ReleaseMap -> m a
inner) = forall (m :: * -> *) a b ignored1 ignored2.
MonadBracket m =>
m a
-> (a -> b -> m ignored1)
-> (a -> SomeException -> m ignored2)
-> (a -> m b)
-> m b
generalBracket
(forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. PrimMonad m => a -> m (PrimVar m a)
primVarNew forall a b. (a -> b) -> a -> b
$ NextKey
-> NextKey -> [(NextKey, ReleaseType -> IO ())] -> ReleaseMap
ReleaseMap forall a. Bounded a => a
maxBound (forall a. Bounded a => a
minBound forall a. Additive a => a -> a -> a
+ NextKey
1) [])
(\IORef ReleaseMap
state a
_res -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IORef ReleaseMap -> ReleaseType -> IO ()
cleanup IORef ReleaseMap
state ReleaseType
ReleaseNormal)
(\IORef ReleaseMap
state SomeException
_exc -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IORef ReleaseMap -> ReleaseType -> IO ()
cleanup IORef ReleaseMap
state ReleaseType
ReleaseException)
PrimVar IO ReleaseMap -> m a
inner
where
cleanup :: IORef ReleaseMap -> ReleaseType -> IO ()
cleanup IORef ReleaseMap
istate ReleaseType
rtype = do
Maybe [(NextKey, ReleaseType -> IO ())]
mm <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef ReleaseMap
istate forall a b. (a -> b) -> a -> b
$ \ReleaseMap
rm ->
case ReleaseMap
rm of
ReleaseMap NextKey
nk NextKey
rf [(NextKey, ReleaseType -> IO ())]
m ->
let rf' :: Difference NextKey
rf' = NextKey
rf forall a. Subtractive a => a -> a -> Difference a
- NextKey
1
in if Difference NextKey
rf' forall a. Eq a => a -> a -> Bool
== forall a. Bounded a => a
minBound
then (ReleaseMap
ReleaseMapClosed, forall a. a -> Maybe a
Just [(NextKey, ReleaseType -> IO ())]
m)
else (NextKey
-> NextKey -> [(NextKey, ReleaseType -> IO ())] -> ReleaseMap
ReleaseMap NextKey
nk Difference NextKey
rf' [(NextKey, ReleaseType -> IO ())]
m, forall a. Maybe a
Nothing)
ReleaseMap
ReleaseMapClosed -> forall a. HasCallStack => String -> a
error String
"runResourceT: cleanup on ReleaseMapClosed"
case Maybe [(NextKey, ReleaseType -> IO ())]
mm of
Just [(NextKey, ReleaseType -> IO ())]
m -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(NextKey
_, ReleaseType -> IO ()
x) -> forall {m :: * -> *} {a}. MonadCatch m => m a -> m ()
ignoreExceptions (ReleaseType -> IO ()
x ReleaseType
rtype)) [(NextKey, ReleaseType -> IO ())]
m
Maybe [(NextKey, ReleaseType -> IO ())]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
ignoreExceptions :: m a -> m ()
ignoreExceptions m a
io = forall (f :: * -> *) a. Functor f => f a -> f ()
void m a
io forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\(SomeException
_ :: SomeException) -> forall (m :: * -> *) a. Monad m => a -> m a
return ())
allocate :: (MonadResource m, MonadIO n) => IO a -> (a -> IO b) -> m (a, n ())
allocate :: forall (m :: * -> *) (n :: * -> *) a b.
(MonadResource m, MonadIO n) =>
IO a -> (a -> IO b) -> m (a, n ())
allocate IO a
acquire a -> IO b
release = forall (m :: * -> *) a. MonadResource m => ResourceT IO a -> m a
liftResourceT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(PrimVar IO ReleaseMap -> m a) -> ResourceT m a
ResourceT forall a b. (a -> b) -> a -> b
$ \PrimVar IO ReleaseMap
istate -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ do
a
a <- IO a
acquire
NextKey
key <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef PrimVar IO ReleaseMap
istate forall a b. (a -> b) -> a -> b
$ \ReleaseMap
rm ->
case ReleaseMap
rm of
ReleaseMap NextKey
key NextKey
rf [(NextKey, ReleaseType -> IO ())]
m ->
( NextKey
-> NextKey -> [(NextKey, ReleaseType -> IO ())] -> ReleaseMap
ReleaseMap (NextKey
key forall a. Subtractive a => a -> a -> Difference a
- NextKey
1) NextKey
rf ((NextKey
key, forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ a -> IO b
release a
a) forall a. a -> [a] -> [a]
: [(NextKey, ReleaseType -> IO ())]
m)
, NextKey
key
)
ReleaseMap
ReleaseMapClosed -> forall a. HasCallStack => String -> a
error String
"allocate: ReleaseMapClosed"
let release' :: IO ()
release' = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef PrimVar IO ReleaseMap
istate forall a b. (a -> b) -> a -> b
$ \ReleaseMap
rm ->
case ReleaseMap
rm of
ReleaseMap NextKey
nextKey NextKey
rf [(NextKey, ReleaseType -> IO ())]
m ->
let loop :: ([(NextKey, ReleaseType -> IO ())]
-> [(NextKey, ReleaseType -> IO ())])
-> [(NextKey, ReleaseType -> IO ())] -> (ReleaseMap, IO ())
loop [(NextKey, ReleaseType -> IO ())]
-> [(NextKey, ReleaseType -> IO ())]
front [] = (NextKey
-> NextKey -> [(NextKey, ReleaseType -> IO ())] -> ReleaseMap
ReleaseMap NextKey
nextKey NextKey
rf ([(NextKey, ReleaseType -> IO ())]
-> [(NextKey, ReleaseType -> IO ())]
front []), forall (m :: * -> *) a. Monad m => a -> m a
return ())
loop [(NextKey, ReleaseType -> IO ())]
-> [(NextKey, ReleaseType -> IO ())]
front ((NextKey
key', ReleaseType -> IO ()
action):[(NextKey, ReleaseType -> IO ())]
rest)
| NextKey
key forall a. Eq a => a -> a -> Bool
== NextKey
key' =
( NextKey
-> NextKey -> [(NextKey, ReleaseType -> IO ())] -> ReleaseMap
ReleaseMap NextKey
nextKey NextKey
rf ([(NextKey, ReleaseType -> IO ())]
-> [(NextKey, ReleaseType -> IO ())]
front [(NextKey, ReleaseType -> IO ())]
rest)
, ReleaseType -> IO ()
action ReleaseType
ReleaseEarly
)
| Bool
otherwise = ([(NextKey, ReleaseType -> IO ())]
-> [(NextKey, ReleaseType -> IO ())])
-> [(NextKey, ReleaseType -> IO ())] -> (ReleaseMap, IO ())
loop ([(NextKey, ReleaseType -> IO ())]
-> [(NextKey, ReleaseType -> IO ())]
front forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ((NextKey
key', ReleaseType -> IO ()
action)forall a. a -> [a] -> [a]
:)) [(NextKey, ReleaseType -> IO ())]
rest
in ([(NextKey, ReleaseType -> IO ())]
-> [(NextKey, ReleaseType -> IO ())])
-> [(NextKey, ReleaseType -> IO ())] -> (ReleaseMap, IO ())
loop forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id [(NextKey, ReleaseType -> IO ())]
m
ReleaseMap
ReleaseMapClosed -> forall a. HasCallStack => String -> a
error String
"allocate: ReleaseMapClosed (2)"
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
release')
class MonadIO m => MonadResource m where
liftResourceT :: ResourceT IO a -> m a
instance MonadIO m => MonadResource (ResourceT m) where
liftResourceT :: forall a. ResourceT IO a -> ResourceT m a
liftResourceT (ResourceT PrimVar IO ReleaseMap -> IO a
f) = forall (m :: * -> *) a.
(PrimVar IO ReleaseMap -> m a) -> ResourceT m a
ResourceT (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. PrimVar IO ReleaseMap -> IO a
f)
instance MonadResource m => MonadResource (Conduit i o m) where
liftResourceT :: forall a. ResourceT IO a -> Conduit i o m a
liftResourceT = forall (trans :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans trans, Monad m) =>
m a -> trans m a
lift forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (m :: * -> *) a. MonadResource m => ResourceT IO a -> m a
liftResourceT