From b7625a8039d477ae288e6af89ca57a106d1510e7 Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Thu, 17 Mar 2022 17:10:05 +0100 Subject: [PATCH] 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 15cba22c..278b17be 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 79d092b9..9c07c761 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 7702ac0b..f2473e08 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 00000000..05eca0c0 --- /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