servant/servant-machines/src/Servant/Machines.hs

47 lines
1.7 KiB
Haskell
Raw Normal View History

{-# 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 ma = S.SourceT ($ go ma) where
go (MachineT m) = S.Effect $ do
step <- m
case step of
Stop -> return S.Stop
Yield x m' -> return (S.Yield x (go m'))
Await _ _ m' -> return (S.Skip (go m'))
instance MachineToSourceIO m => ToSourceIO o (MachineT m k o) where
toSourceIO = machineToSourceIO
instance MonadIO m => FromSourceIO o (MachineT m k o) where
fromSourceIO src = MachineT $ liftIO $ S.unSourceT src go
where
go :: S.StepT IO o -> IO (Step k o (MachineT m k o))
go S.Stop = return Stop
go (S.Error err) = fail err
go (S.Skip s) = go s
go (S.Effect ms) = ms >>= go
go (S.Yield x s) = return (Yield x (MachineT (liftIO (go s))))
{-# SPECIALIZE INLINE fromSourceIO :: SourceIO o -> MachineT IO k o #-}