@@ -1,122 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE FunctionalDependencies #-}
4−{-# LANGUAGE MultiParamTypeClasses #-}
5−{-# LANGUAGE RankNTypes #-}
6−{-# LANGUAGE ScopedTypeVariables #-}
7−{-# LANGUAGE TypeFamilies #-}
8−{-# LANGUAGE TypeOperators #-}
9−{-# LANGUAGE UndecidableInstances #-}
10−module Servant.Utils.Enter {-# DEPRECATED "Use hoistServer or hoistServerWithContext from servant-server" #-} (
11− module Servant.Utils.Enter,
12− -- * natural-transformation re-exports
13− (:~>)(..),
14− ) where
15−
16−import Control.Monad.Identity
17−import Control.Monad.Morph
18−import Control.Monad.Reader
19−import qualified Control.Monad.State.Lazy as LState
20−import qualified Control.Monad.State.Strict as SState
21−import qualified Control.Monad.Writer.Lazy as LWriter
22−import qualified Control.Monad.Writer.Strict as SWriter
23−import Control.Natural
24−import Data.Tagged
25− (Tagged, retag)
26−import Prelude ()
27−import Prelude.Compat
28−import Servant.API
29−
30−-- | Helper type family to state the 'Enter' symmetry.
31−type family Entered m n api where
32− Entered m n (a -> api) = a -> Entered m n api
33− Entered m n (m a) = n a
34− Entered m n (api1 :<|> api2) = Entered m n api1 :<|> Entered m n api2
35− Entered m n (Tagged m a) = Tagged n a
36−
37−class
38− ( Entered m n typ ~ ret
39− , Entered n m ret ~ typ
40− ) => Enter typ m n ret | typ m n -> ret, ret m n -> typ, ret typ m -> n, ret typ n -> m
41− where
42− -- | Map the leafs of an API type.
43− enter :: (m :~> n) -> typ -> ret
44−
45−-- ** Servant combinators
46−
47−instance
48− ( Enter typ1 m1 n1 ret1, Enter typ2 m2 n2 ret2
49− , m1 ~ m2, n1 ~ n2
50− , Entered m1 n1 (typ1 :<|> typ2) ~ (ret1 :<|> ret2)
51− , Entered n1 m1 (ret1 :<|> ret2) ~ (typ1 :<|> typ2)
52− ) => Enter (typ1 :<|> typ2) m1 n1 (ret1 :<|> ret2)
53− where
54− enter e (a :<|> b) = enter e a :<|> enter e b
55−
56−instance
57− ( Enter typ m n ret
58− , Entered m n (a -> typ) ~ (a -> ret)
59− , Entered n m (a -> ret) ~ (a -> typ)
60− ) => Enter (a -> typ) m n (a -> ret)
61− where
62− enter arg f a = enter arg (f a)
63−
64−-- ** Leaf instances
65−
66−instance
67− ( Entered m n (Tagged m a) ~ Tagged n a
68− , Entered n m (Tagged n a) ~ Tagged m a
69− ) => Enter (Tagged m a) m n (Tagged n a)
70− where
71− enter _ = retag
72−
73−instance
74− ( Entered m n (m a) ~ n a
75− , Entered n m (n a) ~ m a
76− ) => Enter (m a) m n (n a)
77− where
78− enter (NT f) = f
79−
80−-- | Like `lift`.
81−liftNat :: (Control.Monad.Morph.MonadTrans t, Monad m) => m :~> t m
82−liftNat = NT Control.Monad.Morph.lift
83−
84−runReaderTNat :: r -> (ReaderT r m :~> m)
85−runReaderTNat a = NT (`runReaderT` a)
86−
87−evalStateTLNat :: Monad m => s -> (LState.StateT s m :~> m)
88−evalStateTLNat a = NT (`LState.evalStateT` a)
89−
90−evalStateTSNat :: Monad m => s -> (SState.StateT s m :~> m)
91−evalStateTSNat a = NT (`SState.evalStateT` a)
92−
93−-- | Log the contents of `SWriter.WriterT` with the function provided as the
94−-- first argument, and return the value of the @WriterT@ computation
95−logWriterTSNat :: MonadIO m => (w -> IO ()) -> (SWriter.WriterT w m :~> m)
96−logWriterTSNat logger = NT $ \x -> do
97− (a, w) <- SWriter.runWriterT x
98− liftIO $ logger w
99− return a
100−
101−-- | Like `logWriterTSNat`, but for lazy @WriterT@.
102−logWriterTLNat :: MonadIO m => (w -> IO ()) -> (LWriter.WriterT w m :~> m)
103−logWriterTLNat logger = NT $ \x -> do
104− (a, w) <- LWriter.runWriterT x
105− liftIO $ logger w
106− return a
107−
108−-- | Like @mmorph@'s `hoist`.
109−hoistNat :: (MFunctor t, Monad m) => (m :~> n) -> (t m :~> t n)
110−hoistNat (NT n) = NT $ hoist n
111−
112−-- | Like @mmorph@'s `embed`.
113−embedNat :: (MMonad t, Monad n) => (m :~> t n) -> (t m :~> t n)
114−embedNat (NT n) = NT $ embed n
115−
116−-- | Like @mmorph@'s `squash`.
117−squashNat :: (Monad m, MMonad t) => t (t m) :~> t m
118−squashNat = NT squash
119−
120−-- | Like @mmorph@'s `generalize`.
121−generalizeNat :: Applicative m => Identity :~> m
122−generalizeNat = NT (pure . runIdentity)