servant/servant-pipes/src/Servant/Pipes.hs
2019-09-12 09:44:54 +03:00

75 lines
2.7 KiB
Haskell

{-# 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 'Proxy' and 'SafeT' instances.
module Servant.Pipes (
PipesToSourceIO (..),
) where
import Control.Monad.IO.Class
(MonadIO (..))
import Control.Monad.Trans.Control
(liftBaseWith)
import Pipes
(ListT (..))
import Pipes.Internal
(Proxy (..), X, closed)
import Pipes.Safe
(SafeT, runSafeT)
import Servant.API.Stream
import qualified Servant.Types.SourceT as S
-- | Helper class to implement @'ToSourceIO' 'Proxy'@ instance
-- for various monads.
class PipesToSourceIO m where
pipesToSourceIO :: Proxy X () () b m () -> SourceIO b
instance PipesToSourceIO IO where
pipesToSourceIO ma = S.SourceT ($ go ma) where
go :: Proxy X () () b IO () -> S.StepT IO b
go (Pure ()) = S.Stop
go (M p) = S.Effect (fmap go p)
go (Request v _) = closed v
go (Respond b n) = S.Yield b (go (n ()))
instance m ~ IO => PipesToSourceIO (SafeT m) where
pipesToSourceIO ma =
S.SourceT $ \k ->
runSafeT $ liftBaseWith $ \runSafe ->
k (go runSafe ma)
where
go :: (forall x. SafeT m x -> m x)
-> Proxy X () () b (SafeT m) ()
-> S.StepT IO b
go _ (Pure ()) = S.Stop
go runSafe (M p) = S.Effect $ runSafe $ fmap (go runSafe) p
go _ (Request v _) = closed v
go runSafe (Respond b n) = S.Yield b (go runSafe (n ()))
instance (PipesToSourceIO m, a' ~ X, a ~ (), b' ~ (), r ~ ())
=> ToSourceIO b (Proxy a' a b' b m r)
where
toSourceIO = pipesToSourceIO
instance PipesToSourceIO m => ToSourceIO a (ListT m a) where
toSourceIO = pipesToSourceIO . enumerate
instance (MonadIO m, a' ~ X, a ~ (), b' ~ (), r ~ ())
=> FromSourceIO b (Proxy a' a b' b m r)
where
fromSourceIO src = M $ liftIO $ S.unSourceT src (return . go) where
go :: S.StepT IO b -> Proxy X () () b m ()
go S.Stop = Pure ()
go (S.Error err) = M (liftIO (fail err))
go (S.Skip s) = go s -- drives
go (S.Effect ms) = M (liftIO (fmap go ms))
go (S.Yield x s) = Respond x (const (go s))
{-# SPECIALIZE INLINE fromSourceIO :: SourceIO x -> Proxy X () () x IO () #-}
instance MonadIO m => FromSourceIO a (ListT m a) where
fromSourceIO = Select . fromSourceIO