{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Servant.Machines (
MachineToSourceIO (..),
) where
import Control.Monad.IO.Class
(MonadIO (..))
import Data.Machine
(MachineT (..), Step (..))
import Servant.API.Stream
import qualified Servant.Types.SourceT as S
class MachineToSourceIO m where
machineToSourceIO :: MachineT m k o -> S.SourceT IO o
instance MachineToSourceIO IO where
machineToSourceIO :: forall (k :: * -> *) o. MachineT IO k o -> SourceT IO o
machineToSourceIO MachineT IO k o
ma = 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 :: * -> *} {k :: * -> *} {a}.
Monad m =>
MachineT m k a -> StepT m a
go MachineT IO k o
ma) where
go :: MachineT m k a -> StepT m a
go (MachineT m (Step k a (MachineT m k a))
m) = forall (m :: * -> *) a. m (StepT m a) -> StepT m a
S.Effect forall a b. (a -> b) -> a -> b
$ do
Step k a (MachineT m k a)
step <- m (Step k a (MachineT m k a))
m
case Step k a (MachineT m k a)
step of
Step k a (MachineT m k a)
Stop -> forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) a. StepT m a
S.Stop
Yield a
x MachineT m k a
m' -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *) a. a -> StepT m a -> StepT m a
S.Yield a
x (MachineT m k a -> StepT m a
go MachineT m k a
m'))
Await t -> MachineT m k a
_ k t
_ MachineT m k a
m' -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *) a. StepT m a -> StepT m a
S.Skip (MachineT m k a -> StepT m a
go MachineT m k a
m'))
instance MachineToSourceIO m => ToSourceIO o (MachineT m k o) where
toSourceIO :: MachineT m k o -> SourceIO o
toSourceIO = forall (m :: * -> *) (k :: * -> *) o.
MachineToSourceIO m =>
MachineT m k o -> SourceT IO o
machineToSourceIO
instance MonadIO m => FromSourceIO o (MachineT m k o) where
fromSourceIO :: SourceIO o -> IO (MachineT m k o)
fromSourceIO SourceIO o
src = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (k :: * -> *) o.
m (Step k o (MachineT m k o)) -> MachineT m k o
MachineT 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 StepT IO o -> IO (Step k o (MachineT m k o))
go
where
go :: S.StepT IO o -> IO (Step k o (MachineT m k o))
go :: StepT IO o -> IO (Step k o (MachineT m k o))
go StepT IO o
S.Stop = forall (m :: * -> *) a. Monad m => a -> m a
return forall (k :: * -> *) o r. Step k o r
Stop
go (S.Error String
err) = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
go (S.Skip StepT IO o
s) = StepT IO o -> IO (Step k o (MachineT m k o))
go StepT IO o
s
go (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
>>= StepT IO o -> IO (Step k o (MachineT m k o))
go
go (S.Yield o
x StepT IO o
s) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall (k :: * -> *) o r. o -> r -> Step k o r
Yield o
x (forall (m :: * -> *) (k :: * -> *) o.
m (Step k o (MachineT m k o)) -> MachineT m k o
MachineT (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (StepT IO o -> IO (Step k o (MachineT m k o))
go StepT IO o
s))))
{-# SPECIALIZE INLINE fromSourceIO :: SourceIO o -> IO (MachineT IO k o) #-}