From da171780b861028148f35c72a0996c9dda6648bb Mon Sep 17 00:00:00 2001
From: "Julian K. Arni" <jkarni@gmail.com>
Date: Sat, 26 Dec 2015 15:30:39 +0100
Subject: [PATCH] Tests for Config.

---
 servant-server/servant-server.cabal           |  3 ++
 .../src/Servant/Server/Internal/Config.hs     | 18 ++++++++-
 .../Servant/Server/Internal/ConfigSpec.hs     | 37 +++++++++++++++++++
 stack.yaml                                    |  1 +
 4 files changed, 57 insertions(+), 2 deletions(-)
 create mode 100644 servant-server/test/Servant/Server/Internal/ConfigSpec.hs

diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal
index b058bec8..d0d0e2a3 100644
--- a/servant-server/servant-server.cabal
+++ b/servant-server/servant-server.cabal
@@ -49,6 +49,7 @@ library
       , attoparsec         >= 0.12 && < 0.14
       , bytestring         >= 0.10 && < 0.11
       , containers         >= 0.5  && < 0.6
+      , deepseq            == 1.4.*
       , http-api-data      >= 0.1  && < 0.3
       , http-types         >= 0.8  && < 0.10
       , network-uri        >= 2.6  && < 2.7
@@ -96,6 +97,7 @@ test-suite spec
   main-is: Spec.hs
   other-modules:
       Servant.Server.Internal.EnterSpec
+      Servant.Server.Internal.ConfigSpec
       Servant.ServerSpec
       Servant.Utils.StaticFilesSpec
       Servant.Server.ErrorSpec
@@ -116,6 +118,7 @@ test-suite spec
     , servant
     , servant-server
     , string-conversions
+    , should-not-typecheck == 2.*
     , temporary
     , text
     , transformers
diff --git a/servant-server/src/Servant/Server/Internal/Config.hs b/servant-server/src/Servant/Server/Internal/Config.hs
index fd9cbe97..5c2855d8 100644
--- a/servant-server/src/Servant/Server/Internal/Config.hs
+++ b/servant-server/src/Servant/Server/Internal/Config.hs
@@ -11,6 +11,7 @@
 {-# LANGUAGE KindSignatures             #-}
 {-# LANGUAGE MultiParamTypeClasses      #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE PolyKinds                  #-}
 {-# LANGUAGE TypeOperators              #-}
 {-# LANGUAGE UndecidableInstances       #-}
 #if !MIN_VERSION_base(4,8,0)
@@ -18,6 +19,7 @@
 #endif
 module Servant.Server.Internal.Config where
 
+import Control.DeepSeq (NFData(rnf))
 import GHC.Generics (Generic)
 import Data.Typeable (Typeable)
 
@@ -25,7 +27,7 @@ import Data.Typeable (Typeable)
 -- 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)
+           , Num, Ord, Real, Functor, Foldable, Traversable, NFData)
 
 instance Applicative (ConfigEntry tag) where
     pure = ConfigEntry
@@ -40,11 +42,23 @@ data Config a where
     EmptyConfig :: Config '[]
     ConsConfig :: x -> Config xs -> Config (x ': xs)
 
+instance Eq (Config '[]) where
+    _ == _ = True
+instance (Eq a, Eq (Config as)) => Eq (Config (a ' : as)) where
+    ConsConfig x1 y1 == ConsConfig x2 y2 = x1 == x2 && y1 == y2
+
+instance NFData (Config '[]) where
+    rnf EmptyConfig = ()
+instance (NFData a, NFData (Config as)) => NFData (Config (a ': as)) where
+    rnf (x `ConsConfig` ys) = rnf x `seq` rnf ys
+
+
+
 (.:) :: x -> Config xs -> Config (ConfigEntry tag x ': xs)
 e .: cfg = ConsConfig (ConfigEntry e) cfg
 infixr 4 .:
 
-class HasConfigEntry (cfg :: [*]) a val | cfg a -> val where
+class HasConfigEntry (cfg :: [*]) (a :: k) (val :: *) | cfg a -> val where
     getConfigEntry :: proxy a -> Config cfg -> val
 
 instance
diff --git a/servant-server/test/Servant/Server/Internal/ConfigSpec.hs b/servant-server/test/Servant/Server/Internal/ConfigSpec.hs
new file mode 100644
index 00000000..01bccc44
--- /dev/null
+++ b/servant-server/test/Servant/Server/Internal/ConfigSpec.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE DataKinds #-}
+{-# OPTIONS_GHC -fdefer-type-errors #-}
+module Servant.Server.Internal.ConfigSpec (spec) where
+
+import           Data.Proxy                     (Proxy (..))
+import           Test.Hspec                     (Spec, describe, it, shouldBe)
+import           Test.ShouldNotTypecheck        (shouldNotTypecheck)
+
+import           Servant.Server.Internal.Config
+
+spec :: Spec
+spec = do
+  getConfigEntrySpec
+
+getConfigEntrySpec :: Spec
+getConfigEntrySpec = describe "getConfigEntry" $ do
+
+  let cfg1 = 0 .: EmptyConfig :: Config '[ConfigEntry "a" Int]
+      cfg2 = 1 .: cfg1 :: Config '[ConfigEntry "a" Int, ConfigEntry "a" Int]
+
+  it "gets the config if a matching one exists" $ do
+
+    getConfigEntry (Proxy :: Proxy "a") cfg1 `shouldBe` 0
+
+  it "gets the first matching config" $ do
+
+    getConfigEntry (Proxy :: Proxy "a") cfg2 `shouldBe` 1
+
+  it "does not typecheck if key 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
+    shouldNotTypecheck x
diff --git a/stack.yaml b/stack.yaml
index f370da09..c1aea0a2 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -16,4 +16,5 @@ packages:
 extra-deps:
 - engine-io-wai-1.0.2
 - control-monad-omega-0.3.1
+- should-not-typecheck-2.0.1
 resolver: nightly-2015-10-08