Merge pull request #1486 from haskell-servant/type-errors

Custom errors for HasClient, HasServer

Author: Gaël Deest

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

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,15 @@ type HasServerArrowTypeError a b =
     ':$$: '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 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.
 --