Remove Servant.Utils.Enter
This commit is contained in:
Oleg Grenrus
parent
ae05ef5312
commit
7150f2b603
3 changed files with 0 additions and 158 deletions
|
|
@ -63,7 +63,6 @@ library
|
||||||
Servant.API.Verbs
|
Servant.API.Verbs
|
||||||
Servant.API.WithNamedContext
|
Servant.API.WithNamedContext
|
||||||
Servant.Utils.Links
|
Servant.Utils.Links
|
||||||
Servant.Utils.Enter
|
|
||||||
|
|
||||||
-- Bundled with GHC: Lower bound to not force re-installs
|
-- Bundled with GHC: Lower bound to not force re-installs
|
||||||
-- text and mtl are bundled starting with GHC-8.4
|
-- text and mtl are bundled starting with GHC-8.4
|
||||||
|
|
@ -89,7 +88,6 @@ library
|
||||||
, http-api-data >= 0.3.8.1 && < 0.4
|
, http-api-data >= 0.3.8.1 && < 0.4
|
||||||
, http-media >= 0.7.1.2 && < 0.8
|
, http-media >= 0.7.1.2 && < 0.8
|
||||||
, http-types >= 0.12.1 && < 0.13
|
, http-types >= 0.12.1 && < 0.13
|
||||||
, natural-transformation >= 0.4 && < 0.5
|
|
||||||
, mmorph >= 1.1.2 && < 1.2
|
, mmorph >= 1.1.2 && < 1.2
|
||||||
, tagged >= 0.8.5 && < 0.9
|
, tagged >= 0.8.5 && < 0.9
|
||||||
, singleton-bool >= 0.1.4 && < 0.2
|
, singleton-bool >= 0.1.4 && < 0.2
|
||||||
|
|
@ -134,7 +132,6 @@ test-suite spec
|
||||||
Servant.API.ContentTypesSpec
|
Servant.API.ContentTypesSpec
|
||||||
Servant.API.ResponseHeadersSpec
|
Servant.API.ResponseHeadersSpec
|
||||||
Servant.Utils.LinksSpec
|
Servant.Utils.LinksSpec
|
||||||
Servant.Utils.EnterSpec
|
|
||||||
|
|
||||||
-- Dependencies inherited from the library. No need to specify bounds.
|
-- Dependencies inherited from the library. No need to specify bounds.
|
||||||
build-depends:
|
build-depends:
|
||||||
|
|
|
||||||
|
|
@ -1,122 +0,0 @@
|
||||||
{-# 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)
|
|
||||||
|
|
@ -1,33 +0,0 @@
|
||||||
{-# LANGUAGE DataKinds #-}
|
|
||||||
{-# LANGUAGE TypeOperators #-}
|
|
||||||
{-# OPTIONS_GHC -fno-warn-deprecations #-}
|
|
||||||
module Servant.Utils.EnterSpec where
|
|
||||||
|
|
||||||
import Test.Hspec (Spec)
|
|
||||||
|
|
||||||
import Servant.API
|
|
||||||
import Servant.Utils.Enter
|
|
||||||
|
|
||||||
-------------------------------------------------------------------------------
|
|
||||||
-- https://github.com/haskell-servant/servant/issues/734
|
|
||||||
-------------------------------------------------------------------------------
|
|
||||||
|
|
||||||
-- This didn't fail if executed in GHCi; cannot have as a doctest.
|
|
||||||
|
|
||||||
data App a
|
|
||||||
|
|
||||||
f :: App :~> App
|
|
||||||
f = NT id
|
|
||||||
|
|
||||||
server :: App Int :<|> (String -> App Bool)
|
|
||||||
server = undefined
|
|
||||||
|
|
||||||
server' :: App Int :<|> (String -> App Bool)
|
|
||||||
server' = enter f server
|
|
||||||
|
|
||||||
-------------------------------------------------------------------------------
|
|
||||||
-- Spec
|
|
||||||
-------------------------------------------------------------------------------
|
|
||||||
|
|
||||||
spec :: Spec
|
|
||||||
spec = return ()
|
|
||||||
Loading…
Reference in a new issue