From 891a077311bf6950aeaaf63ef65cf6c1e849ec74 Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Thu, 17 Mar 2022 14:05:08 +0100 Subject: [PATCH 01/10] Ignore 'unticked promoted constructors' in TypeErrors The file is small enough that using unticked constructors should not be error-prone --- servant/src/Servant/API/TypeErrors.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/servant/src/Servant/API/TypeErrors.hs b/servant/src/Servant/API/TypeErrors.hs index 81a0e7eb2..e0c7080d6 100644 --- a/servant/src/Servant/API/TypeErrors.hs +++ b/servant/src/Servant/API/TypeErrors.hs @@ -4,6 +4,8 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} + -- | This module defines the error messages used in type-level errors. -- Type-level errors can signal non-existing instances, for instance when -- a combinator is not applied to the correct number of arguments. From 7da7f4eb3591f6016c1274a9fa54f38c574da56d Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Thu, 17 Mar 2022 14:12:57 +0100 Subject: [PATCH 02/10] Remove unused imports and variables --- .../src/Servant/Client/Core/HasClient.hs | 3 +- .../src/Servant/Client/Internal/HttpClient.hs | 6 +- .../Client/Internal/HttpClient/Streaming.hs | 2 - servant-client/test/Servant/StreamSpec.hs | 68 +------------------ servant-conduit/example/Main.hs | 2 - servant-docs/src/Servant/Docs/Internal.hs | 6 +- servant-machines/example/Main.hs | 2 - servant-pipes/example/Main.hs | 2 - servant-server/src/Servant/Server/Internal.hs | 4 +- .../src/Servant/Swagger/Internal.hs | 1 - servant/src/Servant/API/TypeErrors.hs | 1 - 11 files changed, 9 insertions(+), 88 deletions(-) diff --git a/servant-client-core/src/Servant/Client/Core/HasClient.hs b/servant-client-core/src/Servant/Client/Core/HasClient.hs index fe2a15f87..80f858024 100644 --- a/servant-client-core/src/Servant/Client/Core/HasClient.hs +++ b/servant-client-core/src/Servant/Client/Core/HasClient.hs @@ -32,7 +32,6 @@ import Control.Arrow (left, (+++)) import Control.Monad (unless) -import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL import Data.Either (partitionEithers) @@ -78,7 +77,7 @@ import Servant.API ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream, StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault, Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList, - getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes) + getResponse, toEncodedUrlPiece, NamedRoutes) import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi , GenericServant, toServant, fromServant) diff --git a/servant-client/src/Servant/Client/Internal/HttpClient.hs b/servant-client/src/Servant/Client/Internal/HttpClient.hs index 8db0c9f24..999805dc7 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient.hs +++ b/servant-client/src/Servant/Client/Internal/HttpClient.hs @@ -43,14 +43,12 @@ import qualified Data.ByteString as BS import Data.ByteString.Builder (toLazyByteString) import qualified Data.ByteString.Lazy as BSL -import Data.Either - (either) import Data.Foldable (foldl',toList) import Data.Functor.Alt (Alt (..)) import Data.Maybe - (maybe, maybeToList) + (maybeToList) import Data.Proxy (Proxy (..)) import Data.Sequence @@ -63,7 +61,7 @@ import GHC.Generics import Network.HTTP.Media (renderHeader) import Network.HTTP.Types - (hContentType, renderQuery, statusIsSuccessful, urlEncode, Status) + (hContentType, statusIsSuccessful, urlEncode, Status) import Servant.Client.Core import qualified Network.HTTP.Client as Client diff --git a/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs b/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs index 41a06572c..0b5a79dee 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs +++ b/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs @@ -24,8 +24,6 @@ import Control.DeepSeq (NFData, force) import Control.Exception (evaluate, throwIO) -import Control.Monad - (unless) import Control.Monad.Base (MonadBase (..)) import Control.Monad.Codensity diff --git a/servant-client/test/Servant/StreamSpec.hs b/servant-client/test/Servant/StreamSpec.hs index 850185769..0afa53dd5 100644 --- a/servant-client/test/Servant/StreamSpec.hs +++ b/servant-client/test/Servant/StreamSpec.hs @@ -21,16 +21,9 @@ module Servant.StreamSpec (spec) where -import Control.Monad - (when) -import Control.Monad.Codensity - (Codensity (..)) -import Control.Monad.IO.Class - (MonadIO (..)) import Control.Monad.Trans.Except import qualified Data.ByteString as BS import Data.Proxy -import qualified Data.TDigest as TD import qualified Network.HTTP.Client as C import Prelude () import Prelude.Compat @@ -46,20 +39,10 @@ import System.Entropy (getEntropy, getHardwareEntropy) import System.IO.Unsafe (unsafePerformIO) -import System.Mem - (performGC) import Test.Hspec import Servant.ClientTestUtils (Person(..)) import qualified Servant.ClientTestUtils as CT -#if MIN_VERSION_base(4,10,0) -import GHC.Stats - (gc, gcdetails_live_bytes, getRTSStats) -#else -import GHC.Stats - (currentBytesUsed, getGCStats) -#endif - -- This declaration simply checks that all instances are in place. -- Note: this is streaming client _ = client comprehensiveAPI @@ -78,9 +61,9 @@ api :: Proxy StreamApi api = Proxy getGetNL, getGetNS :: ClientM (SourceIO Person) -getGetALot :: ClientM (SourceIO BS.ByteString) +_getGetALot :: ClientM (SourceIO BS.ByteString) getStreamBody :: SourceT IO BS.ByteString -> ClientM (SourceIO BS.ByteString) -getGetNL :<|> getGetNS :<|> getGetALot :<|> getStreamBody = client api +getGetNL :<|> getGetNS :<|> _getGetALot :<|> getStreamBody = client api alice :: Person alice = Person "Alice" 42 @@ -134,50 +117,3 @@ streamSpec = beforeAll (CT.startWaiApp server) $ afterAll CT.endWaiApp $ do where input = ["foo", "", "bar"] output = ["foo", "bar"] - -{- - it "streams in constant memory" $ \(_, baseUrl) -> do - Right rs <- runClient getGetALot baseUrl - performGC - -- usage0 <- getUsage - -- putStrLn $ "Start: " ++ show usage0 - tdigest <- memoryUsage $ joinCodensitySourceT rs - - -- putStrLn $ "Median: " ++ show (TD.median tdigest) - -- putStrLn $ "Mean: " ++ show (TD.mean tdigest) - -- putStrLn $ "Stddev: " ++ show (TD.stddev tdigest) - - -- forM_ [0.01, 0.1, 0.2, 0.5, 0.8, 0.9, 0.99] $ \q -> - -- putStrLn $ "q" ++ show q ++ ": " ++ show (TD.quantile q tdigest) - - let Just stddev = TD.stddev tdigest - - -- standard deviation of 100k is ok, we generate 256M of data after all. - -- On my machine deviation is 40k-50k - stddev `shouldSatisfy` (< 100000) - -memoryUsage :: SourceT IO BS.ByteString -> IO (TD.TDigest 25) -memoryUsage src = unSourceT src $ loop mempty (0 :: Int) - where - loop !acc !_ Stop = return acc - loop !_ !_ (Error err) = fail err -- ! - loop !acc !n (Skip s) = loop acc n s - loop !acc !n (Effect ms) = ms >>= loop acc n - loop !acc !n (Yield _bs s) = do - usage <- liftIO getUsage - -- We perform GC in between as we generate garbage. - when (n `mod` 1024 == 0) $ liftIO performGC - loop (TD.insert usage acc) (n + 1) s - -getUsage :: IO Double -getUsage = fromIntegral . -#if MIN_VERSION_base(4,10,0) - gcdetails_live_bytes . gc <$> getRTSStats -#else - currentBytesUsed <$> getGCStats -#endif - memUsed `shouldSatisfy` (< megabytes 22) - -megabytes :: Num a => a -> a -megabytes n = n * (1000 ^ (2 :: Int)) --} diff --git a/servant-conduit/example/Main.hs b/servant-conduit/example/Main.hs index 85ababe00..a50bb707e 100644 --- a/servant-conduit/example/Main.hs +++ b/servant-conduit/example/Main.hs @@ -17,8 +17,6 @@ import Data.Maybe (fromMaybe) import Network.HTTP.Client (defaultManagerSettings, newManager) -import Network.Wai - (Application) import System.Environment (getArgs, lookupEnv) import Text.Read diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index b5c4bf1f7..e545a0358 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -55,7 +55,7 @@ import Data.String.Conversions import Data.Text (Text, unpack) import GHC.Generics - (Generic, Rep, K1(K1), M1(M1), U1(U1), V1, + (K1(K1), M1(M1), U1(U1), V1, (:*:)((:*:)), (:+:)(L1, R1)) import qualified GHC.Generics as G import GHC.TypeLits @@ -964,7 +964,7 @@ instance {-# OVERLAPPABLE #-} instance (ReflectMethod method) => HasDocs (NoContentVerb method) where - docsFor Proxy (endpoint, action) DocOptions{..} = + docsFor Proxy (endpoint, action) _ = single endpoint' action' where endpoint' = endpoint & method .~ method' @@ -982,7 +982,7 @@ instance (ReflectMethod method) => instance {-# OVERLAPPABLE #-} (Accept ct, KnownNat status, ReflectMethod method) => HasDocs (Stream method status framing ct a) where - docsFor Proxy (endpoint, action) DocOptions{..} = + docsFor Proxy (endpoint, action) _ = single endpoint' action' where endpoint' = endpoint & method .~ method' diff --git a/servant-machines/example/Main.hs b/servant-machines/example/Main.hs index 3f1a0bd6d..0ea35cf7f 100644 --- a/servant-machines/example/Main.hs +++ b/servant-machines/example/Main.hs @@ -17,8 +17,6 @@ import Data.Void (Void) import Network.HTTP.Client (defaultManagerSettings, newManager) -import Network.Wai - (Application) import System.Environment (getArgs, lookupEnv) import Text.Read diff --git a/servant-pipes/example/Main.hs b/servant-pipes/example/Main.hs index 8683f651e..6d0f1f38f 100644 --- a/servant-pipes/example/Main.hs +++ b/servant-pipes/example/Main.hs @@ -15,8 +15,6 @@ import Data.Maybe (fromMaybe) import Network.HTTP.Client (defaultManagerSettings, newManager) -import Network.Wai - (Application) import System.Environment (getArgs, lookupEnv) import System.IO diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index a4d74564e..7702ac0b2 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -95,8 +95,6 @@ import Servant.API.TypeErrors import Web.HttpApiData (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece, parseUrlPieces) -import Data.Kind - (Type) import Servant.Server.Internal.BasicAuth import Servant.Server.Internal.Context @@ -110,7 +108,7 @@ import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServerError import GHC.TypeLits - (ErrorMessage (..), TypeError) + (ErrorMessage (..)) import Servant.API.TypeLevel (AtLeastOneFragment, FragmentUnique) diff --git a/servant-swagger/src/Servant/Swagger/Internal.hs b/servant-swagger/src/Servant/Swagger/Internal.hs index 66cb05956..82dde9ee7 100644 --- a/servant-swagger/src/Servant/Swagger/Internal.hs +++ b/servant-swagger/src/Servant/Swagger/Internal.hs @@ -38,7 +38,6 @@ import Network.HTTP.Media (MediaType) import Servant.API import Servant.API.Description (FoldDescription, reflectDescription) -import Servant.API.Generic (ToServantApi, AsApi) import Servant.API.Modifiers (FoldRequired) import Servant.Swagger.Internal.TypeLevel.API diff --git a/servant/src/Servant/API/TypeErrors.hs b/servant/src/Servant/API/TypeErrors.hs index e0c7080d6..0cb2cda86 100644 --- a/servant/src/Servant/API/TypeErrors.hs +++ b/servant/src/Servant/API/TypeErrors.hs @@ -16,7 +16,6 @@ module Servant.API.TypeErrors ( NoInstanceForSub, ) where -import Data.Kind import GHC.TypeLits -- | No instance exists for @tycls (expr :> ...)@ because From 2a4c14744897ca3a9c0f18ed1cee2ae6c94d7fff Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Thu, 17 Mar 2022 14:17:37 +0100 Subject: [PATCH 03/10] Ignore deprecation warning in StreamingSpec We cannot use the recommended replacement `requestBody` => `getRequestBodyChunk`, because we are actually interested in the record selector, not the `Request -> IO ByteString` function. --- servant-server/test/Servant/Server/StreamingSpec.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/servant-server/test/Servant/Server/StreamingSpec.hs b/servant-server/test/Servant/Server/StreamingSpec.hs index 43ff3f69b..5f4697fae 100644 --- a/servant-server/test/Servant/Server/StreamingSpec.hs +++ b/servant-server/test/Servant/Server/StreamingSpec.hs @@ -4,6 +4,8 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} + -- | This module tests whether streaming works from client to server -- with a server implemented with servant-server. module Servant.Server.StreamingSpec where From 096afbc124538b1c6c0cd78d11163ba8a660d519 Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Thu, 17 Mar 2022 14:26:17 +0100 Subject: [PATCH 04/10] Resolve shadowing warnings by hiding shadowed values --- servant-server/test/Servant/Server/StreamingSpec.hs | 3 ++- .../test/Servant/Server/UsingContextSpec/TestCombinators.hs | 3 ++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/servant-server/test/Servant/Server/StreamingSpec.hs b/servant-server/test/Servant/Server/StreamingSpec.hs index 5f4697fae..78cf7d786 100644 --- a/servant-server/test/Servant/Server/StreamingSpec.hs +++ b/servant-server/test/Servant/Server/StreamingSpec.hs @@ -21,7 +21,8 @@ import Network.Wai import Network.Wai.Internal import Prelude () import Prelude.Compat -import Servant +import Servant hiding + (respond) import qualified System.Timeout import Test.Hspec diff --git a/servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs b/servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs index 1701a07d4..10f62592a 100644 --- a/servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs +++ b/servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs @@ -19,7 +19,8 @@ module Servant.Server.UsingContextSpec.TestCombinators where import GHC.TypeLits -import Servant +import Servant hiding + (inject) data ExtractFromContext From fd644b7cc80eae8838e389c66f6a61d2db27a1ef Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Thu, 17 Mar 2022 16:06:16 +0100 Subject: [PATCH 05/10] Rename Servant.Links into Servant.Links.Internal --- servant/src/Servant/{Links.hs => Links/Internal.hs} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename servant/src/Servant/{Links.hs => Links/Internal.hs} (100%) diff --git a/servant/src/Servant/Links.hs b/servant/src/Servant/Links/Internal.hs similarity index 100% rename from servant/src/Servant/Links.hs rename to servant/src/Servant/Links/Internal.hs From 7ccc54612fad056503cb1749ad62b7dc1382361e Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Thu, 17 Mar 2022 16:07:41 +0100 Subject: [PATCH 06/10] Move erroring instances of HasLink to separate file --- servant/servant.cabal | 4 ++ servant/src/Servant/Links.hs | 8 ++++ servant/src/Servant/Links/Internal.hs | 26 +----------- servant/src/Servant/Links/TypeErrors.hs | 56 +++++++++++++++++++++++++ 4 files changed, 70 insertions(+), 24 deletions(-) create mode 100644 servant/src/Servant/Links.hs create mode 100644 servant/src/Servant/Links/TypeErrors.hs diff --git a/servant/servant.cabal b/servant/servant.cabal index a3dc401dd..bc8679b9c 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -75,6 +75,10 @@ library exposed-modules: Servant.Links + other-modules: + Servant.Links.Internal + Servant.Links.TypeErrors + -- Bundled with GHC: Lower bound to not force re-installs -- text and mtl are bundled starting with GHC-8.4 -- diff --git a/servant/src/Servant/Links.hs b/servant/src/Servant/Links.hs new file mode 100644 index 000000000..3ce7388b7 --- /dev/null +++ b/servant/src/Servant/Links.hs @@ -0,0 +1,8 @@ +-- | Wrapper for Servant.Links.Internal, which brings in scope the instance declarations +-- in Servant.Links.TypeErrors +module Servant.Links + ( module Servant.Links.Internal + ) where + +import Servant.Links.Internal +import Servant.Links.TypeErrors () diff --git a/servant/src/Servant/Links/Internal.hs b/servant/src/Servant/Links/Internal.hs index 74314e0a4..066480851 100644 --- a/servant/src/Servant/Links/Internal.hs +++ b/servant/src/Servant/Links/Internal.hs @@ -100,7 +100,7 @@ -- `IsElem'` as a last resort. -- -- @since 0.14.1 -module Servant.Links ( +module Servant.Links.Internal ( module Servant.API.TypeLevel, -- * Building and using safe links @@ -141,7 +141,7 @@ import qualified Data.Text.Encoding as TE import Data.Type.Bool (If) import GHC.TypeLits - (KnownSymbol, TypeError, symbolVal) + (KnownSymbol, symbolVal) import Network.URI (URI (..), escapeURIString, isUnreserved) import Prelude () @@ -184,7 +184,6 @@ import Servant.API.Stream (Stream, StreamBody') import Servant.API.Sub (type (:>)) -import Servant.API.TypeErrors import Servant.API.TypeLevel import Servant.API.UVerb import Servant.API.Vault @@ -194,8 +193,6 @@ import Servant.API.Verbs import Servant.API.WithNamedContext (WithNamedContext) import Web.HttpApiData -import Data.Kind - (Type) -- | A safe link datatype. -- The only way of constructing a 'Link' is using 'safeLink', which means any @@ -648,22 +645,3 @@ simpleToLink _ toA _ = toLink toA (Proxy :: Proxy sub) -- $setup -- >>> import Servant.API -- >>> import Data.Text (Text) - --- Erroring instance for 'HasLink' when a combinator is not fully applied -instance TypeError (PartialApplication -#if __GLASGOW_HASKELL__ >= 904 - @(Type -> Constraint) -#endif - HasLink arr) => HasLink ((arr :: a -> b) :> sub) - where - type MkLink (arr :> sub) _ = TypeError (PartialApplication (HasLink :: * -> Constraint) arr) - toLink = error "unreachable" - --- Erroring instances for 'HasLink' for unknown API combinators -instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub -#if __GLASGOW_HASKELL__ >= 904 - @(Type -> Constraint) -#endif - HasLink ty) => HasLink (ty :> sub) - -instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasLink api)) => HasLink api diff --git a/servant/src/Servant/Links/TypeErrors.hs b/servant/src/Servant/Links/TypeErrors.hs new file mode 100644 index 000000000..75233fae1 --- /dev/null +++ b/servant/src/Servant/Links/TypeErrors.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-missing-methods #-} + +#if __GLASGOW_HASKELL__ >= 904 +{-# LANGUAGE TypeApplications #-} +#endif + +-- | This module contains erroring instances for @Servant.Links.Internal@. +-- They are separated from the bulk of the code, because they raise "missing methods" +-- warnings. These warnings are expected, but ignoring them would lead to missing +-- relevant warnings in @Servant.Links.Internal@. Therefore, we put them in a separate +-- file, and ignore the warnings here. +module Servant.Links.TypeErrors () + where + +import Data.Constraint +import GHC.TypeLits + (TypeError) +import Prelude () +import Prelude.Compat + +import Servant.API.Sub + (type (:>)) +import Servant.API.TypeErrors +import Servant.Links.Internal + +#if __GLASGOW_HASKELL__ >= 904 +import Data.Kind (Type) +#endif + +-- Erroring instance for 'HasLink' when a combinator is not fully applied +instance TypeError (PartialApplication +#if __GLASGOW_HASKELL__ >= 904 + @(Type -> Constraint) +#endif + HasLink arr) => HasLink ((arr :: a -> b) :> sub) + where + type MkLink (arr :> sub) _ = TypeError (PartialApplication (HasLink :: * -> Constraint) arr) + toLink = error "unreachable" + +-- Erroring instances for 'HasLink' for unknown API combinators +instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub +#if __GLASGOW_HASKELL__ >= 904 + @(Type -> Constraint) +#endif + HasLink ty) => HasLink (ty :> sub) + +instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasLink api)) => HasLink api From 5eced67f6cd557c980084c41d4b56f342ad5a1a7 Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Thu, 17 Mar 2022 16:31:28 +0100 Subject: [PATCH 07/10] rename Servant.Client.Core.HasClient into Servant.Client.Core.HasClient.Internal --- .../Servant/Client/Core/{HasClient.hs => HasClient/Internal.hs} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename servant-client-core/src/Servant/Client/Core/{HasClient.hs => HasClient/Internal.hs} (100%) diff --git a/servant-client-core/src/Servant/Client/Core/HasClient.hs b/servant-client-core/src/Servant/Client/Core/HasClient/Internal.hs similarity index 100% rename from servant-client-core/src/Servant/Client/Core/HasClient.hs rename to servant-client-core/src/Servant/Client/Core/HasClient/Internal.hs From 4a048250443729a8bb3510d65b27abc631e4edc4 Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Thu, 17 Mar 2022 16:44:24 +0100 Subject: [PATCH 08/10] Move erroring instances of HasClient to separate file --- servant-client-core/servant-client-core.cabal | 2 + .../src/Servant/Client/Core/HasClient.hs | 8 ++++ .../Servant/Client/Core/HasClient/Internal.hs | 21 +--------- .../Client/Core/HasClient/TypeErrors.hs | 41 +++++++++++++++++++ 4 files changed, 53 insertions(+), 19 deletions(-) create mode 100644 servant-client-core/src/Servant/Client/Core/HasClient.hs create mode 100644 servant-client-core/src/Servant/Client/Core/HasClient/TypeErrors.hs diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal index 1d15594f3..1dd23c1ac 100644 --- a/servant-client-core/servant-client-core.cabal +++ b/servant-client-core/servant-client-core.cabal @@ -44,6 +44,8 @@ library other-modules: Servant.Client.Core.Internal + Servant.Client.Core.HasClient.Internal + Servant.Client.Core.HasClient.TypeErrors -- Bundled with GHC: Lower bound to not force re-installs -- text and mtl are bundled starting with GHC-8.4 diff --git a/servant-client-core/src/Servant/Client/Core/HasClient.hs b/servant-client-core/src/Servant/Client/Core/HasClient.hs new file mode 100644 index 000000000..7c30115bf --- /dev/null +++ b/servant-client-core/src/Servant/Client/Core/HasClient.hs @@ -0,0 +1,8 @@ +-- | Wrapper for Servant.Client.Core.HasClient.Internal, which brings in scope the +-- instance declarations in Servant.Client.Core.HasClient.TypeErrors +module Servant.Client.Core.HasClient + ( module Servant.Client.Core.HasClient.Internal + ) where + +import Servant.Client.Core.HasClient.Internal +import Servant.Client.Core.HasClient.TypeErrors () diff --git a/servant-client-core/src/Servant/Client/Core/HasClient/Internal.hs b/servant-client-core/src/Servant/Client/Core/HasClient/Internal.hs index 80f858024..e4db171eb 100644 --- a/servant-client-core/src/Servant/Client/Core/HasClient/Internal.hs +++ b/servant-client-core/src/Servant/Client/Core/HasClient/Internal.hs @@ -14,7 +14,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -module Servant.Client.Core.HasClient ( +module Servant.Client.Core.HasClient.Internal ( clientIn, HasClient (..), EmptyClient (..), @@ -62,7 +62,7 @@ import Data.Text import Data.Proxy (Proxy (Proxy)) import GHC.TypeLits - (KnownNat, KnownSymbol, TypeError, symbolVal) + (KnownNat, KnownSymbol, symbolVal) import Network.HTTP.Types (Status) import qualified Network.HTTP.Types as H @@ -88,7 +88,6 @@ import Servant.API.Status import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment) import Servant.API.Modifiers (FoldRequired, RequiredArgument, foldRequiredArgument) -import Servant.API.TypeErrors import Servant.API.UVerb (HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion) @@ -974,19 +973,3 @@ decodedAs response ct = do Right val -> return val where accept = toList $ contentTypes ct - -------------------------------------------------------------------------------- --- Custom type errors -------------------------------------------------------------------------------- - --- Erroring instance for HasClient' when a combinator is not fully applied -instance (RunClient m, TypeError (PartialApplication HasClient arr)) => HasClient m ((arr :: a -> b) :> sub) - where - type Client m (arr :> sub) = TypeError (PartialApplication HasClient arr) - clientWithRoute _ _ _ = error "unreachable" - hoistClientMonad _ _ _ _ = error "unreachable" - --- Erroring instances for 'HasClient' for unknown API combinators -instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceForSub (HasClient m) ty)) => HasClient m (ty :> sub) - -instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceFor (HasClient m api))) => HasClient m api diff --git a/servant-client-core/src/Servant/Client/Core/HasClient/TypeErrors.hs b/servant-client-core/src/Servant/Client/Core/HasClient/TypeErrors.hs new file mode 100644 index 000000000..bddb6a4f3 --- /dev/null +++ b/servant-client-core/src/Servant/Client/Core/HasClient/TypeErrors.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-missing-methods #-} + +-- | This module contains erroring instances for @Servant.Client.Core.HasClient.Internal@. +-- They are separated from the bulk of the code, because they raise "missing methods" +-- warnings. These warnings are expected, but ignoring them would lead to missing +-- relevant warnings in @Servant.Client.Core.HasClient.Internal@. Therefore, we put them +-- in a separate file, and ignore the warnings here. +module Servant.Client.Core.HasClient.TypeErrors () + where + +import Prelude () +import Prelude.Compat + +import GHC.TypeLits + (TypeError) +import Servant.API + ((:>)) +import Servant.API.TypeErrors + +import Servant.Client.Core.HasClient.Internal +import Servant.Client.Core.RunClient + +-- Erroring instance for HasClient' when a combinator is not fully applied +instance (RunClient m, TypeError (PartialApplication HasClient arr)) => HasClient m ((arr :: a -> b) :> sub) + where + type Client m (arr :> sub) = TypeError (PartialApplication HasClient arr) + clientWithRoute _ _ _ = error "unreachable" + hoistClientMonad _ _ _ _ = error "unreachable" + +-- Erroring instances for 'HasClient' for unknown API combinators +instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceForSub (HasClient m) ty)) => HasClient m (ty :> sub) + +instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceFor (HasClient m api))) => HasClient m api From b7625a8039d477ae288e6af89ca57a106d1510e7 Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Thu, 17 Mar 2022 17:10:05 +0100 Subject: [PATCH 09/10] Move erroring instances of HasServer to separate file --- servant-server/servant-server.cabal | 3 + servant-server/src/Servant/Server.hs | 1 + servant-server/src/Servant/Server/Internal.hs | 68 +------------ .../src/Servant/Server/TypeErrors.hs | 99 +++++++++++++++++++ 4 files changed, 105 insertions(+), 66 deletions(-) create mode 100644 servant-server/src/Servant/Server/TypeErrors.hs diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 15cba22ce..278b17beb 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -53,6 +53,9 @@ library Servant.Server.StaticFiles Servant.Server.UVerb + other-modules: + Servant.Server.TypeErrors + -- deprecated exposed-modules: Servant.Utils.StaticFiles diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index 79d092b95..9c07c761c 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -126,6 +126,7 @@ import Data.Text import Network.Wai (Application) import Servant.Server.Internal +import Servant.Server.TypeErrors () import Servant.Server.UVerb diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 7702ac0b2..f2473e087 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -42,7 +42,7 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Char8 as BC8 import qualified Data.ByteString.Lazy as BL -import Data.Constraint (Constraint, Dict(..)) +import Data.Constraint (Dict(..)) import Data.Either (partitionEithers) import Data.Maybe @@ -57,7 +57,7 @@ import qualified Data.Text as T import Data.Typeable import GHC.Generics import GHC.TypeLits - (KnownNat, KnownSymbol, TypeError, symbolVal) + (KnownNat, KnownSymbol, symbolVal) import qualified Network.HTTP.Media as NHM import Network.HTTP.Types hiding (Header, ResponseHeaders) @@ -91,7 +91,6 @@ import Servant.API.ResponseHeaders import Servant.API.Status (statusFromNat) import qualified Servant.Types.SourceT as S -import Servant.API.TypeErrors import Web.HttpApiData (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece, parseUrlPieces) @@ -107,8 +106,6 @@ import Servant.Server.Internal.RouteResult import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServerError -import GHC.TypeLits - (ErrorMessage (..)) import Servant.API.TypeLevel (AtLeastOneFragment, FragmentUnique) @@ -817,67 +814,6 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s -------------------------------------------------------------------------------- --- Custom type errors -------------------------------------------------------------------------------- - --- Erroring instance for 'HasServer' when a combinator is not fully applied -instance TypeError (PartialApplication -#if __GLASGOW_HASKELL__ >= 904 - @(Type -> [Type] -> Constraint) -#endif - HasServer arr) => HasServer ((arr :: a -> b) :> sub) context - where - type ServerT (arr :> sub) _ = TypeError (PartialApplication (HasServer :: * -> [*] -> Constraint) arr) - route = error "unreachable" - hoistServerWithContext _ _ _ _ = error "unreachable" - --- | This instance prevents from accidentally using '->' instead of ':>' --- --- >>> serve (Proxy :: Proxy (Capture "foo" Int -> Get '[JSON] Int)) (error "...") --- ... --- ...No instance HasServer (a -> b). --- ...Maybe you have used '->' instead of ':>' between --- ...Capture' '[] "foo" Int --- ...and --- ...Verb 'GET 200 '[JSON] Int --- ... --- --- >>> undefined :: Server (Capture "foo" Int -> Get '[JSON] Int) --- ... --- ...No instance HasServer (a -> b). --- ...Maybe you have used '->' instead of ':>' between --- ...Capture' '[] "foo" Int --- ...and --- ...Verb 'GET 200 '[JSON] Int --- ... --- -instance TypeError (HasServerArrowTypeError a b) => HasServer (a -> b) context - where - type ServerT (a -> b) m = TypeError (HasServerArrowTypeError a b) - route _ _ _ = error "servant-server panic: impossible happened in HasServer (a -> b)" - hoistServerWithContext _ _ _ = id - -type HasServerArrowTypeError a b = - 'Text "No instance HasServer (a -> b)." - ':$$: 'Text "Maybe you have used '->' instead of ':>' between " - ':$$: 'ShowType a - ':$$: 'Text "and" - ':$$: 'ShowType b - --- Erroring instances for 'HasServer' for unknown API combinators - --- XXX: This omits the @context@ parameter, e.g.: --- --- "There is no instance for HasServer (Bool :> …)". Do we care ? -instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub -#if __GLASGOW_HASKELL__ >= 904 - @(Type -> [Type] -> Constraint) -#endif - HasServer ty) => HasServer (ty :> sub) context - -instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasServer api context)) => HasServer api context - -- | Ignore @'Fragment'@ in server handlers. -- See for more details. -- diff --git a/servant-server/src/Servant/Server/TypeErrors.hs b/servant-server/src/Servant/Server/TypeErrors.hs new file mode 100644 index 000000000..05eca0c06 --- /dev/null +++ b/servant-server/src/Servant/Server/TypeErrors.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-missing-methods #-} + +#if __GLASGOW_HASKELL__ >= 904 +{-# LANGUAGE TypeApplications #-} +#endif + +-- | This module contains erroring instances for @Servant.Server.Internal@. +-- They are separated from the bulk of the code, because they raise "missing methods" +-- warnings. These warnings are expected, but ignoring them would lead to missing +-- relevant warnings in @SServant.Server.Internal@. Therefore, we put them in a separate +-- file, and ignore the warnings here. +module Servant.Server.TypeErrors () + where + +import Data.Constraint (Constraint) +import GHC.TypeLits + (TypeError) +import Prelude () +import Prelude.Compat +import Servant.API + ((:>)) +import Servant.API.TypeErrors + +import Servant.Server.Internal + +import GHC.TypeLits + (ErrorMessage (..)) + +#if __GLASGOW_HASKELL__ >= 904 +import Data.Kind (Type) +#endif + +-- Erroring instance for 'HasServer' when a combinator is not fully applied +instance TypeError (PartialApplication +#if __GLASGOW_HASKELL__ >= 904 + @(Type -> [Type] -> Constraint) +#endif + HasServer arr) => HasServer ((arr :: a -> b) :> sub) context + where + type ServerT (arr :> sub) _ = TypeError (PartialApplication (HasServer :: * -> [*] -> Constraint) arr) + route = error "unreachable" + hoistServerWithContext _ _ _ _ = error "unreachable" + +-- | This instance prevents from accidentally using '->' instead of ':>' +-- +-- >>> serve (Proxy :: Proxy (Capture "foo" Int -> Get '[JSON] Int)) (error "...") +-- ... +-- ...No instance HasServer (a -> b). +-- ...Maybe you have used '->' instead of ':>' between +-- ...Capture' '[] "foo" Int +-- ...and +-- ...Verb 'GET 200 '[JSON] Int +-- ... +-- +-- >>> undefined :: Server (Capture "foo" Int -> Get '[JSON] Int) +-- ... +-- ...No instance HasServer (a -> b). +-- ...Maybe you have used '->' instead of ':>' between +-- ...Capture' '[] "foo" Int +-- ...and +-- ...Verb 'GET 200 '[JSON] Int +-- ... +-- +instance TypeError (HasServerArrowTypeError a b) => HasServer (a -> b) context + where + type ServerT (a -> b) m = TypeError (HasServerArrowTypeError a b) + route _ _ _ = error "servant-server panic: impossible happened in HasServer (a -> b)" + hoistServerWithContext _ _ _ = id + +type HasServerArrowTypeError a b = + 'Text "No instance HasServer (a -> b)." + ':$$: 'Text "Maybe you have used '->' instead of ':>' between " + ':$$: 'ShowType a + ':$$: 'Text "and" + ':$$: 'ShowType b + +-- Erroring instances for 'HasServer' for unknown API combinators + +-- XXX: This omits the @context@ parameter, e.g.: +-- +-- "There is no instance for HasServer (Bool :> …)". Do we care ? +instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub +#if __GLASGOW_HASKELL__ >= 904 + @(Type -> [Type] -> Constraint) +#endif + HasServer ty) => HasServer (ty :> sub) context + +instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasServer api context)) => HasServer api context From e32b28c7c4f5f2c9b29ca21d0bf7e5e45041eaa1 Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Mon, 21 Mar 2022 12:32:59 +0100 Subject: [PATCH 10/10] Fix doctests --- servant-server/src/Servant/Server/TypeErrors.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/servant-server/src/Servant/Server/TypeErrors.hs b/servant-server/src/Servant/Server/TypeErrors.hs index 05eca0c06..6a8690ba7 100644 --- a/servant-server/src/Servant/Server/TypeErrors.hs +++ b/servant-server/src/Servant/Server/TypeErrors.hs @@ -97,3 +97,10 @@ instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub HasServer ty) => HasServer (ty :> sub) context instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasServer api context)) => HasServer api context + +-- $setup +-- >>> :set -XDataKinds +-- >>> :set -XTypeOperators +-- >>> import Data.Typeable +-- >>> import Servant.API +-- >>> import Servant.Server