diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index 17fe995e..fac86621 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -38,8 +38,6 @@ module Servant.Server -- * Config , Config(..) - , (.:.) - , Tagged(..) -- * Default error type , ServantErr(..) diff --git a/servant-server/src/Servant/Server/Internal/Config.hs b/servant-server/src/Servant/Server/Internal/Config.hs index e4a0c990..61bc34d7 100644 --- a/servant-server/src/Servant/Server/Internal/Config.hs +++ b/servant-server/src/Servant/Server/Internal/Config.hs @@ -28,10 +28,6 @@ data Config a where (:.) :: x -> Config xs -> Config (x ': xs) infixr 5 :. -(.:.) :: forall x xs . x -> Config xs -> Config (Tagged () x ': xs) -x .:. xs = (Tag x :: Tagged () x) :. xs -infixr 5 .:. - instance Show (Config '[]) where show EmptyConfig = "EmptyConfig" instance (Show a, Show (Config as)) => Show (Config (a ': as)) where @@ -44,16 +40,13 @@ instance Eq (Config '[]) where instance (Eq a, Eq (Config as)) => Eq (Config (a ': as)) where x1 :. y1 == x2 :. y2 = x1 == x2 && y1 == y2 -newtype Tagged tag a = Tag a - deriving (Show, Eq) - -class HasConfigEntry (cfg :: [*]) tag (val :: *) where - getConfigEntry :: Proxy tag -> Config cfg -> val +class HasConfigEntry (cfg :: [*]) (val :: *) where + getConfigEntry :: Config cfg -> val instance OVERLAPPABLE_ - HasConfigEntry xs tag val => HasConfigEntry (Tagged notItTag notIt ': xs) tag val where - getConfigEntry proxy (_ :. xs) = getConfigEntry proxy xs + HasConfigEntry xs val => HasConfigEntry (notIt ': xs) val where + getConfigEntry (_ :. xs) = getConfigEntry xs instance OVERLAPPABLE_ - HasConfigEntry (Tagged tag val ': xs) tag val where - getConfigEntry Proxy (Tag x :. _) = x + HasConfigEntry (val ': xs) val where + getConfigEntry (x :. _) = x diff --git a/servant-server/test/Servant/Server/Internal/ConfigSpec.hs b/servant-server/test/Servant/Server/Internal/ConfigSpec.hs index 0bf31b10..f34129be 100644 --- a/servant-server/test/Servant/Server/Internal/ConfigSpec.hs +++ b/servant-server/test/Servant/Server/Internal/ConfigSpec.hs @@ -13,21 +13,16 @@ spec :: Spec spec = do describe "getConfigEntry" $ do it "gets the config if a matching one exists" $ do - let config = 'a' .:. EmptyConfig - getConfigEntry (Proxy :: Proxy ()) config `shouldBe` 'a' + let config = 'a' :. EmptyConfig + getConfigEntry config `shouldBe` 'a' it "gets the first matching config" $ do - let config = 'a' .:. 'b' .:. EmptyConfig - getConfigEntry (Proxy :: Proxy ()) config `shouldBe` 'a' - - it "allows to distinguish between different config entries with the same type by tag" $ do - let config = 'a' .:. (Tag 'b' :: Tagged "second" Char) :. EmptyConfig - getConfigEntry (Proxy :: Proxy ()) config `shouldBe` 'a' - getConfigEntry (Proxy :: Proxy "second") config `shouldBe` 'b' + let config = 'a' :. 'b' :. EmptyConfig + getConfigEntry config `shouldBe` 'a' it "does not typecheck if type does not exist" $ do - let config = 'a' .:. EmptyConfig - x = getConfigEntry (Proxy :: Proxy ()) config :: Bool + let config = 'a' :. EmptyConfig + x = getConfigEntry config :: Bool shouldNotTypecheck x it "does not typecheck if tag does not exist" $ do diff --git a/servant-server/test/Servant/Server/UsingConfigSpec.hs b/servant-server/test/Servant/Server/UsingConfigSpec.hs index c78f9901..d7f0d1a7 100644 --- a/servant-server/test/Servant/Server/UsingConfigSpec.hs +++ b/servant-server/test/Servant/Server/UsingConfigSpec.hs @@ -16,7 +16,7 @@ import Servant.Server.UsingConfigSpec.TestCombinators -- * API type OneEntryAPI = - ExtractFromConfig () :> Get '[JSON] String + ExtractFromConfig :> Get '[JSON] String testServer :: String -> ExceptT ServantErr IO String testServer s = return s @@ -25,32 +25,18 @@ oneEntryApp :: Application oneEntryApp = serve (Proxy :: Proxy OneEntryAPI) config testServer where - config = ("configEntry" :: String) .:. EmptyConfig + config = ("configEntry" :: String) :. EmptyConfig type OneEntryTwiceAPI = - "foo" :> ExtractFromConfig () :> Get '[JSON] String :<|> - "bar" :> ExtractFromConfig () :> Get '[JSON] String + "foo" :> ExtractFromConfig :> Get '[JSON] String :<|> + "bar" :> ExtractFromConfig :> Get '[JSON] String oneEntryTwiceApp :: Application oneEntryTwiceApp = serve (Proxy :: Proxy OneEntryTwiceAPI) config $ testServer :<|> testServer where - config = ("configEntryTwice" :: String) .:. EmptyConfig - -type TwoDifferentEntries = - "foo" :> ExtractFromConfig "foo" :> Get '[JSON] String :<|> - "bar" :> ExtractFromConfig "bar" :> Get '[JSON] String - -twoDifferentEntries :: Application -twoDifferentEntries = serve (Proxy :: Proxy TwoDifferentEntries) config $ - testServer :<|> - testServer - where - config = - (Tag "firstEntry" :: Tagged "foo" String) :. - (Tag "secondEntry" :: Tagged "bar" String) :. - EmptyConfig + config = ("configEntryTwice" :: String) :. EmptyConfig -- * tests @@ -66,17 +52,12 @@ spec = do get "/foo" `shouldRespondWith` "\"configEntryTwice\"" get "/bar" `shouldRespondWith` "\"configEntryTwice\"" - with (return twoDifferentEntries) $ do - it "allows to retrieve different ConfigEntries for the same combinator" $ do - get "/foo" `shouldRespondWith` "\"firstEntry\"" - get "/bar" `shouldRespondWith` "\"secondEntry\"" - spec2 type InjectAPI = - InjectIntoConfig () :> "untagged" :> ExtractFromConfig () :> + InjectIntoConfig :> "untagged" :> ExtractFromConfig :> Get '[JSON] String :<|> - InjectIntoConfig "tag" :> "tagged" :> ExtractFromConfig "tag" :> + InjectIntoConfig :> "tagged" :> ExtractFromConfig :> Get '[JSON] String injectApp :: Application @@ -99,21 +80,22 @@ spec2 = do spec3 type SubConfigAPI = - "foo" :> ExtractFromConfig () :> Get '[JSON] String :<|> - SubConfig "sub" '[Tagged () String] :> - "bar" :> ExtractFromConfig () :> Get '[JSON] String + "foo" :> ExtractFromConfig :> Get '[JSON] String :<|> + SubConfig "sub" '[String] :> + "bar" :> ExtractFromConfig :> Get '[JSON] String subConfigApp :: Application subConfigApp = serve (Proxy :: Proxy SubConfigAPI) config $ testServer :<|> testServer where - config :: Config '[Tagged () String, Tagged () (Tagged "sub" (Config '[Tagged () String]))] + config :: Config '[String, (Tagged "sub" (Config '[String]))] config = - ("firstEntry" :: String) .:. - (Tag (("secondEntry") .:. EmptyConfig)) .:. + ("firstEntry" :: String) :. + (Tag (("secondEntry" :: String) :. EmptyConfig)) :. EmptyConfig +spec3 :: Spec spec3 = do with (return subConfigApp) $ do it "allows to retrieve different ConfigEntries for the same combinator" $ do diff --git a/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs b/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs index 2b0c545d..34044569 100644 --- a/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs +++ b/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs @@ -19,16 +19,16 @@ import Servant import Servant.Server.Internal.Config import Servant.Server.Internal.RoutingApplication -data ExtractFromConfig (tag :: k) +data ExtractFromConfig -instance forall subApi (c :: [*]) tag . +instance forall subApi (c :: [*]) . (HasServer subApi) => - HasServer (ExtractFromConfig tag :> subApi) where + HasServer (ExtractFromConfig :> subApi) where - type ServerT (ExtractFromConfig tag :> subApi) m = + type ServerT (ExtractFromConfig :> subApi) m = String -> ServerT subApi m - type HasCfg (ExtractFromConfig tag :> subApi) c = - (HasConfigEntry c tag String, HasCfg subApi c) + type HasCfg (ExtractFromConfig :> subApi) c = + (HasConfigEntry c String, HasCfg subApi c) route Proxy config delayed = route subProxy config (fmap (inject config) delayed :: Delayed (Server subApi)) @@ -36,17 +36,17 @@ instance forall subApi (c :: [*]) tag . subProxy :: Proxy subApi subProxy = Proxy - inject config f = f (getConfigEntry (Proxy :: Proxy tag) config) + inject config f = f (getConfigEntry config) -data InjectIntoConfig (tag :: k) +data InjectIntoConfig instance (HasServer subApi) => - HasServer (InjectIntoConfig (tag :: k) :> subApi) where + HasServer (InjectIntoConfig :> subApi) where - type ServerT (InjectIntoConfig tag :> subApi) m = + type ServerT (InjectIntoConfig :> subApi) m = ServerT subApi m - type HasCfg (InjectIntoConfig tag :> subApi) c = - (HasCfg subApi (Tagged tag String ': c)) + type HasCfg (InjectIntoConfig :> subApi) c = + (HasCfg subApi (String ': c)) route Proxy config delayed = route subProxy newConfig delayed @@ -54,17 +54,20 @@ instance (HasServer subApi) => subProxy :: Proxy subApi subProxy = Proxy - newConfig = (Tag "injected" :: Tagged tag String) :. config + newConfig = ("injected" :: String) :. config data SubConfig (name :: Symbol) (subConfig :: [*]) +newtype Tagged tag a = Tag a + deriving (Show, Eq) + instance (HasServer subApi) => HasServer (SubConfig name subConfig :> subApi) where type ServerT (SubConfig name subConfig :> subApi) m = ServerT subApi m type HasCfg (SubConfig name subConfig :> subApi) config = - (HasConfigEntry config () (Tagged name (Config subConfig)), HasCfg subApi subConfig) + (HasConfigEntry config (Tagged name (Config subConfig)), HasCfg subApi subConfig) route Proxy config delayed = route subProxy subConfig delayed @@ -74,5 +77,5 @@ instance (HasServer subApi) => subConfig :: Config subConfig subConfig = - let Tag x = (getConfigEntry (Proxy :: Proxy ()) config) :: Tagged name (Config subConfig) + let Tag x = getConfigEntry config :: Tagged name (Config subConfig) in x