123 lines
3.9 KiB
Haskell
123 lines
3.9 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE FunctionalDependencies #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
module Servant.Utils.Enter {-# DEPRECATED "Use hoistServer or hoistServerWithContext from servant-server" #-} (
|
|
module Servant.Utils.Enter,
|
|
-- * natural-transformation re-exports
|
|
(:~>)(..),
|
|
) where
|
|
|
|
import Control.Monad.Identity
|
|
import Control.Monad.Morph
|
|
import Control.Monad.Reader
|
|
import qualified Control.Monad.State.Lazy as LState
|
|
import qualified Control.Monad.State.Strict as SState
|
|
import qualified Control.Monad.Writer.Lazy as LWriter
|
|
import qualified Control.Monad.Writer.Strict as SWriter
|
|
import Control.Natural
|
|
import Data.Tagged
|
|
(Tagged, retag)
|
|
import Prelude ()
|
|
import Prelude.Compat
|
|
import Servant.API
|
|
|
|
-- | Helper type family to state the 'Enter' symmetry.
|
|
type family Entered m n api where
|
|
Entered m n (a -> api) = a -> Entered m n api
|
|
Entered m n (m a) = n a
|
|
Entered m n (api1 :<|> api2) = Entered m n api1 :<|> Entered m n api2
|
|
Entered m n (Tagged m a) = Tagged n a
|
|
|
|
class
|
|
( Entered m n typ ~ ret
|
|
, Entered n m ret ~ typ
|
|
) => Enter typ m n ret | typ m n -> ret, ret m n -> typ, ret typ m -> n, ret typ n -> m
|
|
where
|
|
-- | Map the leafs of an API type.
|
|
enter :: (m :~> n) -> typ -> ret
|
|
|
|
-- ** Servant combinators
|
|
|
|
instance
|
|
( Enter typ1 m1 n1 ret1, Enter typ2 m2 n2 ret2
|
|
, m1 ~ m2, n1 ~ n2
|
|
, Entered m1 n1 (typ1 :<|> typ2) ~ (ret1 :<|> ret2)
|
|
, Entered n1 m1 (ret1 :<|> ret2) ~ (typ1 :<|> typ2)
|
|
) => Enter (typ1 :<|> typ2) m1 n1 (ret1 :<|> ret2)
|
|
where
|
|
enter e (a :<|> b) = enter e a :<|> enter e b
|
|
|
|
instance
|
|
( Enter typ m n ret
|
|
, Entered m n (a -> typ) ~ (a -> ret)
|
|
, Entered n m (a -> ret) ~ (a -> typ)
|
|
) => Enter (a -> typ) m n (a -> ret)
|
|
where
|
|
enter arg f a = enter arg (f a)
|
|
|
|
-- ** Leaf instances
|
|
|
|
instance
|
|
( Entered m n (Tagged m a) ~ Tagged n a
|
|
, Entered n m (Tagged n a) ~ Tagged m a
|
|
) => Enter (Tagged m a) m n (Tagged n a)
|
|
where
|
|
enter _ = retag
|
|
|
|
instance
|
|
( Entered m n (m a) ~ n a
|
|
, Entered n m (n a) ~ m a
|
|
) => Enter (m a) m n (n a)
|
|
where
|
|
enter (NT f) = f
|
|
|
|
-- | Like `lift`.
|
|
liftNat :: (Control.Monad.Morph.MonadTrans t, Monad m) => m :~> t m
|
|
liftNat = NT Control.Monad.Morph.lift
|
|
|
|
runReaderTNat :: r -> (ReaderT r m :~> m)
|
|
runReaderTNat a = NT (`runReaderT` a)
|
|
|
|
evalStateTLNat :: Monad m => s -> (LState.StateT s m :~> m)
|
|
evalStateTLNat a = NT (`LState.evalStateT` a)
|
|
|
|
evalStateTSNat :: Monad m => s -> (SState.StateT s m :~> m)
|
|
evalStateTSNat a = NT (`SState.evalStateT` a)
|
|
|
|
-- | Log the contents of `SWriter.WriterT` with the function provided as the
|
|
-- first argument, and return the value of the @WriterT@ computation
|
|
logWriterTSNat :: MonadIO m => (w -> IO ()) -> (SWriter.WriterT w m :~> m)
|
|
logWriterTSNat logger = NT $ \x -> do
|
|
(a, w) <- SWriter.runWriterT x
|
|
liftIO $ logger w
|
|
return a
|
|
|
|
-- | Like `logWriterTSNat`, but for lazy @WriterT@.
|
|
logWriterTLNat :: MonadIO m => (w -> IO ()) -> (LWriter.WriterT w m :~> m)
|
|
logWriterTLNat logger = NT $ \x -> do
|
|
(a, w) <- LWriter.runWriterT x
|
|
liftIO $ logger w
|
|
return a
|
|
|
|
-- | Like @mmorph@'s `hoist`.
|
|
hoistNat :: (MFunctor t, Monad m) => (m :~> n) -> (t m :~> t n)
|
|
hoistNat (NT n) = NT $ hoist n
|
|
|
|
-- | Like @mmorph@'s `embed`.
|
|
embedNat :: (MMonad t, Monad n) => (m :~> t n) -> (t m :~> t n)
|
|
embedNat (NT n) = NT $ embed n
|
|
|
|
-- | Like @mmorph@'s `squash`.
|
|
squashNat :: (Monad m, MMonad t) => t (t m) :~> t m
|
|
squashNat = NT squash
|
|
|
|
-- | Like @mmorph@'s `generalize`.
|
|
generalizeNat :: Applicative m => Identity :~> m
|
|
generalizeNat = NT (pure . runIdentity)
|