diff --git a/servant/servant.cabal b/servant/servant.cabal index 02d366ea..060ca9c1 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -58,6 +58,7 @@ library , http-api-data >= 0.3 && < 0.4 , http-media >= 0.4 && < 0.7 , http-types >= 0.8 && < 0.10 + , natural-transformation >= 0.4 && < 0.5 , mtl >= 2.0 && < 2.3 , mmorph >= 1 && < 1.1 , text >= 1 && < 1.3 diff --git a/servant/src/Servant/Utils/Enter.hs b/servant/src/Servant/Utils/Enter.hs index 12f7a530..a93f2e4e 100644 --- a/servant/src/Servant/Utils/Enter.hs +++ b/servant/src/Servant/Utils/Enter.hs @@ -8,9 +8,13 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -module Servant.Utils.Enter where +module Servant.Utils.Enter ( + module Servant.Utils.Enter, + -- * natural-transformation re-exports + (:~>)(..), + ) where -import qualified Control.Category as C +import Control.Natural import Control.Monad.Identity import Control.Monad.Morph import Control.Monad.Reader @@ -18,7 +22,6 @@ 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 Data.Typeable import Prelude () import Prelude.Compat @@ -38,57 +41,49 @@ instance (Enter b arg ret) => Enter (a -> b) arg (a -> ret) where -- ** Useful instances --- | A natural transformation from @m@ to @n@. Used to `enter` particular --- datatypes. -newtype m :~> n = Nat { unNat :: forall a. m a -> n a} deriving Typeable - -instance C.Category (:~>) where - id = Nat id - Nat f . Nat g = Nat (f . g) - instance Enter (m a) (m :~> n) (n a) where - enter (Nat f) = f + enter (NT f) = f -- | Like `lift`. liftNat :: (Control.Monad.Morph.MonadTrans t, Monad m) => m :~> t m -liftNat = Nat Control.Monad.Morph.lift +liftNat = NT Control.Monad.Morph.lift runReaderTNat :: r -> (ReaderT r m :~> m) -runReaderTNat a = Nat (`runReaderT` a) +runReaderTNat a = NT (`runReaderT` a) evalStateTLNat :: Monad m => s -> (LState.StateT s m :~> m) -evalStateTLNat a = Nat (`LState.evalStateT` a) +evalStateTLNat a = NT (`LState.evalStateT` a) evalStateTSNat :: Monad m => s -> (SState.StateT s m :~> m) -evalStateTSNat a = Nat (`SState.evalStateT` a) +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 = Nat $ \x -> do +logWriterTSNat logger = NT $ \x -> do (a, w) <- SWriter.runWriterT x liftIO $ logger w return a -- | Like `logWriterTSNat`, but for strict @WriterT@. logWriterTLNat :: MonadIO m => (w -> IO ()) -> (LWriter.WriterT w m :~> m) -logWriterTLNat logger = Nat $ \x -> do +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 (Nat n) = Nat $ hoist n +hoistNat (NT n) = NT $ hoist n -- | Like @mmorph@'s `embed`. embedNat :: (MMonad t, Monad n) => (m :~> t n) -> (t m :~> t n) -embedNat (Nat n) = Nat $ embed n +embedNat (NT n) = NT $ embed n -- | Like @mmorph@'s `squash`. squashNat :: (Monad m, MMonad t) => t (t m) :~> t m -squashNat = Nat squash +squashNat = NT squash -- | Like @mmorph@'s `generalize`. generalizeNat :: Applicative m => Identity :~> m -generalizeNat = Nat (pure . runIdentity) +generalizeNat = NT (pure . runIdentity) diff --git a/stack-ghc-7.8.4.yaml b/stack-ghc-7.8.4.yaml index 013c50dc..eb20cfbe 100644 --- a/stack-ghc-7.8.4.yaml +++ b/stack-ghc-7.8.4.yaml @@ -15,6 +15,7 @@ extra-deps: - hspec-discover-2.2.3 - hspec-expectations-0.7.2 - http-api-data-0.3 +- natural-transformation-0.4 - primitive-0.6.1.0 - should-not-typecheck-2.1.0 - time-locale-compat-0.1.1.1 diff --git a/stack-ghc-8.0.1.yaml b/stack-ghc-8.0.1.yaml index 9b26ed30..21f2dab0 100644 --- a/stack-ghc-8.0.1.yaml +++ b/stack-ghc-8.0.1.yaml @@ -8,4 +8,5 @@ packages: extra-deps: - http-api-data-0.3 - uri-bytestring-0.2.2.0 +- natural-transformation-0.4 flags: {} diff --git a/stack.yaml b/stack.yaml index 38e1eaa3..97ab4291 100644 --- a/stack.yaml +++ b/stack.yaml @@ -9,4 +9,5 @@ packages: extra-deps: - http-api-data-0.3 - servant-js-0.9 # needed for tutorial +- natural-transformation-0.4 resolver: lts-6.0