server/config: renamings

This commit is contained in:
Sönke Hahn 2016-01-10 16:50:17 +01:00
parent 9dc022bcdd
commit 88dda2f9c6
5 changed files with 32 additions and 39 deletions

View file

@ -37,7 +37,6 @@ module Servant.Server
-- * Config -- * Config
, Config(..) , Config(..)
, (.:.)
-- * Default error type -- * Default error type
, ServantErr(..) , ServantErr(..)

View file

@ -26,31 +26,28 @@ import Data.Typeable (Typeable)
-- | The entire configuration. -- | The entire configuration.
data Config a where data Config a where
EmptyConfig :: Config '[] EmptyConfig :: Config '[]
ConsConfig :: x -> Config xs -> Config (x ': xs) (:.) :: x -> Config xs -> Config (x ': xs)
infixr 5 :.
instance Show (Config '[]) where instance Show (Config '[]) where
show EmptyConfig = "EmptyConfig" show EmptyConfig = "EmptyConfig"
instance (Show a, Show (Config as)) => Show (Config (a ': as)) where instance (Show a, Show (Config as)) => Show (Config (a ': as)) where
showsPrec outerPrecedence (ConsConfig a as) = showsPrec outerPrecedence (a :. as) =
showParen (outerPrecedence > 5) $ showParen (outerPrecedence > 5) $
shows a . showString " .:. " . shows as shows a . showString " :. " . shows as
instance Eq (Config '[]) where instance Eq (Config '[]) where
_ == _ = True _ == _ = True
instance (Eq a, Eq (Config as)) => Eq (Config (a ': as)) where instance (Eq a, Eq (Config as)) => Eq (Config (a ': as)) where
ConsConfig x1 y1 == ConsConfig x2 y2 = x1 == x2 && y1 == y2 x1 :. y1 == x2 :. y2 = x1 == x2 && y1 == y2
(.:.) :: x -> Config xs -> Config (x ': xs)
e .:. cfg = ConsConfig e cfg
infixr 5 .:.
class HasConfigEntry (cfg :: [*]) (val :: *) where class HasConfigEntry (cfg :: [*]) (val :: *) where
getConfigEntry :: Config cfg -> val getConfigEntry :: Config cfg -> val
instance OVERLAPPABLE_ instance OVERLAPPABLE_
HasConfigEntry xs val => HasConfigEntry (notIt ': xs) val where HasConfigEntry xs val => HasConfigEntry (notIt ': xs) val where
getConfigEntry (ConsConfig _ xs) = getConfigEntry xs getConfigEntry (_ :. xs) = getConfigEntry xs
instance OVERLAPPABLE_ instance OVERLAPPABLE_
HasConfigEntry (val ': xs) val where HasConfigEntry (val ': xs) val where
getConfigEntry (ConsConfig x _) = x getConfigEntry (x :. _) = x

View file

@ -18,8 +18,8 @@ newtype Wrapped a = Wrap { unwrap :: a }
getConfigEntrySpec :: Spec getConfigEntrySpec :: Spec
getConfigEntrySpec = describe "getConfigEntry" $ do getConfigEntrySpec = describe "getConfigEntry" $ do
let cfg1 = 0 .:. EmptyConfig :: Config '[Int] let cfg1 = 0 :. EmptyConfig :: Config '[Int]
cfg2 = 1 .:. cfg1 :: Config '[Int, Int] cfg2 = 1 :. cfg1 :: Config '[Int, Int]
it "gets the config if a matching one exists" $ do it "gets the config if a matching one exists" $ do
@ -30,20 +30,20 @@ getConfigEntrySpec = describe "getConfigEntry" $ do
getConfigEntry cfg2 `shouldBe` (1 :: Int) getConfigEntry cfg2 `shouldBe` (1 :: Int)
it "allows to distinguish between different config entries with the same type by tag" $ do it "allows to distinguish between different config entries with the same type by tag" $ do
let cfg = 'a' .:. Wrap 'b' .:. EmptyConfig :: Config '[Char, Wrapped Char] let cfg = 'a' :. Wrap 'b' :. EmptyConfig :: Config '[Char, Wrapped Char]
getConfigEntry cfg `shouldBe` 'a' getConfigEntry cfg `shouldBe` 'a'
context "Show instance" $ do context "Show instance" $ do
let cfg = 1 .:. 2 .:. EmptyConfig let cfg = 1 :. 2 :. EmptyConfig
it "has a Show instance" $ do it "has a Show instance" $ do
show cfg `shouldBe` "1 .:. 2 .:. EmptyConfig" show cfg `shouldBe` "1 :. 2 :. EmptyConfig"
it "bracketing works" $ do it "bracketing works" $ do
show (Just cfg) `shouldBe` "Just (1 .:. 2 .:. EmptyConfig)" show (Just cfg) `shouldBe` "Just (1 :. 2 :. EmptyConfig)"
it "bracketing works with operators" $ do it "bracketing works with operators" $ do
let cfg = (1 .:. 'a' .:. EmptyConfig) :<|> ('b' .:. True .:. EmptyConfig) let cfg = (1 :. 'a' :. EmptyConfig) :<|> ('b' :. True :. EmptyConfig)
show cfg `shouldBe` "(1 .:. 'a' .:. EmptyConfig) :<|> ('b' .:. True .:. EmptyConfig)" show cfg `shouldBe` "(1 :. 'a' :. EmptyConfig) :<|> ('b' :. True :. EmptyConfig)"
it "does not typecheck if type does not exist" $ do it "does not typecheck if type does not exist" $ do

View file

@ -16,47 +16,47 @@ import Servant.Server.UsingConfigSpec.CustomCombinator
newtype Wrapped a = Wrap { unwrap :: a } newtype Wrapped a = Wrap { unwrap :: a }
instance ToCustomConfig (Wrapped CustomConfig) where instance ToCustomConfig (Wrapped String) where
toCustomConfig = unwrap toCustomConfig = unwrap
type OneEntryAPI = type OneEntryAPI =
CustomCombinator CustomConfig :> Get '[JSON] String CustomCombinator String :> Get '[JSON] String
testServer :: Server OneEntryAPI testServer :: Server OneEntryAPI
testServer (CustomConfig s) = return s testServer s = return s
oneEntryApp :: Application oneEntryApp :: Application
oneEntryApp = oneEntryApp =
serve (Proxy :: Proxy OneEntryAPI) config testServer serve (Proxy :: Proxy OneEntryAPI) config testServer
where where
config :: Config '[CustomConfig] config :: Config '[String]
config = CustomConfig "configValue" .:. EmptyConfig config = "configValue" :. EmptyConfig
type OneEntryTwiceAPI = type OneEntryTwiceAPI =
"foo" :> CustomCombinator CustomConfig :> Get '[JSON] String :<|> "foo" :> CustomCombinator String :> Get '[JSON] String :<|>
"bar" :> CustomCombinator CustomConfig :> Get '[JSON] String "bar" :> CustomCombinator String :> Get '[JSON] String
oneEntryTwiceApp :: Application oneEntryTwiceApp :: Application
oneEntryTwiceApp = serve (Proxy :: Proxy OneEntryTwiceAPI) config $ oneEntryTwiceApp = serve (Proxy :: Proxy OneEntryTwiceAPI) config $
testServer :<|> testServer :<|>
testServer testServer
where where
config :: Config '[CustomConfig] config :: Config '[String]
config = CustomConfig "configValueTwice" .:. EmptyConfig config = "configValueTwice" :. EmptyConfig
type TwoDifferentEntries = type TwoDifferentEntries =
"foo" :> CustomCombinator CustomConfig :> Get '[JSON] String :<|> "foo" :> CustomCombinator String :> Get '[JSON] String :<|>
"bar" :> CustomCombinator (Wrapped CustomConfig) :> Get '[JSON] String "bar" :> CustomCombinator (Wrapped String) :> Get '[JSON] String
twoDifferentEntries :: Application twoDifferentEntries :: Application
twoDifferentEntries = serve (Proxy :: Proxy TwoDifferentEntries) config $ twoDifferentEntries = serve (Proxy :: Proxy TwoDifferentEntries) config $
testServer :<|> testServer :<|>
testServer testServer
where where
config :: Config '[CustomConfig, Wrapped CustomConfig] config :: Config '[String, Wrapped String]
config = config =
CustomConfig "firstConfigValue" .:. "firstConfigValue" :.
Wrap (CustomConfig "secondConfigValue") .:. Wrap "secondConfigValue" :.
EmptyConfig EmptyConfig
-- * tests -- * tests

View file

@ -19,12 +19,10 @@ import Servant.Server.Internal.RoutingApplication
data CustomCombinator (entryType :: *) data CustomCombinator (entryType :: *)
data CustomConfig = CustomConfig String
class ToCustomConfig entryType where class ToCustomConfig entryType where
toCustomConfig :: entryType -> CustomConfig toCustomConfig :: entryType -> String
instance ToCustomConfig CustomConfig where instance ToCustomConfig String where
toCustomConfig = id toCustomConfig = id
instance forall subApi (c :: [*]) entryType . instance forall subApi (c :: [*]) entryType .
@ -32,7 +30,7 @@ instance forall subApi (c :: [*]) entryType .
HasServer (CustomCombinator entryType :> subApi) where HasServer (CustomCombinator entryType :> subApi) where
type ServerT (CustomCombinator entryType :> subApi) m = type ServerT (CustomCombinator entryType :> subApi) m =
CustomConfig -> ServerT subApi m String -> ServerT subApi m
type HasCfg (CustomCombinator entryType :> subApi) c = type HasCfg (CustomCombinator entryType :> subApi) c =
(HasConfigEntry c entryType, HasCfg subApi c) (HasConfigEntry c entryType, HasCfg subApi c)
@ -43,4 +41,3 @@ instance forall subApi (c :: [*]) entryType .
subProxy = Proxy subProxy = Proxy
inject config f = f (toCustomConfig (getConfigEntry config :: entryType)) inject config f = f (toCustomConfig (getConfigEntry config :: entryType))