-- Module      : Foundation.Conduit.Internal
-- License     : BSD-style
-- Maintainer  : Foundation
-- Stability   : experimental
-- Portability : portable
--
-- Taken from the conduit package almost verbatim, and
-- Copyright (c) 2012 Michael Snoyman
--
{-# 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)

-- | A pipe producing and consuming values
--
-- A basic intuition is that every @Pipe@ produces a stream of /output/ values
-- and eventually indicates that this stream is terminated by sending a
-- /result/. On the receiving end of a @Pipe@, these become the /input/ and /upstream/
-- parameters.
data Pipe leftOver input output upstream monad result =
      -- | Provide new output to be sent downstream. This constructor has three
      -- fields: the next @Pipe@ to be used, a finalization function, and the
      -- output value.
      Yield (Pipe leftOver input output upstream monad result) (monad ()) output
      -- | Request more input from upstream. The first field takes a new input
      -- value and provides a new @Pipe@. The second takes an upstream result
      -- value, which indicates that upstream is producing no more results.
    | Await (input -> Pipe leftOver input output upstream monad result)
                (upstream -> Pipe leftOver input output upstream monad result)
      -- | Processing with this @Pipe@ is complete, providing the final result.
    | Done result
      -- | Require running of a monadic action to get the next @Pipe@.
    | PipeM (monad (Pipe leftOver input output upstream monad result))
      -- | Return leftover input, which should be provided to future operations.
    | Leftover (Pipe leftOver input output upstream monad result) leftOver

instance Applicative m => Functor (Pipe l i o u m) where
    fmap :: (a -> b) -> Pipe l i o u m a -> Pipe l i o u m b
fmap = (a -> b) -> Pipe l i o u m a -> Pipe l i o u m b
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 :: a -> Pipe l i o u m a
pure = a -> Pipe l i o u m a
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  <*> :: 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 = Pipe l i o u m b -> m () -> o -> Pipe l i o u m b
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 Pipe l i o u m (a -> b) -> Pipe l i o u m a -> Pipe l i o u m b
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 = (i -> Pipe l i o u m b)
-> (u -> Pipe l i o u m b) -> Pipe l i o u m b
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 Pipe l i o u m (a -> b) -> Pipe l i o u m a -> Pipe l i o u m b
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 Pipe l i o u m (a -> b) -> Pipe l i o u m a -> Pipe l i o u m b
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 (a -> b) -> Pipe l i o u m a -> Pipe l i o u m b
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 = m (Pipe l i o u m b) -> Pipe l i o u m b
forall leftOver input output upstream (monad :: * -> *) result.
monad (Pipe leftOver input output upstream monad result)
-> Pipe leftOver input output upstream monad result
PipeM ((Pipe l i o u m (a -> b) -> Pipe l i o u m a -> Pipe l i o u m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pipe l i o u m a
fa) (Pipe l i o u m (a -> b) -> Pipe l i o u m b)
-> m (Pipe l i o u m (a -> b)) -> m (Pipe l i o u m b)
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 = Pipe l i o u m b -> l -> Pipe l i o u m b
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 Pipe l i o u m (a -> b) -> Pipe l i o u m a -> Pipe l i o u m b
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 :: a -> Pipe l i o u m a
return = a -> Pipe l i o u m a
forall leftOver input output upstream (monad :: * -> *) result.
result -> Pipe leftOver input output upstream monad result
Done
    {-# INLINE return #-}

    Yield Pipe l i o u m a
p m ()
c o
o  >>= :: 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 = Pipe l i o u m b -> m () -> o -> Pipe l i o u m b
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 Pipe l i o u m a -> (a -> Pipe l i o u m b) -> Pipe l i o u m b
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 = (i -> Pipe l i o u m b)
-> (u -> Pipe l i o u m b) -> Pipe l i o u m b
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 (i -> Pipe l i o u m a)
-> (a -> Pipe l i o u m b) -> i -> Pipe l i o u m b
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 (u -> Pipe l i o u m a)
-> (a -> Pipe l i o u m b) -> u -> Pipe l i o u m b
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 = m (Pipe l i o u m b) -> Pipe l i o u m b
forall leftOver input output upstream (monad :: * -> *) result.
monad (Pipe leftOver input output upstream monad result)
-> Pipe leftOver input output upstream monad result
PipeM    ((Pipe l i o u m a -> (a -> Pipe l i o u m b) -> Pipe l i o u m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Pipe l i o u m b
fp) (Pipe l i o u m a -> Pipe l i o u m b)
-> m (Pipe l i o u m a) -> m (Pipe l i o u m b)
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 = Pipe l i o u m b -> l -> Pipe l i o u m b
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 Pipe l i o u m a -> (a -> Pipe l i o u m b) -> Pipe l i o u m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Pipe l i o u m b
fp)            l
i

-- | A component of a conduit pipeline, which takes a stream of
-- @input@, produces a stream of @output@, performs actions in the
-- underlying @monad@, and produces a value of @result@ when no more
-- output data is available.
newtype Conduit input output monad result = Conduit
    { 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 :: (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 a. (b -> Pipe i i o () m a) -> Pipe i i o () m a)
-> Conduit i o m 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 -> Pipe i i o () m a) -> Pipe i i o () m a)
 -> Conduit i o m b)
-> (forall a. (b -> Pipe i i o () m a) -> Pipe i i o () m a)
-> Conduit i o m b
forall a b. (a -> b) -> a -> b
$ \b -> Pipe i i o () m a
resPipe -> (a -> Pipe i i o () m a) -> Pipe i i o () m a
forall a. (a -> Pipe i i o () m a) -> Pipe i i o () m a
c (b -> Pipe i i o () m a
resPipe (b -> Pipe i i o () m a) -> (a -> b) -> a -> Pipe i i o () m a
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 :: a -> Conduit i o m a
pure a
x = (forall a. (a -> Pipe i i o () m a) -> Pipe i i o () m a)
-> Conduit i o m a
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 ((a -> Pipe i i o () m a) -> a -> Pipe i i o () m a
forall a b. (a -> b) -> a -> b
$ a
x)
    {-# INLINE pure #-}

    Conduit i o m (a -> b)
fab <*> :: 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 Conduit i o m (a -> b)
-> ((a -> b) -> Conduit i o m b) -> Conduit i o m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a -> b
ab -> Conduit i o m a
fa Conduit i o m a -> (a -> Conduit i o m b) -> Conduit i o m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
a -> b -> Conduit i o m b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> b
ab a
a)
    {-# INLINE (<*>) #-}

instance Monad (Conduit i o m) where
    return :: a -> Conduit i o m a
return = a -> Conduit i o m a
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 >>= :: Conduit i o m a -> (a -> Conduit i o m b) -> Conduit i o m b
>>= a -> Conduit i o m b
g = (forall a. (b -> Pipe i i o () m a) -> Pipe i i o () m a)
-> Conduit i o m 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 -> Pipe i i o () m a) -> Pipe i i o () m a)
 -> Conduit i o m b)
-> (forall a. (b -> Pipe i i o () m a) -> Pipe i i o () m a)
-> Conduit i o m b
forall a b. (a -> b) -> a -> b
$ \b -> Pipe i i o () m a
h -> (a -> Pipe i i o () m a) -> Pipe i i o () m a
forall a. (a -> Pipe i i o () m a) -> Pipe i i o () m a
f ((a -> Pipe i i o () m a) -> Pipe i i o () m a)
-> (a -> Pipe i i o () m a) -> Pipe i i o () m a
forall a b. (a -> b) -> a -> b
$ \a
a -> Conduit i o m b -> (b -> Pipe i i o () m a) -> Pipe i i o () m 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 :: m a -> Conduit i o m a
lift m a
m = (forall a. (a -> Pipe i i o () m a) -> Pipe i i o () m a)
-> Conduit i o m a
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. (a -> Pipe i i o () m a) -> Pipe i i o () m a)
 -> Conduit i o m a)
-> (forall a. (a -> Pipe i i o () m a) -> Pipe i i o () m a)
-> Conduit i o m a
forall a b. (a -> b) -> a -> b
$ \a -> Pipe i i o () m a
rest -> m (Pipe i i o () m a) -> Pipe i i o () m a
forall leftOver input output upstream (monad :: * -> *) result.
monad (Pipe leftOver input output upstream monad result)
-> Pipe leftOver input output upstream monad result
PipeM (m (Pipe i i o () m a) -> Pipe i i o () m a)
-> m (Pipe i i o () m a) -> Pipe i i o () m a
forall a b. (a -> b) -> a -> b
$ (a -> Pipe i i o () m a) -> m a -> m (Pipe i i o () m a)
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 :: IO a -> Conduit i o m a
liftIO = m a -> Conduit i o m a
forall (trans :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans trans, Monad m) =>
m a -> trans m a
lift (m a -> Conduit i o m a)
-> (IO a -> m a) -> IO a -> Conduit i o m a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. IO a -> m a
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 = m () -> Conduit i o m ()
forall (trans :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans trans, Monad m) =>
m a -> trans m a
lift (m () -> Conduit i o m ())
-> (Failure m -> m ()) -> Failure m -> Conduit i o m ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Failure m -> m ()
forall (m :: * -> *). MonadFailure m => Failure m -> m ()
mFail

instance MonadThrow m => MonadThrow (Conduit i o m) where
    throw :: e -> Conduit i o m a
throw = m a -> Conduit i o m a
forall (trans :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans trans, Monad m) =>
m a -> trans m a
lift (m a -> Conduit i o m a) -> (e -> m a) -> e -> Conduit i o m a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw

instance MonadCatch m => MonadCatch (Conduit i o m) where
    catch :: 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 a. (a -> Pipe i i o () m a) -> Pipe i i o () m a)
-> Conduit i o m a
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. (a -> Pipe i i o () m a) -> Pipe i i o () m a)
 -> Conduit i o m a)
-> (forall a. (a -> Pipe i i o () m a) -> Pipe i i o () m a)
-> Conduit i o m a
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) =
            m (Pipe i i o () m a) -> Pipe i i o () m a
forall leftOver input output upstream (monad :: * -> *) result.
monad (Pipe leftOver input output upstream monad result)
-> Pipe leftOver input output upstream monad result
PipeM (m (Pipe i i o () m a) -> Pipe i i o () m a)
-> m (Pipe i i o () m a) -> Pipe i i o () m a
forall a b. (a -> b) -> a -> b
$ m (Pipe i i o () m a)
-> (e -> m (Pipe i i o () m a)) -> m (Pipe i i o () m a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch ((Pipe i i o () m a -> Pipe i i o () m a)
-> m (Pipe i i o () m a) -> m (Pipe i i o () m a)
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 -> Pipe i i o () m a -> m (Pipe i i o () m a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pipe i i o () m a -> m (Pipe i i o () m a))
-> Pipe i i o () m a -> m (Pipe i i o () m a)
forall a b. (a -> b) -> a -> b
$ Conduit i o m a -> (a -> Pipe i i o () m a) -> Pipe i i o () m 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 (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) = (i -> Pipe i i o () m a)
-> (() -> Pipe i i o () m a) -> Pipe i i o () m a
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 (Pipe i i o () m a -> Pipe i i o () m a)
-> (i -> Pipe i i o () m a) -> i -> Pipe i i o () m a
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 (Pipe i i o () m a -> Pipe i i o () m a)
-> (() -> Pipe i i o () m a) -> () -> Pipe i i o () m a
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) = Pipe i i o () m a -> m () -> o -> Pipe i i o () m a
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) = Pipe i i o () m a -> i -> Pipe i i o () m a
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 ((a -> Pipe i i o () m a) -> Pipe i i o () m a
forall a. (a -> Pipe i i o () m a) -> Pipe i i o () m a
c0 a -> Pipe i i o () m a
forall leftOver input output upstream (monad :: * -> *) result.
result -> Pipe leftOver input output upstream monad result
Done)

-- | Await for a value from upstream.
await :: Conduit i o m (Maybe i)
await :: Conduit i o m (Maybe i)
await = (forall a. (Maybe i -> Pipe i i o () m a) -> Pipe i i o () m a)
-> Conduit i o m (Maybe 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. (Maybe i -> Pipe i i o () m a) -> Pipe i i o () m a)
 -> Conduit i o m (Maybe i))
-> (forall a. (Maybe i -> Pipe i i o () m a) -> Pipe i i o () m a)
-> Conduit i o m (Maybe i)
forall a b. (a -> b) -> a -> b
$ \Maybe i -> Pipe i i o () m a
f -> (i -> Pipe i i o () m a)
-> (() -> Pipe i i o () m a) -> Pipe i i o () m a
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 (Maybe i -> Pipe i i o () m a)
-> (i -> Maybe i) -> i -> Pipe i i o () m a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. i -> Maybe i
forall a. a -> Maybe a
Just) (Pipe i i o () m a -> () -> Pipe i i o () m a
forall a b. a -> b -> a
const (Maybe i -> Pipe i i o () m a
f Maybe i
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' :: 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 a. (r -> Pipe i i o () m a) -> Pipe i i o () m a)
-> Conduit i o m r
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. (r -> Pipe i i o () m a) -> Pipe i i o () m a)
 -> Conduit i o m r)
-> (forall a. (r -> Pipe i i o () m a) -> Pipe i i o () m a)
-> Conduit i o m r
forall a b. (a -> b) -> a -> b
$ \r -> Pipe i i o () m a
rest -> (i -> Pipe i i o () m a)
-> (() -> Pipe i i o () m a) -> Pipe i i o () m a
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 -> Conduit i o m r -> (r -> Pipe i i o () m a) -> Pipe i i o () m 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 (i -> Conduit i o m r
g i
i) r -> Pipe i i o () m a
rest)
    (Pipe i i o () m a -> () -> Pipe i i o () m a
forall a b. a -> b -> a
const (Pipe i i o () m a -> () -> Pipe i i o () m a)
-> Pipe i i o () m a -> () -> Pipe i i o () m a
forall a b. (a -> b) -> a -> b
$ Conduit i o m r -> (r -> Pipe i i o () m a) -> Pipe i i o () m 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 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 :: (input -> Conduit input output monad b)
-> Conduit input output monad ()
awaitForever input -> Conduit input output monad b
f = (forall a.
 (() -> Pipe input input output () monad a)
 -> Pipe input input output () monad a)
-> Conduit input output monad ()
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.
  (() -> Pipe input input output () monad a)
  -> Pipe input input output () monad a)
 -> Conduit input output monad ())
-> (forall a.
    (() -> Pipe input input output () monad a)
    -> Pipe input input output () monad a)
-> Conduit input output monad ()
forall a b. (a -> b) -> a -> b
$ \() -> Pipe input input output () monad a
rest ->
    let go :: Pipe input input output () monad a
go = (input -> Pipe input input output () monad a)
-> (() -> Pipe input input output () monad a)
-> Pipe input input output () monad a
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 -> Conduit input output monad b
-> (b -> Pipe input input output () monad a)
-> Pipe input input output () monad 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 (input -> Conduit input output monad b
f input
i) (Pipe input input output () monad a
-> b -> Pipe input input output () monad a
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

-- | Send a value downstream.
yield :: Monad m => o -> Conduit i o m ()
yield :: o -> Conduit i o m ()
yield o
o = (forall a. (() -> Pipe i i o () m a) -> Pipe i i o () m a)
-> Conduit i o 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. (() -> Pipe i i o () m a) -> Pipe i i o () m a)
 -> Conduit i o m ())
-> (forall a. (() -> Pipe i i o () m a) -> Pipe i i o () m a)
-> Conduit i o m ()
forall a b. (a -> b) -> a -> b
$ \() -> Pipe i i o () m a
f -> Pipe i i o () m a -> m () -> o -> Pipe i i o () m a
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 ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) o
o

-- | Same as 'yield', but additionally takes a finalizer to be run if
-- the downstream component terminates.
yieldOr :: o
        -> m () -- ^ finalizer
        -> Conduit i o m ()
yieldOr :: o -> m () -> Conduit i o m ()
yieldOr o
o m ()
m = (forall a. (() -> Pipe i i o () m a) -> Pipe i i o () m a)
-> Conduit i o 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. (() -> Pipe i i o () m a) -> Pipe i i o () m a)
 -> Conduit i o m ())
-> (forall a. (() -> Pipe i i o () m a) -> Pipe i i o () m a)
-> Conduit i o m ()
forall a b. (a -> b) -> a -> b
$ \() -> Pipe i i o () m a
f -> Pipe i i o () m a -> m () -> o -> Pipe i i o () m a
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

-- | Provide leftover input to be consumed by the next component in
-- the current monadic binding.
leftover :: i -> Conduit i o m ()
leftover :: i -> Conduit i o m ()
leftover i
i = (forall a. (() -> Pipe i i o () m a) -> Pipe i i o () m a)
-> Conduit i o 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. (() -> Pipe i i o () m a) -> Pipe i i o () m a)
 -> Conduit i o m ())
-> (forall a. (() -> Pipe i i o () m a) -> Pipe i i o () m a)
-> Conduit i o m ()
forall a b. (a -> b) -> a -> b
$ \() -> Pipe i i o () m a
f -> Pipe i i o () m a -> i -> Pipe i i o () m a
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

-- | Run a conduit pipeline to completion.
runConduit :: Monad m => Conduit () () m r -> m r
runConduit :: Conduit () () m r -> m r
runConduit (Conduit forall a. (r -> Pipe () () () () m a) -> Pipe () () () () m a
f) = Pipe () () () () m r -> m r
forall (m :: * -> *) r. Monad m => Pipe () () () () m r -> m r
runPipe ((r -> Pipe () () () () m r) -> Pipe () () () () m r
forall a. (r -> Pipe () () () () m a) -> Pipe () () () () m a
f r -> Pipe () () () () m r
forall leftOver input output upstream (monad :: * -> *) result.
result -> Pipe leftOver input output upstream monad result
Done)

-- | Run a pure conduit pipeline to completion.
runConduitPure :: Conduit () () Identity r -> r
runConduitPure :: Conduit () () Identity r -> r
runConduitPure = Identity r -> r
forall a. Identity a -> a
runIdentity (Identity r -> r)
-> (Conduit () () Identity r -> Identity r)
-> Conduit () () Identity r
-> r
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Conduit () () Identity r -> Identity r
forall (m :: * -> *) r. Monad m => Conduit () () m r -> m r
runConduit

-- | Run a conduit pipeline in a 'ResourceT' context for acquiring resources.
runConduitRes :: (MonadBracket m, MonadIO m) => Conduit () () (ResourceT m) r -> m r
runConduitRes :: Conduit () () (ResourceT m) r -> m r
runConduitRes = ResourceT m r -> m r
forall (m :: * -> *) a.
(MonadBracket m, MonadIO m) =>
ResourceT m a -> m a
runResourceT (ResourceT m r -> m r)
-> (Conduit () () (ResourceT m) r -> ResourceT m r)
-> Conduit () () (ResourceT m) r
-> m r
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Conduit () () (ResourceT m) r -> ResourceT m r
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 :: 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) <- IO a -> (a -> IO b) -> Conduit i o m (a, Conduit i o m ())
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
    r -> Conduit i o m r
forall (m :: * -> *) a. Monad m => a -> m a
return r
result

-- | Internal: run a @Pipe@
runPipe :: Monad m => Pipe () () () () m r -> m r
runPipe :: Pipe () () () () m r -> m r
runPipe =
    Pipe () () () () m r -> m r
forall (m :: * -> *) input b.
Monad m =>
Pipe () input () () m b -> m b
go
  where
    go :: Pipe () input () () m b -> m b
go (Yield Pipe () input () () m b
p m ()
_ ()) = Pipe () input () () m b -> m b
go Pipe () input () () m b
p
    go (Await input -> Pipe () input () () m b
_ () -> Pipe () input () () m b
p) = Pipe () input () () m b -> m b
go (() -> Pipe () input () () m b
p ())
    go (Done b
r) = b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
r
    go (PipeM m (Pipe () input () () m b)
mp) = m (Pipe () input () () m b)
mp m (Pipe () input () () m b)
-> (Pipe () input () () m b -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Pipe () input () () m b -> m b
go
    go (Leftover Pipe () input () () m b
p ()) = Pipe () input () () m b -> m b
go Pipe () input () () m b
p

-- | Send the output of the first Conduit component to the second
-- Conduit component.
fuse :: Monad m => Conduit a b m () -> Conduit b c m r -> Conduit a c m r
fuse :: 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 a. (r -> Pipe a a c () m a) -> Pipe a a c () m a)
-> Conduit a c m r
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. (r -> Pipe a a c () m a) -> Pipe a a c () m a)
 -> Conduit a c m r)
-> (forall a. (r -> Pipe a a c () m a) -> Pipe a a c () m a)
-> Conduit a c m r
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       -> Pipe a a c () m a -> m () -> c -> Pipe a a c () m a
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 m () -> m () -> m ()
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           -> m (Pipe a a c () m a) -> Pipe a a c () m a
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 m () -> m (Pipe a a c () m a) -> m (Pipe a a c () m a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pipe a a c () m a -> m (Pipe a a c () m a)
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          -> m (Pipe a a c () m a) -> Pipe a a c () m a
forall leftOver input output upstream (monad :: * -> *) result.
monad (Pipe leftOver input output upstream monad result)
-> Pipe leftOver input output upstream monad result
PipeM ((Pipe b b c () m r -> Pipe a a c () m a)
-> m (Pipe b b c () m r) -> m (Pipe a a c () m a)
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 (Pipe a a b () m () -> m () -> b -> Pipe a a b () m ()
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       -> (a -> Pipe a a c () m a)
-> (() -> Pipe a a c () m a) -> Pipe a a c () m a
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 (Pipe a a b () m () -> Pipe a a c () m a)
-> (a -> Pipe a a b () m ()) -> a -> Pipe a a c () m a
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 (Pipe a a b () m () -> Pipe a a c () m a)
-> (() -> Pipe a a b () m ()) -> () -> Pipe a a c () m a
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 (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (() -> Pipe a a b () m ()
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             -> m (Pipe a a c () m a) -> Pipe a a c () m a
forall leftOver input output upstream (monad :: * -> *) result.
monad (Pipe leftOver input output upstream monad result)
-> Pipe leftOver input output upstream monad result
PipeM ((Pipe a a b () m () -> Pipe a a c () m a)
-> m (Pipe a a b () m ()) -> m (Pipe a a c () m a)
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     -> Pipe a a c () m a -> a -> Pipe a a c () m a
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 (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ((() -> Pipe a a b () m ()) -> Pipe a a b () m ()
forall a. (() -> Pipe a a b () m a) -> Pipe a a b () m a
left0 () -> Pipe a a b () m ()
forall leftOver input output upstream (monad :: * -> *) result.
result -> Pipe leftOver input output upstream monad result
Done) ((r -> Pipe b b c () m r) -> Pipe b b c () m r
forall a. (r -> Pipe b b c () m a) -> Pipe b b c () m a
right0 r -> Pipe b b c () m r
forall leftOver input output upstream (monad :: * -> *) result.
result -> Pipe leftOver input output upstream monad result
Done)

{- FIXME for later, if we add resourcet
-- | Safely acquire a resource and register a cleanup action for it,
-- in the context of a 'Conduit'.
bracketConduit :: MonadResource m
               => IO a -- ^ acquire
               -> (a -> IO ()) -- ^ cleanup
               -> (a -> Conduit i o m r)
               -> Conduit i o m r
bracketConduit alloc cleanup inner = Conduit $ \rest -> PipeM $ do
    (key, val) <- allocate alloc cleanup
    return $ unConduit (addCleanup (const $ release key) (inside seed)) rest

addCleanup :: Monad m
           => (Bool -> m ())
           -> Conduit i o m r
           -> Conduit i o m r
addCleanup cleanup (Conduit c0) = Conduit $ \rest -> let
    go (Done r) = PipeM (cleanup True >> return (rest r))
    go (Yield src close x) = Yield
        (go src)
        (cleanup False >> close)
        x
    go (PipeM msrc) = PipeM (liftM (go) msrc)
    go (Await p c) = Await
        (go . p)
        (go . c)
    go (Leftover p i) = Leftover (go p) i
    in go (c0 Done)
-}

newtype ZipSink i m r = ZipSink { ZipSink i m r -> Conduit i () m r
getZipSink :: Conduit i () m r }

instance Monad m => Functor (ZipSink i m) where
    fmap :: (a -> b) -> ZipSink i m a -> ZipSink i m b
fmap a -> b
f (ZipSink Conduit i () m a
x) = Conduit i () m b -> ZipSink i m b
forall i (m :: * -> *) r. Conduit i () m r -> ZipSink i m r
ZipSink ((a -> b) -> Conduit i () m a -> Conduit i () m b
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 :: a -> ZipSink i m a
pure  = Conduit i () m a -> ZipSink i m a
forall i (m :: * -> *) r. Conduit i () m r -> ZipSink i m r
ZipSink (Conduit i () m a -> ZipSink i m a)
-> (a -> Conduit i () m a) -> a -> ZipSink i m a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> Conduit i () m a
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) <*> :: 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) =
      Conduit i () m b -> ZipSink i m b
forall i (m :: * -> *) r. Conduit i () m r -> ZipSink i m r
ZipSink (Conduit i () m b -> ZipSink i m b)
-> Conduit i () m b -> ZipSink i m b
forall a b. (a -> b) -> a -> b
$ (forall a. (b -> Pipe i i () () m a) -> Pipe i i () () m a)
-> Conduit i () m 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 -> Pipe i i () () m a) -> Pipe i i () () m a)
 -> Conduit i () m b)
-> (forall a. (b -> Pipe i i () () m a) -> Pipe i i () () m a)
-> Conduit i () m b
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
_ = Void -> Pipe i 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) = Void -> Pipe i i () () m a
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 = m (Pipe i i () () m a) -> Pipe i i () () m a
forall leftOver input output upstream (monad :: * -> *) result.
monad (Pipe leftOver input output upstream monad result)
-> Pipe leftOver input output upstream monad result
PipeM ((Pipe Void i () () m (a -> b) -> Pipe i i () () m a)
-> m (Pipe Void i () () m (a -> b)) -> m (Pipe i i () () m a)
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) = m (Pipe i i () () m a) -> Pipe i i () () m a
forall leftOver input output upstream (monad :: * -> *) result.
monad (Pipe leftOver input output upstream monad result)
-> Pipe leftOver input output upstream monad result
PipeM ((Pipe Void i () () m a -> Pipe i i () () m a)
-> m (Pipe Void i () () m a) -> m (Pipe i i () () m a)
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) = (i -> Pipe i i () () m a)
-> (() -> Pipe i i () () m a) -> Pipe i i () () m a
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{} = (i -> Pipe i i () () m a)
-> (() -> Pipe i i () () m a) -> Pipe i i () () m a
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) = (i -> Pipe i i () () m a)
-> (() -> Pipe i i () () m a) -> Pipe i i () () m a
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 (Pipe i i () () m (a -> b) -> Pipe Void i () () m (a -> b)
forall (m :: * -> *) i o u r l.
Monad m =>
Pipe i i o u m r -> Pipe l i o u m r
injectLeftovers (((a -> b) -> Pipe i i () () m (a -> b))
-> Pipe i i () () m (a -> b)
forall a. ((a -> b) -> Pipe i i () () m a) -> Pipe i i () () m a
f0 (a -> b) -> Pipe i i () () m (a -> b)
forall leftOver input output upstream (monad :: * -> *) result.
result -> Pipe leftOver input output upstream monad result
Done)) (Pipe i i () () m a -> Pipe Void i () () m a
forall (m :: * -> *) i o u r l.
Monad m =>
Pipe i i o u m r -> Pipe l i o u m r
injectLeftovers ((a -> Pipe i i () () m a) -> Pipe i i () () m a
forall a. (a -> Pipe i i () () m a) -> Pipe i i () () m a
x0 a -> Pipe i i () () m a
forall leftOver input output upstream (monad :: * -> *) result.
result -> Pipe leftOver input output upstream monad result
Done))

data Void

absurd :: Void -> a
absurd :: Void -> a
absurd Void
_ = String -> a
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 :: Pipe i i o u m r -> Pipe l i o u m r
injectLeftovers =
    [i] -> Pipe i i o u m r -> Pipe l i o u m r
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) = Pipe leftOver input output upstream monad result
-> monad ()
-> output
-> Pipe leftOver input output upstream monad result
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 (Pipe input input output upstream monad result
 -> Pipe leftOver input output upstream monad result)
-> Pipe input input output upstream monad result
-> Pipe leftOver input output upstream monad result
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) = (input -> Pipe leftOver input output upstream monad result)
-> (upstream -> Pipe leftOver input output upstream monad result)
-> Pipe leftOver input output upstream monad result
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 [] (Pipe input input output upstream monad result
 -> Pipe leftOver input output upstream monad result)
-> (input -> Pipe input input output upstream monad result)
-> input
-> Pipe leftOver input output upstream monad result
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 [] (Pipe input input output upstream monad result
 -> Pipe leftOver input output upstream monad result)
-> (upstream -> Pipe input input output upstream monad result)
-> upstream
-> Pipe leftOver input output upstream monad result
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) = result -> Pipe leftOver input output upstream monad result
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) = monad (Pipe leftOver input output upstream monad result)
-> Pipe leftOver input output upstream monad result
forall leftOver input output upstream (monad :: * -> *) result.
monad (Pipe leftOver input output upstream monad result)
-> Pipe leftOver input output upstream monad result
PipeM ((Pipe input input output upstream monad result
 -> Pipe leftOver input output upstream monad result)
-> monad (Pipe input input output upstream monad result)
-> monad (Pipe leftOver input output upstream monad result)
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
linput -> [input] -> [input]
forall a. a -> [a] -> [a]
:[input]
ls) Pipe input input output upstream monad result
p

---------------------
-- ResourceT
---------------------
newtype ResourceT m a = ResourceT { ResourceT m a -> PrimVar IO ReleaseMap -> m a
unResourceT :: PrimVar IO ReleaseMap -> m a }
instance Functor m => Functor (ResourceT m) where
    fmap :: (a -> b) -> ResourceT m a -> ResourceT m b
fmap a -> b
f (ResourceT PrimVar IO ReleaseMap -> m a
m) = (PrimVar IO ReleaseMap -> m b) -> ResourceT m b
forall (m :: * -> *) a.
(PrimVar IO ReleaseMap -> m a) -> ResourceT m a
ResourceT ((PrimVar IO ReleaseMap -> m b) -> ResourceT m b)
-> (PrimVar IO ReleaseMap -> m b) -> ResourceT m b
forall a b. (a -> b) -> a -> b
$ \PrimVar IO ReleaseMap
r -> (a -> b) -> m a -> m b
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 :: a -> ResourceT m a
pure = (IORef ReleaseMap -> m a) -> ResourceT m a
forall (m :: * -> *) a.
(PrimVar IO ReleaseMap -> m a) -> ResourceT m a
ResourceT ((IORef ReleaseMap -> m a) -> ResourceT m a)
-> (a -> IORef ReleaseMap -> m a) -> a -> ResourceT m a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. m a -> IORef ReleaseMap -> m a
forall a b. a -> b -> a
const (m a -> IORef ReleaseMap -> m a)
-> (a -> m a) -> a -> IORef ReleaseMap -> m a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ResourceT PrimVar IO ReleaseMap -> m (a -> b)
mf <*> :: ResourceT m (a -> b) -> ResourceT m a -> ResourceT m b
<*> ResourceT PrimVar IO ReleaseMap -> m a
ma = (PrimVar IO ReleaseMap -> m b) -> ResourceT m b
forall (m :: * -> *) a.
(PrimVar IO ReleaseMap -> m a) -> ResourceT m a
ResourceT ((PrimVar IO ReleaseMap -> m b) -> ResourceT m b)
-> (PrimVar IO ReleaseMap -> m b) -> ResourceT m b
forall a b. (a -> b) -> a -> b
$ \PrimVar IO ReleaseMap
r ->
        PrimVar IO ReleaseMap -> m (a -> b)
mf PrimVar IO ReleaseMap
r m (a -> b) -> m a -> m b
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 >>= :: ResourceT m a -> (a -> ResourceT m b) -> ResourceT m b
>>= a -> ResourceT m b
f = (PrimVar IO ReleaseMap -> m b) -> ResourceT m b
forall (m :: * -> *) a.
(PrimVar IO ReleaseMap -> m a) -> ResourceT m a
ResourceT ((PrimVar IO ReleaseMap -> m b) -> ResourceT m b)
-> (PrimVar IO ReleaseMap -> m b) -> ResourceT m b
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 :: m a -> ResourceT m a
lift = (IORef ReleaseMap -> m a) -> ResourceT m a
forall (m :: * -> *) a.
(PrimVar IO ReleaseMap -> m a) -> ResourceT m a
ResourceT ((IORef ReleaseMap -> m a) -> ResourceT m a)
-> (m a -> IORef ReleaseMap -> m a) -> m a -> ResourceT m a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. m a -> IORef ReleaseMap -> m a
forall a b. a -> b -> a
const
instance MonadIO m => MonadIO (ResourceT m) where
    liftIO :: IO a -> ResourceT m a
liftIO = m a -> ResourceT m a
forall (trans :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans trans, Monad m) =>
m a -> trans m a
lift (m a -> ResourceT m a) -> (IO a -> m a) -> IO a -> ResourceT m a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
instance MonadThrow m => MonadThrow (ResourceT m) where
    throw :: e -> ResourceT m a
throw = m a -> ResourceT m a
forall (trans :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans trans, Monad m) =>
m a -> trans m a
lift (m a -> ResourceT m a) -> (e -> m a) -> e -> ResourceT m a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw
instance MonadCatch m => MonadCatch (ResourceT m) where
    catch :: ResourceT m a -> (e -> ResourceT m a) -> ResourceT m a
catch (ResourceT PrimVar IO ReleaseMap -> m a
f) e -> ResourceT m a
g = (PrimVar IO ReleaseMap -> m a) -> ResourceT m a
forall (m :: * -> *) a.
(PrimVar IO ReleaseMap -> m a) -> ResourceT m a
ResourceT ((PrimVar IO ReleaseMap -> m a) -> ResourceT m a)
-> (PrimVar IO ReleaseMap -> m a) -> ResourceT m a
forall a b. (a -> b) -> a -> b
$ \PrimVar IO ReleaseMap
env -> PrimVar IO ReleaseMap -> m a
f PrimVar IO ReleaseMap
env m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \e
e -> ResourceT m a -> PrimVar IO ReleaseMap -> m a
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 :: 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 = (PrimVar IO ReleaseMap -> m b) -> ResourceT m b
forall (m :: * -> *) a.
(PrimVar IO ReleaseMap -> m a) -> ResourceT m a
ResourceT ((PrimVar IO ReleaseMap -> m b) -> ResourceT m b)
-> (PrimVar IO ReleaseMap -> m b) -> ResourceT m b
forall a b. (a -> b) -> a -> b
$ \PrimVar IO ReleaseMap
env -> m a
-> (a -> b -> m ignored1)
-> (a -> SomeException -> m ignored2)
-> (a -> m b)
-> m b
forall (m :: * -> *) a b ignored1 ignored2.
MonadBracket m =>
m a
-> (a -> b -> m ignored1)
-> (a -> SomeException -> m ignored2)
-> (a -> m b)
-> m b
generalBracket
        (ResourceT m a -> PrimVar IO ReleaseMap -> m a
forall (m :: * -> *) a.
ResourceT m a -> PrimVar IO ReleaseMap -> m a
unResourceT ResourceT m a
acquire PrimVar IO ReleaseMap
env)
        (\a
x b
y -> ResourceT m ignored1 -> PrimVar IO ReleaseMap -> m ignored1
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 -> ResourceT m ignored2 -> PrimVar IO ReleaseMap -> m ignored2
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 -> ResourceT m b -> PrimVar IO ReleaseMap -> m b
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 ()))] -- FIXME use a proper Map?
  | ReleaseMapClosed

data ReleaseType = ReleaseEarly
                 | ReleaseNormal
                 | ReleaseException

type RefCount = Word
type NextKey = Word

runResourceT :: (MonadBracket m, MonadIO m) => ResourceT m a -> m a
runResourceT :: ResourceT m a -> m a
runResourceT (ResourceT PrimVar IO ReleaseMap -> m a
inner) = m (IORef ReleaseMap)
-> (IORef ReleaseMap -> a -> m ())
-> (IORef ReleaseMap -> SomeException -> m ())
-> (IORef ReleaseMap -> m a)
-> m a
forall (m :: * -> *) a b ignored1 ignored2.
MonadBracket m =>
m a
-> (a -> b -> m ignored1)
-> (a -> SomeException -> m ignored2)
-> (a -> m b)
-> m b
generalBracket
    (IO (IORef ReleaseMap) -> m (IORef ReleaseMap)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef ReleaseMap) -> m (IORef ReleaseMap))
-> IO (IORef ReleaseMap) -> m (IORef ReleaseMap)
forall a b. (a -> b) -> a -> b
$ ReleaseMap -> IO (PrimVar IO ReleaseMap)
forall (m :: * -> *) a. PrimMonad m => a -> m (PrimVar m a)
primVarNew (ReleaseMap -> IO (PrimVar IO ReleaseMap))
-> ReleaseMap -> IO (PrimVar IO ReleaseMap)
forall a b. (a -> b) -> a -> b
$ NextKey
-> NextKey -> [(NextKey, ReleaseType -> IO ())] -> ReleaseMap
ReleaseMap NextKey
forall a. Bounded a => a
maxBound (NextKey
forall a. Bounded a => a
minBound NextKey -> NextKey -> NextKey
forall a. Additive a => a -> a -> a
+ NextKey
1) [])
    (\IORef ReleaseMap
state a
_res -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef ReleaseMap -> ReleaseType -> IO ()
cleanup IORef ReleaseMap
state ReleaseType
ReleaseNormal)
    (\IORef ReleaseMap
state SomeException
_exc -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef ReleaseMap -> ReleaseType -> IO ()
cleanup IORef ReleaseMap
state ReleaseType
ReleaseException)
    IORef ReleaseMap -> m a
PrimVar IO ReleaseMap -> m a
inner
  where
    cleanup :: IORef ReleaseMap -> ReleaseType -> IO ()
cleanup IORef ReleaseMap
istate ReleaseType
rtype = do
        Maybe [(NextKey, ReleaseType -> IO ())]
mm <- IORef ReleaseMap
-> (ReleaseMap
    -> (ReleaseMap, Maybe [(NextKey, ReleaseType -> IO ())]))
-> IO (Maybe [(NextKey, ReleaseType -> IO ())])
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef ReleaseMap
istate ((ReleaseMap
  -> (ReleaseMap, Maybe [(NextKey, ReleaseType -> IO ())]))
 -> IO (Maybe [(NextKey, ReleaseType -> IO ())]))
-> (ReleaseMap
    -> (ReleaseMap, Maybe [(NextKey, ReleaseType -> IO ())]))
-> IO (Maybe [(NextKey, ReleaseType -> IO ())])
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 NextKey -> NextKey -> Difference NextKey
forall a. Subtractive a => a -> a -> Difference a
- NextKey
1
                    in if NextKey
Difference NextKey
rf' NextKey -> NextKey -> Bool
forall a. Eq a => a -> a -> Bool
== NextKey
forall a. Bounded a => a
minBound
                            then (ReleaseMap
ReleaseMapClosed, [(NextKey, ReleaseType -> IO ())]
-> Maybe [(NextKey, ReleaseType -> IO ())]
forall a. a -> Maybe a
Just [(NextKey, ReleaseType -> IO ())]
m)
                            else (NextKey
-> NextKey -> [(NextKey, ReleaseType -> IO ())] -> ReleaseMap
ReleaseMap NextKey
nk NextKey
Difference NextKey
rf' [(NextKey, ReleaseType -> IO ())]
m, Maybe [(NextKey, ReleaseType -> IO ())]
forall a. Maybe a
Nothing)
                ReleaseMap
ReleaseMapClosed -> String -> (ReleaseMap, Maybe [(NextKey, ReleaseType -> IO ())])
forall a. HasCallStack => String -> a
error String
"runResourceT: cleanup on ReleaseMapClosed"
        case Maybe [(NextKey, ReleaseType -> IO ())]
mm of
            Just [(NextKey, ReleaseType -> IO ())]
m -> ((NextKey, ReleaseType -> IO ()) -> IO ())
-> [(NextKey, ReleaseType -> IO ())] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(NextKey
_, ReleaseType -> IO ()
x) -> IO () -> IO ()
forall (m :: * -> *) a. MonadCatch m => m a -> m ()
ignoreExceptions (ReleaseType -> IO ()
x ReleaseType
rtype)) [(NextKey, ReleaseType -> IO ())]
m
            Maybe [(NextKey, ReleaseType -> IO ())]
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      where
        ignoreExceptions :: m a -> m ()
ignoreExceptions m a
io = m a -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void m a
io m () -> (SomeException -> m ()) -> m ()
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\(SomeException
_ :: SomeException) -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

allocate :: (MonadResource m, MonadIO n) => IO a -> (a -> IO b) -> m (a, n ())
allocate :: IO a -> (a -> IO b) -> m (a, n ())
allocate IO a
acquire a -> IO b
release = ResourceT IO (a, n ()) -> m (a, n ())
forall (m :: * -> *) a. MonadResource m => ResourceT IO a -> m a
liftResourceT (ResourceT IO (a, n ()) -> m (a, n ()))
-> ResourceT IO (a, n ()) -> m (a, n ())
forall a b. (a -> b) -> a -> b
$ (PrimVar IO ReleaseMap -> IO (a, n ())) -> ResourceT IO (a, n ())
forall (m :: * -> *) a.
(PrimVar IO ReleaseMap -> m a) -> ResourceT m a
ResourceT ((PrimVar IO ReleaseMap -> IO (a, n ())) -> ResourceT IO (a, n ()))
-> (PrimVar IO ReleaseMap -> IO (a, n ()))
-> ResourceT IO (a, n ())
forall a b. (a -> b) -> a -> b
$ \PrimVar IO ReleaseMap
istate -> IO (a, n ()) -> IO (a, n ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (a, n ()) -> IO (a, n ())) -> IO (a, n ()) -> IO (a, n ())
forall a b. (a -> b) -> a -> b
$ IO (a, n ()) -> IO (a, n ())
forall a. IO a -> IO a
mask_ (IO (a, n ()) -> IO (a, n ())) -> IO (a, n ()) -> IO (a, n ())
forall a b. (a -> b) -> a -> b
$ do
    a
a <- IO a
acquire
    NextKey
key <- IORef ReleaseMap
-> (ReleaseMap -> (ReleaseMap, NextKey)) -> IO NextKey
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef ReleaseMap
PrimVar IO ReleaseMap
istate ((ReleaseMap -> (ReleaseMap, NextKey)) -> IO NextKey)
-> (ReleaseMap -> (ReleaseMap, NextKey)) -> IO NextKey
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 NextKey -> NextKey -> Difference NextKey
forall a. Subtractive a => a -> a -> Difference a
- NextKey
1) NextKey
rf ((NextKey
key, IO () -> ReleaseType -> IO ()
forall a b. a -> b -> a
const (IO () -> ReleaseType -> IO ()) -> IO () -> ReleaseType -> IO ()
forall a b. (a -> b) -> a -> b
$ IO b -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO b -> IO ()) -> IO b -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> IO b
release a
a) (NextKey, ReleaseType -> IO ())
-> [(NextKey, ReleaseType -> IO ())]
-> [(NextKey, ReleaseType -> IO ())]
forall a. a -> [a] -> [a]
: [(NextKey, ReleaseType -> IO ())]
m)
                , NextKey
key
                )
            ReleaseMap
ReleaseMapClosed -> String -> (ReleaseMap, NextKey)
forall a. HasCallStack => String -> a
error String
"allocate: ReleaseMapClosed"
    let release' :: IO ()
release' = IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef ReleaseMap
-> (ReleaseMap -> (ReleaseMap, IO ())) -> IO (IO ())
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef ReleaseMap
PrimVar IO ReleaseMap
istate ((ReleaseMap -> (ReleaseMap, IO ())) -> IO (IO ()))
-> (ReleaseMap -> (ReleaseMap, IO ())) -> IO (IO ())
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 []), () -> IO ()
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 NextKey -> NextKey -> Bool
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 ([(NextKey, ReleaseType -> IO ())]
 -> [(NextKey, ReleaseType -> IO ())])
-> ([(NextKey, ReleaseType -> IO ())]
    -> [(NextKey, ReleaseType -> IO ())])
-> [(NextKey, ReleaseType -> IO ())]
-> [(NextKey, ReleaseType -> IO ())]
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)(NextKey, ReleaseType -> IO ())
-> [(NextKey, ReleaseType -> IO ())]
-> [(NextKey, ReleaseType -> IO ())]
forall a. a -> [a] -> [a]
:)) [(NextKey, ReleaseType -> IO ())]
rest
                     in ([(NextKey, ReleaseType -> IO ())]
 -> [(NextKey, ReleaseType -> IO ())])
-> [(NextKey, ReleaseType -> IO ())] -> (ReleaseMap, IO ())
loop [(NextKey, ReleaseType -> IO ())]
-> [(NextKey, ReleaseType -> IO ())]
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id [(NextKey, ReleaseType -> IO ())]
m
                ReleaseMap
ReleaseMapClosed -> String -> (ReleaseMap, IO ())
forall a. HasCallStack => String -> a
error String
"allocate: ReleaseMapClosed (2)"
    (a, n ()) -> IO (a, n ())
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, IO () -> n ()
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 :: ResourceT IO a -> ResourceT m a
liftResourceT (ResourceT PrimVar IO ReleaseMap -> IO a
f) = (PrimVar IO ReleaseMap -> m a) -> ResourceT m a
forall (m :: * -> *) a.
(PrimVar IO ReleaseMap -> m a) -> ResourceT m a
ResourceT (IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a)
-> (IORef ReleaseMap -> IO a) -> IORef ReleaseMap -> m a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. IORef ReleaseMap -> IO a
PrimVar IO ReleaseMap -> IO a
f)
instance MonadResource m => MonadResource (Conduit i o m) where
    liftResourceT :: ResourceT IO a -> Conduit i o m a
liftResourceT = m a -> Conduit i o m a
forall (trans :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans trans, Monad m) =>
m a -> trans m a
lift (m a -> Conduit i o m a)
-> (ResourceT IO a -> m a) -> ResourceT IO a -> Conduit i o m a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ResourceT IO a -> m a
forall (m :: * -> *) a. MonadResource m => ResourceT IO a -> m a
liftResourceT