{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE UndecidableInstances  #-}
{-# OPTIONS_GHC -Wno-orphans #-}
-- | This module exports 'ToSourceIO' and 'FromSourceIO' for 'ConduitT' instances.
module Servant.Conduit (
    ConduitToSourceIO (..),
    ) where

import           Control.Monad.IO.Class
                 (MonadIO (..))
import           Control.Monad.IO.Unlift
                 (MonadUnliftIO (..))
import           Control.Monad.Trans.Resource
                 (ResourceT, runResourceT)
import           Data.Conduit.Internal
                 (ConduitT (..), Pipe (..))
import           Servant.API.Stream
import qualified Servant.Types.SourceT        as S

-- | Helper class to implement @'ToSourceIO' 'ConduitT'@ instance
-- for various monads.
class ConduitToSourceIO m where
    conduitToSourceIO :: ConduitT i o m () -> SourceIO o

instance ConduitToSourceIO IO where
    conduitToSourceIO :: forall i o. ConduitT i o IO () -> SourceIO o
conduitToSourceIO (ConduitT forall b. (() -> Pipe i i o () IO b) -> Pipe i i o () IO b
con) = (forall b. (StepT IO o -> IO b) -> IO b) -> SourceT IO o
forall (m :: * -> *) a.
(forall b. (StepT m a -> m b) -> m b) -> SourceT m a
S.SourceT ((StepT IO o -> IO b) -> StepT IO o -> IO b
forall a b. (a -> b) -> a -> b
$ Pipe i i o () IO () -> StepT IO o
forall {m :: * -> *} {l} {i} {a}.
Functor m =>
Pipe l i a () m () -> StepT m a
go ((() -> Pipe i i o () IO ()) -> Pipe i i o () IO ()
forall b. (() -> Pipe i i o () IO b) -> Pipe i i o () IO b
con () -> Pipe i i o () IO ()
forall l i o u (m :: * -> *) r. r -> Pipe l i o u m r
Done)) where
        go :: Pipe l i a () m () -> StepT m a
go Pipe l i a () m ()
p0 = case Pipe l i a () m ()
p0 of
            Done ()          -> StepT m a
forall (m :: * -> *) a. StepT m a
S.Stop
            HaveOutput Pipe l i a () m ()
p a
o   -> a -> StepT m a -> StepT m a
forall (m :: * -> *) a. a -> StepT m a -> StepT m a
S.Yield a
o (Pipe l i a () m () -> StepT m a
go Pipe l i a () m ()
p)
            NeedInput i -> Pipe l i a () m ()
_ip () -> Pipe l i a () m ()
up -> StepT m a -> StepT m a
forall (m :: * -> *) a. StepT m a -> StepT m a
S.Skip (Pipe l i a () m () -> StepT m a
go (() -> Pipe l i a () m ()
up ()))
            PipeM m (Pipe l i a () m ())
m          -> m (StepT m a) -> StepT m a
forall (m :: * -> *) a. m (StepT m a) -> StepT m a
S.Effect (m (StepT m a) -> StepT m a) -> m (StepT m a) -> StepT m a
forall a b. (a -> b) -> a -> b
$ (Pipe l i a () m () -> StepT m a)
-> m (Pipe l i a () m ()) -> m (StepT m a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Pipe l i a () m () -> StepT m a
go m (Pipe l i a () m ())
m
            Leftover Pipe l i a () m ()
p l
_l    -> StepT m a -> StepT m a
forall (m :: * -> *) a. StepT m a -> StepT m a
S.Skip (Pipe l i a () m () -> StepT m a
go Pipe l i a () m ()
p)

instance m ~ IO => ConduitToSourceIO (ResourceT m) where
    conduitToSourceIO :: forall i o. ConduitT i o (ResourceT m) () -> SourceIO o
conduitToSourceIO (ConduitT forall b.
(() -> Pipe i i o () (ResourceT m) b)
-> Pipe i i o () (ResourceT m) b
con) =
        (forall b. (StepT IO o -> IO b) -> IO b) -> SourceT IO o
forall (m :: * -> *) a.
(forall b. (StepT m a -> m b) -> m b) -> SourceT m a
S.SourceT ((forall b. (StepT IO o -> IO b) -> IO b) -> SourceT IO o)
-> (forall b. (StepT IO o -> IO b) -> IO b) -> SourceT IO o
forall a b. (a -> b) -> a -> b
$ \StepT IO o -> IO b
k ->
        ResourceT IO b -> IO b
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT IO b -> IO b) -> ResourceT IO b -> IO b
forall a b. (a -> b) -> a -> b
$ ((forall a. ResourceT IO a -> IO a) -> IO b) -> ResourceT IO b
forall b.
((forall a. ResourceT IO a -> IO a) -> IO b) -> ResourceT IO b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. ResourceT IO a -> IO a) -> IO b) -> ResourceT IO b)
-> ((forall a. ResourceT IO a -> IO a) -> IO b) -> ResourceT IO b
forall a b. (a -> b) -> a -> b
$ \forall a. ResourceT IO a -> IO a
runRes ->
        StepT IO o -> IO b
k ((forall x. ResourceT m x -> m x)
-> Pipe i i o () (ResourceT m) () -> StepT IO o
forall i o.
(forall x. ResourceT m x -> m x)
-> Pipe i i o () (ResourceT m) () -> StepT IO o
go ResourceT m x -> m x
ResourceT IO x -> IO x
forall x. ResourceT m x -> m x
forall a. ResourceT IO a -> IO a
runRes ((() -> Pipe i i o () (ResourceT m) ())
-> Pipe i i o () (ResourceT m) ()
forall b.
(() -> Pipe i i o () (ResourceT m) b)
-> Pipe i i o () (ResourceT m) b
con () -> Pipe i i o () (ResourceT m) ()
forall l i o u (m :: * -> *) r. r -> Pipe l i o u m r
Done))
      where
        go :: (forall x. ResourceT m x -> m x)
           -> Pipe i i o () (ResourceT m) ()
           -> S.StepT IO o
        go :: forall i o.
(forall x. ResourceT m x -> m x)
-> Pipe i i o () (ResourceT m) () -> StepT IO o
go forall x. ResourceT m x -> m x
_      (Done ())          = StepT IO o
forall (m :: * -> *) a. StepT m a
S.Stop
        go forall x. ResourceT m x -> m x
runRes (HaveOutput Pipe i i o () (ResourceT m) ()
p o
o)   = o -> StepT IO o -> StepT IO o
forall (m :: * -> *) a. a -> StepT m a -> StepT m a
S.Yield o
o ((forall x. ResourceT m x -> m x)
-> Pipe i i o () (ResourceT m) () -> StepT IO o
forall i o.
(forall x. ResourceT m x -> m x)
-> Pipe i i o () (ResourceT m) () -> StepT IO o
go ResourceT m x -> m x
forall x. ResourceT m x -> m x
runRes Pipe i i o () (ResourceT m) ()
p)
        go forall x. ResourceT m x -> m x
runRes (NeedInput i -> Pipe i i o () (ResourceT m) ()
_ip () -> Pipe i i o () (ResourceT m) ()
up) = StepT IO o -> StepT IO o
forall (m :: * -> *) a. StepT m a -> StepT m a
S.Skip ((forall x. ResourceT m x -> m x)
-> Pipe i i o () (ResourceT m) () -> StepT IO o
forall i o.
(forall x. ResourceT m x -> m x)
-> Pipe i i o () (ResourceT m) () -> StepT IO o
go ResourceT m x -> m x
forall x. ResourceT m x -> m x
runRes (() -> Pipe i i o () (ResourceT m) ()
up ()))
        go forall x. ResourceT m x -> m x
runRes (PipeM ResourceT m (Pipe i i o () (ResourceT m) ())
m)          = IO (StepT IO o) -> StepT IO o
forall (m :: * -> *) a. m (StepT m a) -> StepT m a
S.Effect (IO (StepT IO o) -> StepT IO o) -> IO (StepT IO o) -> StepT IO o
forall a b. (a -> b) -> a -> b
$ ResourceT m (StepT IO o) -> m (StepT IO o)
forall x. ResourceT m x -> m x
runRes (ResourceT m (StepT IO o) -> m (StepT IO o))
-> ResourceT m (StepT IO o) -> m (StepT IO o)
forall a b. (a -> b) -> a -> b
$ (Pipe i i o () (ResourceT m) () -> StepT IO o)
-> ResourceT m (Pipe i i o () (ResourceT m) ())
-> ResourceT m (StepT IO o)
forall a b. (a -> b) -> ResourceT m a -> ResourceT m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((forall x. ResourceT m x -> m x)
-> Pipe i i o () (ResourceT m) () -> StepT IO o
forall i o.
(forall x. ResourceT m x -> m x)
-> Pipe i i o () (ResourceT m) () -> StepT IO o
go ResourceT m x -> m x
forall x. ResourceT m x -> m x
runRes) ResourceT m (Pipe i i o () (ResourceT m) ())
m
        go forall x. ResourceT m x -> m x
runRes (Leftover Pipe i i o () (ResourceT m) ()
p i
_l)    = StepT IO o -> StepT IO o
forall (m :: * -> *) a. StepT m a -> StepT m a
S.Skip ((forall x. ResourceT m x -> m x)
-> Pipe i i o () (ResourceT m) () -> StepT IO o
forall i o.
(forall x. ResourceT m x -> m x)
-> Pipe i i o () (ResourceT m) () -> StepT IO o
go ResourceT m x -> m x
forall x. ResourceT m x -> m x
runRes Pipe i i o () (ResourceT m) ()
p)

instance (ConduitToSourceIO m, r ~ ())
    => ToSourceIO o (ConduitT i o m r)
  where
    toSourceIO :: ConduitT i o m r -> SourceIO o
toSourceIO = ConduitT i o m r -> SourceIO o
ConduitT i o m () -> SourceIO o
forall i o. ConduitT i o m () -> SourceIO o
forall (m :: * -> *) i o.
ConduitToSourceIO m =>
ConduitT i o m () -> SourceIO o
conduitToSourceIO

instance (MonadIO m, r ~ ()) => FromSourceIO o (ConduitT i o m r) where
    fromSourceIO :: SourceIO o -> IO (ConduitT i o m r)
fromSourceIO SourceIO o
src = ConduitT i o m r -> IO (ConduitT i o m r)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ConduitT i o m r -> IO (ConduitT i o m r))
-> ConduitT i o m r -> IO (ConduitT i o m r)
forall a b. (a -> b) -> a -> b
$
        (forall b. (r -> Pipe i i o () m b) -> Pipe i i o () m b)
-> ConduitT i o m r
forall i o (m :: * -> *) r.
(forall b. (r -> Pipe i i o () m b) -> Pipe i i o () m b)
-> ConduitT i o m r
ConduitT ((forall b. (r -> Pipe i i o () m b) -> Pipe i i o () m b)
 -> ConduitT i o m r)
-> (forall b. (r -> Pipe i i o () m b) -> Pipe i i o () m b)
-> ConduitT i o m r
forall a b. (a -> b) -> a -> b
$ \r -> Pipe i i o () m b
con ->
        m (Pipe i i o () m b) -> Pipe i i o () m b
forall l i o u (m :: * -> *) r.
m (Pipe l i o u m r) -> Pipe l i o u m r
PipeM (m (Pipe i i o () m b) -> Pipe i i o () m b)
-> m (Pipe i i o () m b) -> Pipe i i o () m b
forall a b. (a -> b) -> a -> b
$ IO (Pipe i i o () m b) -> m (Pipe i i o () m b)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Pipe i i o () m b) -> m (Pipe i i o () m b))
-> IO (Pipe i i o () m b) -> m (Pipe i i o () m b)
forall a b. (a -> b) -> a -> b
$ SourceIO o -> forall b. (StepT IO o -> IO b) -> IO b
forall (m :: * -> *) a.
SourceT m a -> forall b. (StepT m a -> m b) -> m b
S.unSourceT SourceIO o
src ((StepT IO o -> IO (Pipe i i o () m b)) -> IO (Pipe i i o () m b))
-> (StepT IO o -> IO (Pipe i i o () m b)) -> IO (Pipe i i o () m b)
forall a b. (a -> b) -> a -> b
$ \StepT IO o
step ->
        (() -> Pipe i i o () m b) -> StepT IO o -> IO (Pipe i i o () m b)
forall b.
MonadIO m =>
(() -> Pipe i i o () m b) -> StepT IO o -> IO (Pipe i i o () m b)
loop r -> Pipe i i o () m b
() -> Pipe i i o () m b
con StepT IO o
step
      where
        loop :: MonadIO m => (() -> Pipe i i o () m b) -> S.StepT IO o -> IO (Pipe i i o () m b)
        loop :: forall b.
MonadIO m =>
(() -> Pipe i i o () m b) -> StepT IO o -> IO (Pipe i i o () m b)
loop  () -> Pipe i i o () m b
con StepT IO o
S.Stop        = Pipe i i o () m b -> IO (Pipe i i o () m b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Pipe i i o () m b
con ())
        loop () -> Pipe i i o () m b
_con (S.Error String
err) = String -> IO (Pipe i i o () m b)
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
        loop  () -> Pipe i i o () m b
con (S.Skip StepT IO o
s)    = (() -> Pipe i i o () m b) -> StepT IO o -> IO (Pipe i i o () m b)
forall b.
MonadIO m =>
(() -> Pipe i i o () m b) -> StepT IO o -> IO (Pipe i i o () m b)
loop () -> Pipe i i o () m b
con StepT IO o
s
        loop  () -> Pipe i i o () m b
con (S.Effect IO (StepT IO o)
ms) = IO (StepT IO o)
ms IO (StepT IO o)
-> (StepT IO o -> IO (Pipe i i o () m b)) -> IO (Pipe i i o () m b)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (() -> Pipe i i o () m b) -> StepT IO o -> IO (Pipe i i o () m b)
forall b.
MonadIO m =>
(() -> Pipe i i o () m b) -> StepT IO o -> IO (Pipe i i o () m b)
loop () -> Pipe i i o () m b
con
        loop  () -> Pipe i i o () m b
con (S.Yield o
x StepT IO o
s) = Pipe i i o () m b -> IO (Pipe i i o () m b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pipe i i o () m b -> o -> Pipe i i o () m b
forall l i o u (m :: * -> *) r.
Pipe l i o u m r -> o -> Pipe l i o u m r
HaveOutput (m (Pipe i i o () m b) -> Pipe i i o () m b
forall l i o u (m :: * -> *) r.
m (Pipe l i o u m r) -> Pipe l i o u m r
PipeM (IO (Pipe i i o () m b) -> m (Pipe i i o () m b)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Pipe i i o () m b) -> m (Pipe i i o () m b))
-> IO (Pipe i i o () m b) -> m (Pipe i i o () m b)
forall a b. (a -> b) -> a -> b
$ (() -> Pipe i i o () m b) -> StepT IO o -> IO (Pipe i i o () m b)
forall b.
MonadIO m =>
(() -> Pipe i i o () m b) -> StepT IO o -> IO (Pipe i i o () m b)
loop () -> Pipe i i o () m b
con StepT IO o
s)) o
x)

    {-# SPECIALIZE INLINE fromSourceIO :: SourceIO o -> IO (ConduitT i o IO ()) #-}