git.iko.soy/typeable/servant
on master help sign in
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.

commit19ec395e66db0232464244c9b4def1883c828828 authorPaolo Capriotti <paolo@capriotti.io> dateTue 13 Jul 2021, 17:10 (5 years ago) parent21682f6
2 files changed+8−11
compare with master
unifiedsplit
servant-client/test/Servant/SuccessSpec.hs+5−7 servant-server/test/Servant/ServerSpec.hs+3−4
servant-client/test/Servant/SuccessSpec.hs+5−7
@@ -32,7 +32,6 @@ import Data.Foldable
3232import Data.Maybe
3333 (listToMaybe)
3434import Data.Monoid ()
35−import Data.SOP (NS (..), I (..))
3635import Data.Text
3736 (Text)
3837import qualified Network.HTTP.Client as C
@@ -43,11 +42,9 @@ import Test.HUnit
4342import Test.QuickCheck
4443
4544import Servant.API
46− (NoContent (NoContent), WithStatus (WithStatus), getHeaders)
45+ (NoContent (NoContent), WithStatus (WithStatus), getHeaders, Headers(..))
4746import Servant.Client
4847import qualified Servant.Client.Core.Request as Req
49−import Servant.Client.Internal.HttpClient
50− (defaultMakeClientRequest)
5148import Servant.ClientTestUtils
5249import Servant.Test.ComprehensiveAPI
5350
@@ -134,9 +131,10 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
134131 res <- runClient getUVerbRespHeaders baseUrl
135132 case res of
136133 Left e -> assertFailure $ show e
137− Right (Z (I (WithStatus val))) ->
138− getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
139− Right (S _) -> assertFailure "expected first alternative of union"
134+ Right val -> case matchUnion val of
135+ Just (WithStatus val' :: WithStatus 200 (Headers TestHeaders Bool))
136+ -> getHeaders val' `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
137+ Nothing -> assertFailure "unexpected alternative of union"
140138
141139 it "Stores Cookie in CookieJar after a redirect" $ \(_, baseUrl) -> do
142140 mgr <- C.newManager C.defaultManagerSettings
servant-server/test/Servant/ServerSpec.hs+3−4
@@ -7,6 +7,7 @@
77{-# LANGUAGE ScopedTypeVariables #-}
88{-# LANGUAGE TypeFamilies #-}
99{-# LANGUAGE TypeOperators #-}
10+{-# LANGUAGE TypeApplications #-}
1011{-# OPTIONS_GHC -freduction-depth=100 #-}
1112
1213module Servant.ServerSpec where
@@ -28,8 +29,6 @@ import Data.Maybe
2829 (fromMaybe)
2930import Data.Proxy
3031 (Proxy (Proxy))
31−import Data.SOP
32− (I (..), NS (..))
3332import Data.String
3433 (fromString)
3534import Data.String.Conversions
@@ -699,8 +698,8 @@ type UVerbResponseHeadersApi =
699698 Capture "ok" Bool :> UVerb 'GET '[JSON] UVerbHeaderResponse
700699
701700uverbResponseHeadersServer :: Server UVerbResponseHeadersApi
702−uverbResponseHeadersServer True = pure . Z . I . WithStatus $ addHeader 5 "foo"
703−uverbResponseHeadersServer False = pure . S . Z . I . WithStatus $ "bar"
701+uverbResponseHeadersServer True = respond . WithStatus @200 . addHeader @"H1" (5 :: Int) $ ("foo" :: String)
702+uverbResponseHeadersServer False = respond . WithStatus @404 $ ("bar" :: String)
704703
705704uverbResponseHeadersSpec :: Spec
706705uverbResponseHeadersSpec = describe "UVerbResponseHeaders" $ do