{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE UndecidableInstances  #-}
{-# OPTIONS_GHC -Wno-orphans #-}
-- | This module exports 'ToSourceIO' and 'FromSourceIO' for 'MachineT' instances.
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

-- | Helper class to implement @'ToSourceIO' 'MachineT'@ instance
-- for various monads.
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 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
$ MachineT IO k o -> StepT IO o
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) = 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
$ 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         -> StepT m a -> m (StepT m a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return StepT m a
forall (m :: * -> *) a. StepT m a
S.Stop
                Yield a
x MachineT m k a
m'   -> StepT m a -> m (StepT m a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> StepT m a -> StepT m a
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' -> StepT m a -> m (StepT m a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (StepT m a -> StepT m a
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 = MachineT m k o -> SourceIO o
forall (m :: * -> *) (k :: * -> *) o.
MachineToSourceIO m =>
MachineT m k o -> SourceT IO o
forall (k :: * -> *) o. 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 = MachineT m k o -> IO (MachineT m k o)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (MachineT m k o -> IO (MachineT m k o))
-> MachineT m k o -> IO (MachineT m k o)
forall a b. (a -> b) -> a -> b
$ m (Step k o (MachineT m k o)) -> MachineT m k o
forall (m :: * -> *) (k :: * -> *) o.
m (Step k o (MachineT m k o)) -> MachineT m k o
MachineT (m (Step k o (MachineT m k o)) -> MachineT m k o)
-> m (Step k o (MachineT m k o)) -> MachineT m k o
forall a b. (a -> b) -> a -> b
$ IO (Step k o (MachineT m k o)) -> m (Step k o (MachineT m k o))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Step k o (MachineT m k o)) -> m (Step k o (MachineT m k o)))
-> IO (Step k o (MachineT m k o)) -> m (Step k o (MachineT m k o))
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 (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        = Step k o (MachineT m k o) -> IO (Step k o (MachineT m k o))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Step k o (MachineT m k o)
forall (k :: * -> *) o r. Step k o r
Stop
        go (S.Error String
err) = String -> IO (Step k o (MachineT m k o))
forall a. String -> IO a
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 IO (StepT IO o)
-> (StepT IO o -> IO (Step k o (MachineT m k o)))
-> IO (Step k o (MachineT m k o))
forall a b. IO a -> (a -> IO b) -> IO b
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) = Step k o (MachineT m k o) -> IO (Step k o (MachineT m k o))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (o -> MachineT m k o -> Step k o (MachineT m k o)
forall (k :: * -> *) o r. o -> r -> Step k o r
Yield o
x (m (Step k o (MachineT m k o)) -> MachineT m k o
forall (m :: * -> *) (k :: * -> *) o.
m (Step k o (MachineT m k o)) -> MachineT m k o
MachineT (IO (Step k o (MachineT m k o)) -> m (Step k o (MachineT m k o))
forall a. IO a -> m a
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) #-}