From e2665391f9cb78239a8ca1651e46cadc5a4a45d6 Mon Sep 17 00:00:00 2001
From: Oleg Grenrus <oleg.grenrus@iki.fi>
Date: Fri, 28 Apr 2017 14:31:57 +0300
Subject: [PATCH 1/2] Redo Enter

---
 servant-server/src/Servant/Server.hs          |  5 +--
 .../test/Servant/ArbitraryMonadServerSpec.hs  |  3 +-
 servant/src/Servant/Utils/Enter.hs            | 34 +++++++++++++++----
 3 files changed, 32 insertions(+), 10 deletions(-)

diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs
index 0e786ea6..71c67e1b 100644
--- a/servant-server/src/Servant/Server.hs
+++ b/servant-server/src/Servant/Server.hs
@@ -207,7 +207,7 @@ layoutWithContext p context =
 -- monad. Or have your types ensure that your handlers don't do any IO. Enter
 -- `enter`.
 --
--- With `enter`, you can provide a function, wrapped in the `(:~>)` / `Nat`
+-- With `enter`, you can provide a function, wrapped in the `(:~>)` / `NT`
 -- newtype, to convert any number of endpoints from one type constructor to
 -- another. For example
 --
@@ -215,7 +215,8 @@ layoutWithContext p context =
 -- >>> import qualified Control.Category as C
 -- >>> type ReaderAPI = "ep1" :> Get '[JSON] Int :<|> "ep2" :> Get '[JSON] String
 -- >>> let readerServer = return 1797 :<|> ask :: ServerT ReaderAPI (Reader String)
--- >>> let mainServer = enter (generalizeNat C.. (runReaderTNat "hi")) readerServer :: Server ReaderAPI
+-- >>> let nt = generalizeNat C.. (runReaderTNat "hi") :: Reader String :~> Handler
+-- >>> let mainServer = enter nt readerServer :: Server ReaderAPI
 --
 
 -- $setup
diff --git a/servant-server/test/Servant/ArbitraryMonadServerSpec.hs b/servant-server/test/Servant/ArbitraryMonadServerSpec.hs
index 444d86ec..09ec30b8 100644
--- a/servant-server/test/Servant/ArbitraryMonadServerSpec.hs
+++ b/servant-server/test/Servant/ArbitraryMonadServerSpec.hs
@@ -5,6 +5,7 @@ module Servant.ArbitraryMonadServerSpec where
 
 import qualified Control.Category           as C
 import           Control.Monad.Reader
+import Data.Functor.Identity
 import           Data.Proxy
 import           Servant.API
 import           Servant.Server
@@ -40,7 +41,7 @@ readerServer :: Server ReaderAPI
 readerServer = enter fReader readerServer'
 
 combinedReaderServer' :: ServerT CombinedAPI (Reader String)
-combinedReaderServer' = readerServer' :<|> enter generalizeNat (return True)
+combinedReaderServer' = readerServer' :<|> enter (generalizeNat :: Identity :~> Reader String) (return True)
 
 combinedReaderServer :: Server CombinedAPI
 combinedReaderServer = enter fReader combinedReaderServer'
diff --git a/servant/src/Servant/Utils/Enter.hs b/servant/src/Servant/Utils/Enter.hs
index 09418761..93c09a5f 100644
--- a/servant/src/Servant/Utils/Enter.hs
+++ b/servant/src/Servant/Utils/Enter.hs
@@ -27,21 +27,41 @@ import           Prelude.Compat
 
 import           Servant.API
 
-class Enter typ arg ret | typ arg -> ret, typ ret -> arg where
-    enter :: arg -> typ -> ret
+type family Entered m n api where
+    Entered m n (m a)            = n a
+    Entered m n (a -> api)       = a -> Entered m n api
+    Entered m n (api1 :<|> api2) = Entered m n api1 :<|> Entered m n api2
+
+class ( Entered m n typ ~ ret
+      , Entered n m ret ~ typ
+      )
+    => Enter typ m n ret
+  where
+    enter :: m :~> n -> typ -> ret
 
 -- **  Servant combinators
-instance ( Enter typ1 arg1 ret1, Enter typ2 arg2 ret2
-         , arg1 ~ arg2
-         ) => Enter (typ1 :<|> typ2) arg1 (ret1 :<|> ret2) where
+
+instance
+    ( Entered m1 n1 (typ1 :<|> typ2) ~ (ret1 :<|> ret2)
+    , Entered n1 m1 (ret1 :<|> ret2) ~ (typ1 :<|> typ2)
+    , Enter typ1 m1 n1 ret1, Enter typ2 m2 n2 ret2
+    , m1 ~ m2, n1 ~ n2
+    ) => Enter (typ1 :<|> typ2) m1 n1 (ret1 :<|> ret2)
+  where
     enter e (a :<|> b) = enter e a :<|> enter e b
 
-instance (Enter b arg ret) => Enter (a -> b) arg (a -> ret) where
+instance
+    ( Entered m n (a -> typ) ~ (a -> ret)
+    , Entered n m (a -> ret) ~ (a -> typ)
+    , Enter typ m n ret
+    )
+    => Enter (a -> typ) m n (a -> ret)
+  where
     enter arg f a = enter arg (f a)
 
 -- ** Useful instances
 
-instance Enter (m a) (m :~> n) (n a) where
+instance Enter (m a) m n (n a) where
     enter (NT f) = f
 
 -- | Like `lift`.

From c01dca6d271e07716f49e4585bb0d87b81c5db8c Mon Sep 17 00:00:00 2001
From: Oleg Grenrus <oleg.grenrus@iki.fi>
Date: Fri, 28 Apr 2017 14:55:13 +0300
Subject: [PATCH 2/2] Parens

---
 servant/src/Servant/Utils/Enter.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/servant/src/Servant/Utils/Enter.hs b/servant/src/Servant/Utils/Enter.hs
index 93c09a5f..3cddb8fe 100644
--- a/servant/src/Servant/Utils/Enter.hs
+++ b/servant/src/Servant/Utils/Enter.hs
@@ -37,7 +37,7 @@ class ( Entered m n typ ~ ret
       )
     => Enter typ m n ret
   where
-    enter :: m :~> n -> typ -> ret
+    enter :: (m :~> n) -> typ -> ret
 
 -- **  Servant combinators