mirror of
https://github.com/ilyakooo0/roboservant.git
synced 2024-09-11 08:05:47 +03:00
some cleanup + a compilation speed fix from sam gelineau
This commit is contained in:
parent
6ab4cd5960
commit
a96a0ffa0e
@ -52,17 +52,7 @@ handler = pure . \case
|
|||||||
Input1 foo -> Output1 foo
|
Input1 foo -> Output1 foo
|
||||||
Input2 bar -> Output2 bar
|
Input2 bar -> Output2 bar
|
||||||
|
|
||||||
main =
|
main = fuzz @Api server defaultConfig (pure ())
|
||||||
-- 28s at 80 reps
|
|
||||||
-- fuzz @Api server defaultConfig (pure ())
|
|
||||||
pure ()
|
|
||||||
|
|
||||||
-- 18.5s at 80 reps
|
|
||||||
-- reifiedApi = toReifiedApi flattened endpoints
|
|
||||||
|
|
||||||
flattened = flattenServer @Api server
|
|
||||||
|
|
||||||
endpoints = Proxy @(Endpoints Api)
|
|
||||||
|
|
||||||
defaultConfig :: Config
|
defaultConfig :: Config
|
||||||
defaultConfig = Config {
|
defaultConfig = Config {
|
||||||
|
@ -6,6 +6,7 @@
|
|||||||
{-# LANGUAGE TypeApplications #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
-- | terrible name, this really just pulls stuff out where we can fiddle with it.
|
||||||
|
|
||||||
module Roboservant.Types.FlattenServer where
|
module Roboservant.Types.FlattenServer where
|
||||||
|
|
||||||
@ -18,10 +19,10 @@ data Bundled endpoints where
|
|||||||
class FlattenServer api where
|
class FlattenServer api where
|
||||||
flattenServer :: Server api -> Bundled (Endpoints api)
|
flattenServer :: Server api -> Bundled (Endpoints api)
|
||||||
|
|
||||||
|
|
||||||
instance
|
instance
|
||||||
( Endpoints (endpoint :<|> api) ~ (endpoint ': Endpoints api)
|
( FlattenServer api
|
||||||
-- , Server (endpoint :<|> api) ~ (Server endpoint :<|> Server api)
|
, Endpoints endpoint ~ '[endpoint]
|
||||||
, FlattenServer api
|
|
||||||
) =>
|
) =>
|
||||||
FlattenServer (endpoint :<|> api)
|
FlattenServer (endpoint :<|> api)
|
||||||
where
|
where
|
||||||
|
@ -55,11 +55,11 @@ type ReifiedApi = [(ApiOffset, ReifiedEndpoint)]
|
|||||||
tagType :: Typeable a => f a -> TypedF f a
|
tagType :: Typeable a => f a -> TypedF f a
|
||||||
tagType = (R.typeRep :*:)
|
tagType = (R.typeRep :*:)
|
||||||
|
|
||||||
class ToReifiedApi (endpoints :: [*]) where
|
class ToReifiedApi (endpoints ) where
|
||||||
|
|
||||||
toReifiedApi :: Bundled endpoints -> Proxy endpoints -> ReifiedApi
|
toReifiedApi :: Bundled endpoints -> Proxy endpoints -> ReifiedApi
|
||||||
|
|
||||||
class ( V.Curried (EndpointArgs endpoint) (Handler (EndpointRes endpoint)) ~ Server endpoint
|
class ( V.RecordToList (EndpointArgs endpoint)
|
||||||
, V.RecordToList (EndpointArgs endpoint)
|
|
||||||
, V.RMap (EndpointArgs endpoint)
|
, V.RMap (EndpointArgs endpoint)
|
||||||
) => ToReifiedEndpoint (endpoint :: *) where
|
) => ToReifiedEndpoint (endpoint :: *) where
|
||||||
type EndpointArgs endpoint :: [Type]
|
type EndpointArgs endpoint :: [Type]
|
||||||
@ -72,10 +72,11 @@ instance ToReifiedApi '[] where
|
|||||||
|
|
||||||
instance
|
instance
|
||||||
( Typeable (EndpointRes endpoint)
|
( Typeable (EndpointRes endpoint)
|
||||||
|
|
||||||
, NormalizeFunction (ServerT endpoint Handler)
|
, NormalizeFunction (ServerT endpoint Handler)
|
||||||
, Normal (ServerT endpoint Handler) ~ V.Curried (EndpointArgs endpoint) (IO (Either ServerError (NonEmpty (Dynamic,Int))))
|
, Normal (ServerT endpoint Handler) ~ V.Curried (EndpointArgs endpoint) (IO (Either ServerError (NonEmpty (Dynamic,Int))))
|
||||||
, ToReifiedEndpoint endpoint
|
, ToReifiedEndpoint endpoint
|
||||||
, ToReifiedApi endpoints, Typeable (ServerT endpoint Handler)
|
, ToReifiedApi endpoints
|
||||||
) =>
|
) =>
|
||||||
ToReifiedApi (endpoint : endpoints)
|
ToReifiedApi (endpoint : endpoints)
|
||||||
where
|
where
|
||||||
|
25
test/Nested.hs
Normal file
25
test/Nested.hs
Normal file
@ -0,0 +1,25 @@
|
|||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
{-# LANGUAGE DerivingStrategies #-}
|
||||||
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
|
||||||
|
module Nested where
|
||||||
|
|
||||||
|
import Servant
|
||||||
|
import Servant.API.Flatten
|
||||||
|
|
||||||
|
|
||||||
|
type Api =
|
||||||
|
("one" :> Post '[JSON] Int
|
||||||
|
:<|> "two" :> Post '[JSON] Int
|
||||||
|
)
|
||||||
|
:<|> (
|
||||||
|
"three" :> Post '[JSON] Int
|
||||||
|
)
|
||||||
|
|
||||||
|
type FlatApi = Flat Api
|
||||||
|
|
||||||
|
server :: Server FlatApi
|
||||||
|
server = pure 1 :<|> pure 2 :<|> pure 3
|
Loading…
Reference in New Issue
Block a user