-- 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 :: 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

-- | 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
    { 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 for a value from upstream.
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

-- | Send a value downstream.
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

-- | 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 :: 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

-- | Provide leftover input to be consumed by the next component in
-- the current monadic binding.
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

-- | Run a conduit pipeline to completion.
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)

-- | Run a pure conduit pipeline to completion.
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

-- | Run a conduit pipeline in a 'ResourceT' context for acquiring resources.
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

-- | Internal: run a @Pipe@
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

-- | 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 :: 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)

{- 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 { 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

---------------------
-- ResourceT
---------------------
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 ()))] -- 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 :: 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