server/config: implemented newtypes instead of tags

servant-server/src/Servant/Server.hs

@@ -36,7 +36,6 @@ module Servant.Server
   , tweakResponse
 
   -- * Config
-  , ConfigEntry(..)
   , Config(..)
   , (.:.)
 

servant-server/src/Servant/Server/Internal/Config.hs

@@ -23,12 +23,6 @@ import Control.DeepSeq (NFData(rnf))
 import GHC.Generics (Generic)
 import Data.Typeable (Typeable)
 
--- | A single entry in the configuration. The first parameter is phantom, and
--- is used to lookup a @ConfigEntry@ in a @Config@.
-newtype ConfigEntry tag a = ConfigEntry { unConfigEntry :: a }
-  deriving ( Eq, Show, Read, Enum, Integral, Fractional, Generic, Typeable
-           , Num, Ord, Real, Functor, Foldable, Traversable, NFData)
-
 -- | The entire configuration.
 data Config a where
     EmptyConfig :: Config '[]
@@ -36,8 +30,8 @@ data Config a where
 
 instance Show (Config '[]) where
   show EmptyConfig = "EmptyConfig"
-instance (Show a, Show (Config as)) => Show (Config (ConfigEntry tag a ': as)) where
-  showsPrec outerPrecedence (ConsConfig (ConfigEntry a) as) =
+instance (Show a, Show (Config as)) => Show (Config (a ': as)) where
+  showsPrec outerPrecedence (ConsConfig a as) =
     showParen (outerPrecedence > 5) $
       shows a . showString " .:. " . shows as
 
@@ -46,17 +40,17 @@ instance Eq (Config '[]) where
 instance (Eq a, Eq (Config as)) => Eq (Config (a ': as)) where
     ConsConfig x1 y1 == ConsConfig x2 y2 = x1 == x2 && y1 == y2
 
-(.:.) :: x -> Config xs -> Config (ConfigEntry tag x ': xs)
-e .:. cfg = ConsConfig (ConfigEntry e) cfg
+(.:.) :: x -> Config xs -> Config (x ': xs)
+e .:. cfg = ConsConfig e cfg
 infixr 5 .:.
 
-class HasConfigEntry (cfg :: [*]) (tag :: k) (val :: *) | 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 (notIt ': xs) tag val where
-    getConfigEntry p (ConsConfig _ xs) = getConfigEntry p xs
+         HasConfigEntry xs val => HasConfigEntry (notIt ': xs) val where
+    getConfigEntry (ConsConfig _ xs) = getConfigEntry xs
 
 instance OVERLAPPABLE_
-         HasConfigEntry (ConfigEntry tag val ': xs) tag val where
-    getConfigEntry _ (ConsConfig x _) = unConfigEntry x
+         HasConfigEntry (val ': xs) val where
+    getConfigEntry (ConsConfig x _) = x

servant-server/test/Servant/Server/Internal/ConfigSpec.hs

@@ -13,23 +13,25 @@ spec :: Spec
 spec = do
   getConfigEntrySpec
 
+newtype Wrapped a = Wrap { unwrap :: a }
+
 getConfigEntrySpec :: Spec
 getConfigEntrySpec = describe "getConfigEntry" $ do
 
-  let cfg1 = 0 .:. EmptyConfig :: Config '[ConfigEntry "a" Int]
-      cfg2 = 1 .:. cfg1 :: Config '[ConfigEntry "a" Int, ConfigEntry "a" Int]
+  let cfg1 = 0 .:. EmptyConfig :: Config '[Int]
+      cfg2 = 1 .:. cfg1 :: Config '[Int, Int]
 
   it "gets the config if a matching one exists" $ do
 
-    getConfigEntry (Proxy :: Proxy "a") cfg1 `shouldBe` 0
+    getConfigEntry cfg1 `shouldBe` (0 :: Int)
 
   it "gets the first matching config" $ do
 
-    getConfigEntry (Proxy :: Proxy "a") cfg2 `shouldBe` 1
+    getConfigEntry cfg2 `shouldBe` (1 :: Int)
 
   it "allows to distinguish between different config entries with the same type by tag" $ do
-    let cfg = 'a' .:. 'b' .:. EmptyConfig :: Config '[ConfigEntry 1 Char, ConfigEntry 2 Char]
-    getConfigEntry (Proxy :: Proxy 1) cfg `shouldBe` 'a'
+    let cfg = 'a' .:. Wrap 'b' .:. EmptyConfig :: Config '[Char, Wrapped Char]
+    getConfigEntry cfg `shouldBe` 'a'
 
   context "Show instance" $ do
     let cfg = 1 .:. 2 .:. EmptyConfig
@@ -43,12 +45,7 @@ getConfigEntrySpec = describe "getConfigEntry" $ do
       let cfg = (1 .:. 'a' .:. EmptyConfig) :<|> ('b' .:. True .:. EmptyConfig)
       show cfg `shouldBe` "(1 .:. 'a' .:. EmptyConfig) :<|> ('b' .:. True .:. EmptyConfig)"
 
-  it "does not typecheck if key does not exist" $ do
+  it "does not typecheck if type does not exist" $ do
 
-    let x = getConfigEntry (Proxy :: Proxy "b") cfg1 :: Int
-    shouldNotTypecheck x
-
-  it "does not typecheck if key maps to a different type" $ do
-
-    let x = getConfigEntry (Proxy :: Proxy "a") cfg1 :: String
+    let x = getConfigEntry cfg1 :: Bool
     shouldNotTypecheck x

servant-server/test/Servant/Server/UsingConfigSpec.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeOperators #-}
 
@@ -13,11 +14,13 @@ import           Servant.Server.UsingConfigSpec.CustomCombinator
 
 -- * API
 
-data Tag1
-data Tag2
+newtype Wrapped a = Wrap { unwrap :: a }
+
+instance ToCustomConfig (Wrapped CustomConfig) where
+  toCustomConfig = unwrap
 
 type OneEntryAPI =
-  CustomCombinator Tag1 :> Get '[JSON] String
+  CustomCombinator CustomConfig :> Get '[JSON] String
 
 testServer :: Server OneEntryAPI
 testServer (CustomConfig s) = return s
@@ -26,34 +29,34 @@ oneEntryApp :: Application
 oneEntryApp =
   serve (Proxy :: Proxy OneEntryAPI) config testServer
   where
-    config :: Config '[ConfigEntry Tag1 CustomConfig]
+    config :: Config '[CustomConfig]
     config = CustomConfig "configValue" .:. EmptyConfig
 
 type OneEntryTwiceAPI =
-  "foo" :> CustomCombinator Tag1 :> Get '[JSON] String :<|>
-  "bar" :> CustomCombinator Tag1 :> Get '[JSON] String
+  "foo" :> CustomCombinator CustomConfig :> Get '[JSON] String :<|>
+  "bar" :> CustomCombinator CustomConfig :> Get '[JSON] String
 
 oneEntryTwiceApp :: Application
 oneEntryTwiceApp = serve (Proxy :: Proxy OneEntryTwiceAPI) config $
   testServer :<|>
   testServer
   where
-    config :: Config '[ConfigEntry Tag1 CustomConfig]
+    config :: Config '[CustomConfig]
     config = CustomConfig "configValueTwice" .:. EmptyConfig
 
 type TwoDifferentEntries =
-  "foo" :> CustomCombinator Tag1 :> Get '[JSON] String :<|>
-  "bar" :> CustomCombinator Tag2 :> Get '[JSON] String
+  "foo" :> CustomCombinator CustomConfig :> Get '[JSON] String :<|>
+  "bar" :> CustomCombinator (Wrapped CustomConfig) :> Get '[JSON] String
 
 twoDifferentEntries :: Application
 twoDifferentEntries = serve (Proxy :: Proxy TwoDifferentEntries) config $
   testServer :<|>
   testServer
   where
-    config :: Config '[ConfigEntry Tag1 CustomConfig, ConfigEntry Tag2 CustomConfig]
+    config :: Config '[CustomConfig, Wrapped CustomConfig]
     config =
       CustomConfig "firstConfigValue" .:.
-      CustomConfig "secondConfigValue" .:.
+      Wrap (CustomConfig "secondConfigValue") .:.
       EmptyConfig
 
 -- * tests

servant-server/test/Servant/Server/UsingConfigSpec/CustomCombinator.hs

@@ -17,18 +17,24 @@ import           Servant
 import           Servant.Server.Internal.Config
 import           Servant.Server.Internal.RoutingApplication
 
-data CustomCombinator (tag :: *)
+data CustomCombinator (entryType :: *)
 
 data CustomConfig = CustomConfig String
 
-instance forall subApi (c :: [*]) tag .
-  (HasServer subApi) =>
-  HasServer (CustomCombinator tag :> subApi) where
+class ToCustomConfig entryType where
+  toCustomConfig :: entryType -> CustomConfig
 
-  type ServerT (CustomCombinator tag :> subApi) m =
+instance ToCustomConfig CustomConfig where
+  toCustomConfig = id
+
+instance forall subApi (c :: [*]) entryType .
+  (HasServer subApi, ToCustomConfig entryType) =>
+  HasServer (CustomCombinator entryType :> subApi) where
+
+  type ServerT (CustomCombinator entryType :> subApi) m =
     CustomConfig -> ServerT subApi m
-  type HasCfg (CustomCombinator tag :> subApi) c =
-    (HasConfigEntry c tag CustomConfig, HasCfg subApi c)
+  type HasCfg (CustomCombinator entryType :> subApi) c =
+    (HasConfigEntry c entryType, HasCfg subApi c)
 
   route Proxy config delayed =
     route subProxy config (fmap (inject config) delayed :: Delayed (Server subApi))
@@ -36,5 +42,5 @@ instance forall subApi (c :: [*]) tag .
       subProxy :: Proxy subApi
       subProxy = Proxy
 
-      inject config f = f (getConfigEntry (Proxy :: Proxy tag) config)
+      inject config f = f (toCustomConfig (getConfigEntry config :: entryType))