{-# 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 (m :: * -> *) a.
(forall b. (StepT m a -> m b) -> m b) -> SourceT m a
S.SourceT (forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *} {l} {i} {a}.
Functor m =>
Pipe l i a () m () -> StepT m a
go (forall b. (() -> Pipe i i o () IO b) -> Pipe i i o () IO b
con 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 ()          -> forall (m :: * -> *) a. StepT m a
S.Stop
            HaveOutput Pipe l i a () m ()
p a
o   -> 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 -> 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          -> forall (m :: * -> *) a. m (StepT m a) -> StepT m a
S.Effect forall a b. (a -> b) -> a -> 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    -> 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 (m :: * -> *) a.
(forall b. (StepT m a -> m b) -> m b) -> SourceT m a
S.SourceT forall a b. (a -> b) -> a -> b
$ \StepT IO o -> IO b
k ->
        forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. ResourceT IO a -> IO a
runRes ->
        StepT IO o -> IO b
k (forall i o.
(forall x. ResourceT m x -> m x)
-> Pipe i i o () (ResourceT m) () -> StepT IO o
go forall a. ResourceT IO a -> IO a
runRes (forall b.
(() -> Pipe i i o () (ResourceT m) b)
-> Pipe i i o () (ResourceT m) b
con 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 ())          = 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)   = forall (m :: * -> *) a. a -> StepT m a -> StepT m a
S.Yield o
o (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
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) = forall (m :: * -> *) a. StepT m a -> StepT m a
S.Skip (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
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)          = forall (m :: * -> *) a. m (StepT m a) -> StepT m a
S.Effect forall a b. (a -> b) -> a -> b
$ forall x. ResourceT m x -> m x
runRes forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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
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)    = forall (m :: * -> *) a. StepT m a -> StepT m a
S.Skip (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
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 = 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 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
        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 a b. (a -> b) -> a -> b
$ \r -> Pipe i i o () m b
con ->
        forall l i o u (m :: * -> *) r.
m (Pipe l i o u m r) -> Pipe l i o u m r
PipeM forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
SourceT m a -> forall b. (StepT m a -> m b) -> m b
S.unSourceT SourceIO o
src forall a b. (a -> b) -> a -> b
$ \StepT IO o
step ->
        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
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        = 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) = 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)    = 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> 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) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall l i o u (m :: * -> *) r.
Pipe l i o u m r -> o -> Pipe l i o u m r
HaveOutput (forall l i o u (m :: * -> *) r.
m (Pipe l i o u m r) -> Pipe l i o u m r
PipeM (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> 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 ()) #-}