@@ -0,0 +1,96 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DeriveDataTypeable #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE FunctionalDependencies #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE OverlappingInstances #-}
7+{-# LANGUAGE RankNTypes #-}
8+{-# LANGUAGE ScopedTypeVariables #-}
9+{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE TypeOperators #-}
11+{-# LANGUAGE UndecidableInstances #-}
12+module Servant.Server.Internal.Enter where
13+
14+import Control.Applicative
15+import qualified Control.Category as C
16+#if MIN_VERSION_mtl(2,2,1)
17+import Control.Monad.Except
18+#endif
19+import Control.Monad.Identity
20+import Control.Monad.Morph
21+import Control.Monad.Reader
22+import qualified Control.Monad.State.Lazy as LState
23+import qualified Control.Monad.State.Strict as SState
24+import Control.Monad.Trans.Either
25+import qualified Control.Monad.Writer.Lazy as LWriter
26+import qualified Control.Monad.Writer.Strict as SWriter
27+import Data.Typeable
28+import Servant.API
29+
30+class Enter typ arg ret | typ arg -> ret, typ ret -> arg where
31+ enter :: arg -> typ -> ret
32+
33+-- ** Servant combinators
34+instance ( Enter typ1 arg1 ret1, Enter typ2 arg2 ret2
35+ , arg1 ~ arg2
36+ ) => Enter (typ1 :<|> typ2) arg1 (ret1 :<|> ret2) where
37+ enter e (a :<|> b) = enter e a :<|> enter e b
38+
39+instance (Enter b arg ret) => Enter (a -> b) arg (a -> ret) where
40+ enter arg f a = enter arg (f a)
41+
42+-- ** Useful instances
43+
44+newtype m :~> n = Nat { unNat :: forall a. m a -> n a} deriving Typeable
45+
46+instance C.Category (:~>) where
47+ id = Nat id
48+ Nat f . Nat g = Nat (f . g)
49+
50+instance Enter (m a) (m :~> n) (n a) where
51+ enter (Nat f) = f
52+
53+liftNat :: (MonadTrans t, Monad m) => m :~> t m
54+liftNat = Nat lift
55+
56+runReaderTNat :: r -> (ReaderT r m :~> m)
57+runReaderTNat a = Nat (`runReaderT` a)
58+
59+evalStateTLNat :: Monad m => s -> (LState.StateT s m :~> m)
60+evalStateTLNat a = Nat (`LState.evalStateT` a)
61+
62+evalStateTSNat :: Monad m => s -> (SState.StateT s m :~> m)
63+evalStateTSNat a = Nat (`SState.evalStateT` a)
64+
65+-- | Log the contents of `SWriter.WriterT` with the function provided as the
66+-- first argument, and return the value of the @WriterT@ computation
67+logWriterTSNat :: MonadIO m => (w -> IO ()) -> (SWriter.WriterT w m :~> m)
68+logWriterTSNat logger = Nat $ \x -> do
69+ (a, w) <- SWriter.runWriterT x
70+ liftIO $ logger w
71+ return a
72+
73+-- | Like `logWriterTSNat`, but for strict @WriterT@.
74+logWriterTLNat :: MonadIO m => (w -> IO ()) -> (LWriter.WriterT w m :~> m)
75+logWriterTLNat logger = Nat $ \x -> do
76+ (a, w) <- LWriter.runWriterT x
77+ liftIO $ logger w
78+ return a
79+
80+#if MIN_VERSION_mtl(2,2,1)
81+fromExceptT :: ExceptT e m :~> EitherT e m
82+fromExceptT = Nat $ \x -> EitherT $ runExceptT x
83+#endif
84+
85+-- | Like @mmorph@'s `hoist`.
86+hoistNat :: (MFunctor t, Monad m) => (m :~> n) -> (t m :~> t n)
87+hoistNat (Nat n) = Nat $ hoist n
88+
89+embedNat :: (MMonad t, Monad n) => (m :~> t n) -> (t m :~> t n)
90+embedNat (Nat n) = Nat $ embed n
91+
92+squashNat :: (Monad m, MMonad t) => t (t m) :~> t m
93+squashNat = Nat squash
94+
95+generalizeNat :: Applicative m => Identity :~> m
96+generalizeNat = Nat (pure . runIdentity)