From aab7e0d5dd652221e114360a84a59ec54f40262f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Deest?= Date: Thu, 18 Nov 2021 11:49:28 +0100 Subject: [PATCH 1/2] Custom errors for HasClient, HasServer --- .../src/Servant/Client/Core/HasClient.hs | 19 +++++++- servant-server/src/Servant/Server/Internal.hs | 43 ++++++------------- 2 files changed, 31 insertions(+), 31 deletions(-) diff --git a/servant-client-core/src/Servant/Client/Core/HasClient.hs b/servant-client-core/src/Servant/Client/Core/HasClient.hs index ddd2d0cc..9b26c089 100644 --- a/servant-client-core/src/Servant/Client/Core/HasClient.hs +++ b/servant-client-core/src/Servant/Client/Core/HasClient.hs @@ -65,7 +65,7 @@ import Data.Text import Data.Proxy (Proxy (Proxy)) import GHC.TypeLits - (KnownNat, KnownSymbol, symbolVal) + (KnownNat, KnownSymbol, TypeError, symbolVal) import Network.HTTP.Types (Status) import qualified Network.HTTP.Types as H @@ -91,6 +91,7 @@ import Servant.API.Status import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment) import Servant.API.Modifiers (FoldRequired, RequiredArgument, foldRequiredArgument) +import Servant.API.TypeErrors import Servant.API.UVerb (HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion) @@ -979,3 +980,19 @@ decodedAs response ct = do Right val -> return val where accept = toList $ contentTypes ct + +------------------------------------------------------------------------------- +-- Custom type errors +------------------------------------------------------------------------------- + +-- Erroring instance for HasClient' when a combinator is not fully applied +instance (RunClient m, TypeError (PartialApplication HasClient arr)) => HasClient m ((arr :: a -> b) :> sub) + where + type Client m (arr :> sub) = TypeError (PartialApplication HasClient arr) + clientWithRoute _ _ _ = error "unreachable" + hoistClientMonad _ _ _ _ = error "unreachable" + +-- Erroring instances for 'HasClient' for unknown API combinators +instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceForSub (HasClient m) ty)) => HasClient m (ty :> sub) + +instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceFor (HasClient m api))) => HasClient m api diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index e751d90e..164c1f77 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -56,7 +56,7 @@ import qualified Data.Text as T import Data.Typeable import GHC.Generics import GHC.TypeLits - (KnownNat, KnownSymbol, symbolVal) + (KnownNat, KnownSymbol, TypeError, symbolVal) import qualified Network.HTTP.Media as NHM import Network.HTTP.Types hiding (Header, ResponseHeaders) @@ -90,6 +90,7 @@ 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) @@ -814,38 +815,15 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s ------------------------------------------------------------------------------- --- TypeError helpers +-- Custom type errors ------------------------------------------------------------------------------- --- | This instance catches mistakes when there are non-saturated --- type applications on LHS of ':>'. --- --- >>> serve (Proxy :: Proxy (Capture "foo" :> Get '[JSON] Int)) (error "...") --- ... --- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'. --- ...Maybe you haven't applied enough arguments to --- ...Capture' '[] "foo" --- ... --- --- >>> undefined :: Server (Capture "foo" :> Get '[JSON] Int) --- ... --- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'. --- ...Maybe you haven't applied enough arguments to --- ...Capture' '[] "foo" --- ... --- -instance TypeError (HasServerArrowKindError arr) => HasServer ((arr :: k -> l) :> api) context +-- Erroring instance for 'HasServer' when a combinator is not fully applied +instance TypeError (PartialApplication HasServer arr) => HasServer ((arr :: a -> b) :> sub) context where - type ServerT (arr :> api) m = TypeError (HasServerArrowKindError arr) - -- it doesn't really matter what sub route we peak - route _ _ _ = error "servant-server panic: impossible happened in HasServer (arr :> api)" - hoistServerWithContext _ _ _ = id - --- Cannot have TypeError here, otherwise use of this symbol will error :) -type HasServerArrowKindError arr = - 'Text "Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'." - ':$$: 'Text "Maybe you haven't applied enough arguments to" - ':$$: 'ShowType arr + type ServerT (arr :> sub) _ = TypeError (PartialApplication HasServer arr) + route = error "unreachable" + hoistServerWithContext _ _ _ _ = error "unreachable" -- | This instance prevents from accidentally using '->' instead of ':>' -- @@ -880,6 +858,11 @@ type HasServerArrowTypeError a b = ':$$: 'Text "and" ':$$: 'ShowType b +-- Erroring instances for 'HasServer' for unknown API combinators +instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub 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. -- From 75cb9ac24604182a5fa917307d86e6843108f4c1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Deest?= Date: Thu, 18 Nov 2021 13:50:21 +0100 Subject: [PATCH 2/2] Add comment about slightly incorrect error message --- servant-server/src/Servant/Server/Internal.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 164c1f77..bb35b9c8 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -859,6 +859,10 @@ type HasServerArrowTypeError a b = ':$$: '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 HasServer ty) => HasServer (ty :> sub) context instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasServer api context)) => HasServer api context