Avoid using SOP constructors directly (#1434)

This is a followup to #1420. It uses `respond` and `matchUnion`, with the help of some type annotations, instead of the NS constructors from SOP.
haskell-servant · Jul 13, 2021 · 19ec395 · 19ec395
1 parent 21682f6
commit 19ec395
Show file tree

Hide file tree

Showing 2 changed files with 8 additions and 11 deletions.
diff --git a/servant-client/test/Servant/SuccessSpec.hs b/servant-client/test/Servant/SuccessSpec.hs
@@ -32,7 +32,6 @@ import           Data.Foldable
 import           Data.Maybe
                  (listToMaybe)
 import           Data.Monoid ()
-import           Data.SOP (NS (..), I (..))
 import           Data.Text
                  (Text)
 import qualified Network.HTTP.Client                as C
@@ -43,11 +42,9 @@ import           Test.HUnit
 import           Test.QuickCheck
 
 import           Servant.API
-                 (NoContent (NoContent), WithStatus (WithStatus), getHeaders)
+                 (NoContent (NoContent), WithStatus (WithStatus), getHeaders, Headers(..))
 import           Servant.Client
 import qualified Servant.Client.Core.Request        as Req
-import           Servant.Client.Internal.HttpClient
-                 (defaultMakeClientRequest)
 import           Servant.ClientTestUtils
 import           Servant.Test.ComprehensiveAPI
 
@@ -134,9 +131,10 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
       res <- runClient getUVerbRespHeaders baseUrl
       case res of
         Left e -> assertFailure $ show e
-        Right (Z (I (WithStatus val))) ->
-          getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
-        Right (S _) -> assertFailure "expected first alternative of union"
+        Right val -> case matchUnion val of
+          Just (WithStatus val' :: WithStatus 200 (Headers TestHeaders Bool))
+            -> getHeaders val' `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
+          Nothing -> assertFailure "unexpected alternative of union"
 
     it "Stores Cookie in CookieJar after a redirect" $ \(_, baseUrl) -> do
       mgr <- C.newManager C.defaultManagerSettings

diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs
@@ -7,6 +7,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies        #-}
 {-# LANGUAGE TypeOperators       #-}
+{-# LANGUAGE TypeApplications    #-}
 {-# OPTIONS_GHC -freduction-depth=100 #-}
 
 module Servant.ServerSpec where
@@ -28,8 +29,6 @@ import           Data.Maybe
                  (fromMaybe)
 import           Data.Proxy
                  (Proxy (Proxy))
-import           Data.SOP
-                 (I (..), NS (..))
 import           Data.String
                  (fromString)
 import           Data.String.Conversions
@@ -699,8 +698,8 @@ type UVerbResponseHeadersApi =
        Capture "ok" Bool :> UVerb 'GET '[JSON] UVerbHeaderResponse
 
 uverbResponseHeadersServer :: Server UVerbResponseHeadersApi
-uverbResponseHeadersServer True = pure . Z . I . WithStatus $ addHeader 5 "foo"
-uverbResponseHeadersServer False = pure . S . Z . I . WithStatus $ "bar"
+uverbResponseHeadersServer True = respond . WithStatus @200 . addHeader @"H1" (5 :: Int) $ ("foo" :: String)
+uverbResponseHeadersServer False = respond .  WithStatus @404 $ ("bar" :: String)
 
 uverbResponseHeadersSpec :: Spec
 uverbResponseHeadersSpec = describe "UVerbResponseHeaders" $ do