Skip to content

Commit 257ff6c

Browse files
nbacqueynbacquey
committed
Move erroring instances of HasServer to separate file
1 parent afa8778 commit 257ff6c

File tree

4 files changed

+103
-66
lines changed

4 files changed

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

0 commit comments

Comments
 (0)