Skip to content

Commit 9b4716f

Browse files
nbacqueynbacquey
committed
Move erroring instances of HasServer to separate file
1 parent 9bb838b commit 9b4716f

File tree

4 files changed

+95
-66
lines changed

4 files changed

+95
-66
lines changed

‎servant-server/servant-server.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -51,6 +51,7 @@ library
5151
Servant.Server.Internal.RoutingApplication
5252
Servant.Server.Internal.ServerError
5353
Servant.Server.StaticFiles
54+
Servant.Server.TypeErrors
5455
Servant.Server.UVerb
5556

5657
-- deprecated

‎servant-server/src/Servant/Server.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -126,6 +126,7 @@ import Data.Text
126126
import Network.Wai
127127
(Application)
128128
import Servant.Server.Internal
129+
import Servant.Server.TypeErrors ()
129130
import Servant.Server.UVerb
130131

131132

‎servant-server/src/Servant/Server/Internal.hs‎

Lines changed: 2 additions & 66 deletions
Original file line numberDiff line numberDiff line change
@@ -42,7 +42,7 @@ import qualified Data.ByteString as B
4242
import qualified Data.ByteString.Builder as BB
4343
import qualified Data.ByteString.Char8 as BC8
4444
import qualified Data.ByteString.Lazy as BL
45-
import Data.Constraint (Constraint, Dict(..))
45+
import Data.Constraint (Dict(..))
4646
import Data.Either
4747
(partitionEithers)
4848
import Data.Maybe
@@ -57,7 +57,7 @@ import qualified Data.Text as T
5757
import Data.Typeable
5858
import GHC.Generics
5959
import GHC.TypeLits
60-
(KnownNat, KnownSymbol, TypeError, symbolVal)
60+
(KnownNat, KnownSymbol, symbolVal)
6161
import qualified Network.HTTP.Media as NHM
6262
import Network.HTTP.Types hiding
6363
(Header, ResponseHeaders)
@@ -91,7 +91,6 @@ import Servant.API.ResponseHeaders
9191
import Servant.API.Status
9292
(statusFromNat)
9393
import qualified Servant.Types.SourceT as S
94-
import Servant.API.TypeErrors
9594
import Web.HttpApiData
9695
(FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,
9796
parseUrlPieces)
@@ -107,8 +106,6 @@ import Servant.Server.Internal.RouteResult
107106
import Servant.Server.Internal.RoutingApplication
108107
import Servant.Server.Internal.ServerError
109108

110-
import GHC.TypeLits
111-
(ErrorMessage (..))
112109
import Servant.API.TypeLevel
113110
(AtLeastOneFragment, FragmentUnique)
114111

@@ -817,67 +814,6 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA
817814

818815
hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s
819816

820-
-------------------------------------------------------------------------------
821-
-- Custom type errors
822-
-------------------------------------------------------------------------------
823-
824-
-- Erroring instance for 'HasServer' when a combinator is not fully applied
825-
instance TypeError (PartialApplication
826-
#if __GLASGOW_HASKELL__ >= 904
827-
@(Type -> [Type] -> Constraint)
828-
#endif
829-
HasServer arr) => HasServer ((arr :: a -> b) :> sub) context
830-
where
831-
type ServerT (arr :> sub) _ = TypeError (PartialApplication (HasServer :: * -> [*] -> Constraint) arr)
832-
route = error "unreachable"
833-
hoistServerWithContext _ _ _ _ = error "unreachable"
834-
835-
-- | This instance prevents from accidentally using '->' instead of ':>'
836-
--
837-
-- >>> serve (Proxy :: Proxy (Capture "foo" Int -> Get '[JSON] Int)) (error "...")
838-
-- ...
839-
-- ...No instance HasServer (a -> b).
840-
-- ...Maybe you have used '->' instead of ':>' between
841-
-- ...Capture' '[] "foo" Int
842-
-- ...and
843-
-- ...Verb 'GET 200 '[JSON] Int
844-
-- ...
845-
--
846-
-- >>> undefined :: Server (Capture "foo" Int -> Get '[JSON] Int)
847-
-- ...
848-
-- ...No instance HasServer (a -> b).
849-
-- ...Maybe you have used '->' instead of ':>' between
850-
-- ...Capture' '[] "foo" Int
851-
-- ...and
852-
-- ...Verb 'GET 200 '[JSON] Int
853-
-- ...
854-
--
855-
instance TypeError (HasServerArrowTypeError a b) => HasServer (a -> b) context
856-
where
857-
type ServerT (a -> b) m = TypeError (HasServerArrowTypeError a b)
858-
route _ _ _ = error "servant-server panic: impossible happened in HasServer (a -> b)"
859-
hoistServerWithContext _ _ _ = id
860-
861-
type HasServerArrowTypeError a b =
862-
'Text "No instance HasServer (a -> b)."
863-
':$$: 'Text "Maybe you have used '->' instead of ':>' between "
864-
':$$: 'ShowType a
865-
':$$: 'Text "and"
866-
':$$: 'ShowType b
867-
868-
-- Erroring instances for 'HasServer' for unknown API combinators
869-
870-
-- XXX: This omits the @context@ parameter, e.g.:
871-
--
872-
-- "There is no instance for HasServer (Bool :> …)". Do we care ?
873-
instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub
874-
#if __GLASGOW_HASKELL__ >= 904
875-
@(Type -> [Type] -> Constraint)
876-
#endif
877-
HasServer ty) => HasServer (ty :> sub) context
878-
879-
instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasServer api context)) => HasServer api context
880-
881817
-- | Ignore @'Fragment'@ in server handlers.
882818
-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
883819
--

‎servant-server/src/Servant/Server/TypeErrors.hs‎

Lines changed: 91 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,91 @@
1+
{-# LANGUAGE AllowAmbiguousTypes #-}
2+
{-# LANGUAGE CPP #-}
3+
{-# LANGUAGE DataKinds #-}
4+
{-# LANGUAGE FlexibleInstances #-}
5+
{-# LANGUAGE MultiParamTypeClasses #-}
6+
{-# LANGUAGE PolyKinds #-}
7+
{-# LANGUAGE TypeFamilies #-}
8+
{-# LANGUAGE TypeOperators #-}
9+
{-# LANGUAGE UndecidableInstances #-}
10+
11+
{-# OPTIONS_GHC -fno-warn-orphans #-}
12+
{-# OPTIONS_GHC -fno-warn-missing-methods #-}
13+
14+
-- | This module contains erroring instances for @Servant.Server.Internal@.
15+
-- They are separated from the bulk of the code, because they raise "missing methods"
16+
-- warnings. These warnings are expected, but ignoring them would lead to missing
17+
-- relevant warnings in @SServant.Server.Internal@. Therefore, we put them in a separate
18+
-- file, and ignore the warnings here.
19+
module Servant.Server.TypeErrors ()
20+
where
21+
22+
import Data.Constraint (Constraint)
23+
import GHC.TypeLits
24+
(TypeError)
25+
import Prelude ()
26+
import Prelude.Compat
27+
import Servant.API
28+
((:>))
29+
import Servant.API.TypeErrors
30+
31+
import Servant.Server.Internal
32+
33+
import GHC.TypeLits
34+
(ErrorMessage (..))
35+
36+
-- Erroring instance for 'HasServer' when a combinator is not fully applied
37+
instance TypeError (PartialApplication
38+
#if __GLASGOW_HASKELL__ >= 904
39+
@(Type -> [Type] -> Constraint)
40+
#endif
41+
HasServer arr) => HasServer ((arr :: a -> b) :> sub) context
42+
where
43+
type ServerT (arr :> sub) _ = TypeError (PartialApplication (HasServer :: * -> [*] -> Constraint) arr)
44+
route = error "unreachable"
45+
hoistServerWithContext _ _ _ _ = error "unreachable"
46+
47+
-- | This instance prevents from accidentally using '->' instead of ':>'
48+
--
49+
-- >>> serve (Proxy :: Proxy (Capture "foo" Int -> Get '[JSON] Int)) (error "...")
50+
-- ...
51+
-- ...No instance HasServer (a -> b).
52+
-- ...Maybe you have used '->' instead of ':>' between
53+
-- ...Capture' '[] "foo" Int
54+
-- ...and
55+
-- ...Verb 'GET 200 '[JSON] Int
56+
-- ...
57+
--
58+
-- >>> undefined :: Server (Capture "foo" Int -> Get '[JSON] Int)
59+
-- ...
60+
-- ...No instance HasServer (a -> b).
61+
-- ...Maybe you have used '->' instead of ':>' between
62+
-- ...Capture' '[] "foo" Int
63+
-- ...and
64+
-- ...Verb 'GET 200 '[JSON] Int
65+
-- ...
66+
--
67+
instance TypeError (HasServerArrowTypeError a b) => HasServer (a -> b) context
68+
where
69+
type ServerT (a -> b) m = TypeError (HasServerArrowTypeError a b)
70+
route _ _ _ = error "servant-server panic: impossible happened in HasServer (a -> b)"
71+
hoistServerWithContext _ _ _ = id
72+
73+
type HasServerArrowTypeError a b =
74+
'Text "No instance HasServer (a -> b)."
75+
':$$: 'Text "Maybe you have used '->' instead of ':>' between "
76+
':$$: 'ShowType a
77+
':$$: 'Text "and"
78+
':$$: 'ShowType b
79+
80+
-- Erroring instances for 'HasServer' for unknown API combinators
81+
82+
-- XXX: This omits the @context@ parameter, e.g.:
83+
--
84+
-- "There is no instance for HasServer (Bool :> …)". Do we care ?
85+
instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub
86+
#if __GLASGOW_HASKELL__ >= 904
87+
@(Type -> [Type] -> Constraint)
88+
#endif
89+
HasServer ty) => HasServer (ty :> sub) context
90+
91+
instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasServer api context)) => HasServer api context

0 commit comments

Comments
 (0)