diff --git a/benchmarks/prelude b/benchmarks/prelude index 04211fd..6a0fe40 100644 --- a/benchmarks/prelude +++ b/benchmarks/prelude @@ -52,17 +52,7 @@ handler = pure . \case Input1 foo -> Output1 foo Input2 bar -> Output2 bar -main = - -- 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) +main = fuzz @Api server defaultConfig (pure ()) defaultConfig :: Config defaultConfig = Config { diff --git a/src/Roboservant/Types/FlattenServer.hs b/src/Roboservant/Types/FlattenServer.hs index 0d02401..9c918fa 100644 --- a/src/Roboservant/Types/FlattenServer.hs +++ b/src/Roboservant/Types/FlattenServer.hs @@ -6,6 +6,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +-- | terrible name, this really just pulls stuff out where we can fiddle with it. module Roboservant.Types.FlattenServer where @@ -18,10 +19,10 @@ data Bundled endpoints where class FlattenServer api where flattenServer :: Server api -> Bundled (Endpoints api) + instance - ( Endpoints (endpoint :<|> api) ~ (endpoint ': Endpoints api) --- , Server (endpoint :<|> api) ~ (Server endpoint :<|> Server api) - , FlattenServer api + ( FlattenServer api + , Endpoints endpoint ~ '[endpoint] ) => FlattenServer (endpoint :<|> api) where diff --git a/src/Roboservant/Types/ReifiedApi.hs b/src/Roboservant/Types/ReifiedApi.hs index 036a0bf..6e118d6 100644 --- a/src/Roboservant/Types/ReifiedApi.hs +++ b/src/Roboservant/Types/ReifiedApi.hs @@ -55,11 +55,11 @@ type ReifiedApi = [(ApiOffset, ReifiedEndpoint)] tagType :: Typeable a => f a -> TypedF f a tagType = (R.typeRep :*:) -class ToReifiedApi (endpoints :: [*]) where +class ToReifiedApi (endpoints ) where + toReifiedApi :: Bundled endpoints -> Proxy endpoints -> ReifiedApi -class ( V.Curried (EndpointArgs endpoint) (Handler (EndpointRes endpoint)) ~ Server endpoint - , V.RecordToList (EndpointArgs endpoint) +class ( V.RecordToList (EndpointArgs endpoint) , V.RMap (EndpointArgs endpoint) ) => ToReifiedEndpoint (endpoint :: *) where type EndpointArgs endpoint :: [Type] @@ -72,10 +72,11 @@ instance ToReifiedApi '[] where instance ( Typeable (EndpointRes endpoint) + , NormalizeFunction (ServerT endpoint Handler) , Normal (ServerT endpoint Handler) ~ V.Curried (EndpointArgs endpoint) (IO (Either ServerError (NonEmpty (Dynamic,Int)))) , ToReifiedEndpoint endpoint - , ToReifiedApi endpoints, Typeable (ServerT endpoint Handler) + , ToReifiedApi endpoints ) => ToReifiedApi (endpoint : endpoints) where diff --git a/test/Nested.hs b/test/Nested.hs new file mode 100644 index 0000000..8dad15d --- /dev/null +++ b/test/Nested.hs @@ -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