From 9dc022bcdd350bdb0f0cd446e86f2202029a04e5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Sun, 10 Jan 2016 16:40:56 +0100 Subject: [PATCH] server/config: implemented newtypes instead of tags --- servant-server/src/Servant/Server.hs | 1 - .../src/Servant/Server/Internal/Config.hs | 26 +++++++------------ .../Servant/Server/Internal/ConfigSpec.hs | 23 +++++++--------- .../test/Servant/Server/UsingConfigSpec.hs | 25 ++++++++++-------- .../UsingConfigSpec/CustomCombinator.hs | 22 ++++++++++------ 5 files changed, 48 insertions(+), 49 deletions(-) diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index 74010909..33f1c7ab 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -36,7 +36,6 @@ module Servant.Server , tweakResponse -- * Config - , ConfigEntry(..) , Config(..) , (.:.) diff --git a/servant-server/src/Servant/Server/Internal/Config.hs b/servant-server/src/Servant/Server/Internal/Config.hs index c22414c3..e5c39fec 100644 --- a/servant-server/src/Servant/Server/Internal/Config.hs +++ b/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 diff --git a/servant-server/test/Servant/Server/Internal/ConfigSpec.hs b/servant-server/test/Servant/Server/Internal/ConfigSpec.hs index 15cb5bf6..f78b2229 100644 --- a/servant-server/test/Servant/Server/Internal/ConfigSpec.hs +++ b/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 diff --git a/servant-server/test/Servant/Server/UsingConfigSpec.hs b/servant-server/test/Servant/Server/UsingConfigSpec.hs index 32f7d4e2..5f7519ee 100644 --- a/servant-server/test/Servant/Server/UsingConfigSpec.hs +++ b/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 diff --git a/servant-server/test/Servant/Server/UsingConfigSpec/CustomCombinator.hs b/servant-server/test/Servant/Server/UsingConfigSpec/CustomCombinator.hs index 95f47588..2161e50a 100644 --- a/servant-server/test/Servant/Server/UsingConfigSpec/CustomCombinator.hs +++ b/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))