Move erroring instances of HasServer to separate file

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

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
 
 

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 <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
 --

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