Redo Enter
This commit is contained in:
parent
832b359380
commit
e2665391f9
3 changed files with 32 additions and 10 deletions
|
@ -207,7 +207,7 @@ layoutWithContext p context =
|
||||||
-- monad. Or have your types ensure that your handlers don't do any IO. Enter
|
-- monad. Or have your types ensure that your handlers don't do any IO. Enter
|
||||||
-- `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
|
-- newtype, to convert any number of endpoints from one type constructor to
|
||||||
-- another. For example
|
-- another. For example
|
||||||
--
|
--
|
||||||
|
@ -215,7 +215,8 @@ layoutWithContext p context =
|
||||||
-- >>> import qualified Control.Category as C
|
-- >>> import qualified Control.Category as C
|
||||||
-- >>> type ReaderAPI = "ep1" :> Get '[JSON] Int :<|> "ep2" :> Get '[JSON] String
|
-- >>> type ReaderAPI = "ep1" :> Get '[JSON] Int :<|> "ep2" :> Get '[JSON] String
|
||||||
-- >>> let readerServer = return 1797 :<|> ask :: ServerT ReaderAPI (Reader 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
|
-- $setup
|
||||||
|
|
|
@ -5,6 +5,7 @@ module Servant.ArbitraryMonadServerSpec where
|
||||||
|
|
||||||
import qualified Control.Category as C
|
import qualified Control.Category as C
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
|
import Data.Functor.Identity
|
||||||
import Data.Proxy
|
import Data.Proxy
|
||||||
import Servant.API
|
import Servant.API
|
||||||
import Servant.Server
|
import Servant.Server
|
||||||
|
@ -40,7 +41,7 @@ readerServer :: Server ReaderAPI
|
||||||
readerServer = enter fReader readerServer'
|
readerServer = enter fReader readerServer'
|
||||||
|
|
||||||
combinedReaderServer' :: ServerT CombinedAPI (Reader String)
|
combinedReaderServer' :: ServerT CombinedAPI (Reader String)
|
||||||
combinedReaderServer' = readerServer' :<|> enter generalizeNat (return True)
|
combinedReaderServer' = readerServer' :<|> enter (generalizeNat :: Identity :~> Reader String) (return True)
|
||||||
|
|
||||||
combinedReaderServer :: Server CombinedAPI
|
combinedReaderServer :: Server CombinedAPI
|
||||||
combinedReaderServer = enter fReader combinedReaderServer'
|
combinedReaderServer = enter fReader combinedReaderServer'
|
||||||
|
|
|
@ -27,21 +27,41 @@ import Prelude.Compat
|
||||||
|
|
||||||
import Servant.API
|
import Servant.API
|
||||||
|
|
||||||
class Enter typ arg ret | typ arg -> ret, typ ret -> arg where
|
type family Entered m n api where
|
||||||
enter :: arg -> typ -> ret
|
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
|
-- ** Servant combinators
|
||||||
instance ( Enter typ1 arg1 ret1, Enter typ2 arg2 ret2
|
|
||||||
, arg1 ~ arg2
|
instance
|
||||||
) => Enter (typ1 :<|> typ2) arg1 (ret1 :<|> ret2) where
|
( 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
|
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)
|
enter arg f a = enter arg (f a)
|
||||||
|
|
||||||
-- ** Useful instances
|
-- ** Useful instances
|
||||||
|
|
||||||
instance Enter (m a) (m :~> n) (n a) where
|
instance Enter (m a) m n (n a) where
|
||||||
enter (NT f) = f
|
enter (NT f) = f
|
||||||
|
|
||||||
-- | Like `lift`.
|
-- | Like `lift`.
|
||||||
|
|
Loading…
Reference in a new issue