Skip to content

Commit 0dd3821

Browse files
nbacqueynbacquey
committed
Move erroring instances of HasServer to separate file
1 parent 124dc14 commit 0dd3821

File tree

4 files changed

+86
-58
lines changed

4 files changed

+86
-58
lines changed

‎servant-server/servant-server.cabal

+1
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

+1
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

+2-58
Original file line numberDiff line numberDiff line change
@@ -41,7 +41,7 @@ import qualified Data.ByteString as B
4141
import qualified Data.ByteString.Builder as BB
4242
import qualified Data.ByteString.Char8 as BC8
4343
import qualified Data.ByteString.Lazy as BL
44-
import Data.Constraint (Constraint, Dict(..))
44+
import Data.Constraint (Dict(..))
4545
import Data.Either
4646
(partitionEithers)
4747
import Data.Maybe
@@ -56,7 +56,7 @@ import qualified Data.Text as T
5656
import Data.Typeable
5757
import GHC.Generics
5858
import GHC.TypeLits
59-
(KnownNat, KnownSymbol, TypeError, symbolVal)
59+
(KnownNat, KnownSymbol, symbolVal)
6060
import qualified Network.HTTP.Media as NHM
6161
import Network.HTTP.Types hiding
6262
(Header, ResponseHeaders)
@@ -90,7 +90,6 @@ import Servant.API.ResponseHeaders
9090
import Servant.API.Status
9191
(statusFromNat)
9292
import qualified Servant.Types.SourceT as S
93-
import Servant.API.TypeErrors
9493
import Web.HttpApiData
9594
(FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,
9695
parseUrlPieces)
@@ -106,8 +105,6 @@ import Servant.Server.Internal.RouteResult
106105
import Servant.Server.Internal.RoutingApplication
107106
import Servant.Server.Internal.ServerError
108107

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

@@ -814,59 +811,6 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA
814811

815812
hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s
816813

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

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

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

0 commit comments

Comments
 (0)