diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index 93a54dbc..17fe995e 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -38,6 +38,7 @@ module Servant.Server -- * Config , Config(..) + , (.:.) , Tagged(..) -- * Default error type diff --git a/servant-server/src/Servant/Server/Internal/Config.hs b/servant-server/src/Servant/Server/Internal/Config.hs index 4b882399..e4a0c990 100644 --- a/servant-server/src/Servant/Server/Internal/Config.hs +++ b/servant-server/src/Servant/Server/Internal/Config.hs @@ -28,6 +28,10 @@ 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 @@ -40,20 +44,16 @@ 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 :: Symbol) a = Tag a +newtype Tagged tag a = Tag a deriving (Show, Eq) class HasConfigEntry (cfg :: [*]) tag (val :: *) where getConfigEntry :: Proxy tag -> Config cfg -> val instance OVERLAPPABLE_ - HasConfigEntry xs tag val => HasConfigEntry (notIt ': xs) tag val where + HasConfigEntry xs tag val => HasConfigEntry (Tagged notItTag notIt ': xs) tag val where getConfigEntry proxy (_ :. xs) = getConfigEntry proxy xs -instance OVERLAPPABLE_ - HasConfigEntry (val ': xs) () val where - getConfigEntry proxy (x :. _) = x - instance OVERLAPPABLE_ HasConfigEntry (Tagged tag val ': xs) tag val where - getConfigEntry proxy (Tag x :. _) = x + getConfigEntry Proxy (Tag x :. _) = x diff --git a/servant-server/test/Servant/Server/Internal/ConfigSpec.hs b/servant-server/test/Servant/Server/Internal/ConfigSpec.hs index c0822ce8..0bf31b10 100644 --- a/servant-server/test/Servant/Server/Internal/ConfigSpec.hs +++ b/servant-server/test/Servant/Server/Internal/ConfigSpec.hs @@ -13,20 +13,20 @@ spec :: Spec spec = do describe "getConfigEntry" $ do it "gets the config if a matching one exists" $ do - let config = 'a' :. EmptyConfig + let config = 'a' .:. EmptyConfig getConfigEntry (Proxy :: Proxy ()) config `shouldBe` 'a' it "gets the first matching config" $ do - let config = 'a' :. 'b' :. EmptyConfig + 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 + let config = 'a' .:. (Tag 'b' :: Tagged "second" Char) :. EmptyConfig getConfigEntry (Proxy :: Proxy ()) config `shouldBe` 'a' getConfigEntry (Proxy :: Proxy "second") config `shouldBe` 'b' it "does not typecheck if type does not exist" $ do - let config = 'a' :. EmptyConfig + let config = 'a' .:. EmptyConfig x = getConfigEntry (Proxy :: Proxy ()) config :: Bool shouldNotTypecheck x diff --git a/servant-server/test/Servant/Server/UsingConfigSpec.hs b/servant-server/test/Servant/Server/UsingConfigSpec.hs index 8eab507a..65ce56e9 100644 --- a/servant-server/test/Servant/Server/UsingConfigSpec.hs +++ b/servant-server/test/Servant/Server/UsingConfigSpec.hs @@ -24,7 +24,7 @@ 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 :<|> @@ -35,7 +35,7 @@ oneEntryTwiceApp = serve (Proxy :: Proxy OneEntryTwiceAPI) config $ testServer :<|> testServer where - config = ("configEntryTwice" :: String) :. EmptyConfig + config = ("configEntryTwice" :: String) .:. EmptyConfig type TwoDifferentEntries = "foo" :> ExtractFromConfig "foo" :> Get '[JSON] String :<|> diff --git a/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs b/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs index 442fc86f..006036d2 100644 --- a/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs +++ b/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs @@ -41,7 +41,7 @@ instance forall subApi (c :: [*]) tag . data InjectIntoConfig (tag :: k) instance (HasServer subApi) => - HasServer (InjectIntoConfig (tag :: Symbol) :> subApi) where + HasServer (InjectIntoConfig (tag :: k) :> subApi) where type ServerT (InjectIntoConfig tag :> subApi) m = ServerT subApi m @@ -55,19 +55,3 @@ instance (HasServer subApi) => subProxy = Proxy newConfig = (Tag "injected" :: Tagged tag String) :. config - -instance (HasServer subApi) => - HasServer (InjectIntoConfig () :> subApi) where - - type ServerT (InjectIntoConfig () :> subApi) m = - ServerT subApi m - type HasCfg (InjectIntoConfig () :> subApi) c = - (HasCfg subApi (String ': c)) - - route Proxy config delayed = - route subProxy newConfig delayed - where - subProxy :: Proxy subApi - subProxy = Proxy - - newConfig = "injected" :. config