Merge pull request #1641 from amesgen/custom-error-for-named-routes-n…

…o-generic Better type errors for `NamedRoutes` without `Generic` instance
haskell-servant · Mar 9, 2023 · 38f519a · 38f519a
2 parents a082794 + 420d633
commit 38f519a
Show file tree

Hide file tree

Showing 5 changed files with 27 additions and 1 deletion.
diff --git a/servant-client-core/src/Servant/Client/Core/HasClient.hs b/servant-client-core/src/Servant/Client/Core/HasClient.hs
@@ -860,6 +860,7 @@ instance
   ( forall n. GClient api n
   , HasClient m (ToServantApi api)
   , RunClient m
+  , ErrorIfNoGeneric api
   )
   => HasClient m (NamedRoutes api) where
   type Client m (NamedRoutes api) = api (AsClientT m)

diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs
@@ -61,6 +61,7 @@ import qualified GHC.Generics               as G
 import           GHC.TypeLits
 import           Servant.API
 import           Servant.API.ContentTypes
+import           Servant.API.TypeErrors
 import           Servant.API.TypeLevel
 import           Servant.API.Generic
 
@@ -1154,7 +1155,10 @@ instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth r
         authProxy = Proxy :: Proxy (BasicAuth realm usr)
         action' = over authInfo (|> toAuthInfo authProxy) action
 
-instance HasDocs (ToServantApi api) => HasDocs (NamedRoutes api) where
+instance
+  ( HasDocs (ToServantApi api)
+  , ErrorIfNoGeneric api
+  ) => HasDocs (NamedRoutes api) where
   docsFor Proxy = docsFor (Proxy :: Proxy (ToServantApi api))
 
 -- ToSample instances for simple types

diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs
@@ -1013,6 +1013,7 @@ instance
   ( HasServer (ToServantApi api) context
   , forall m. Generic (api (AsServerT m))
   , forall m. GServer api m
+  , ErrorIfNoGeneric api
   ) => HasServer (NamedRoutes api) context where
 
   type ServerT (NamedRoutes api) m = api (AsServerT m)

diff --git a/servant/src/Servant/API/TypeErrors.hs b/servant/src/Servant/API/TypeErrors.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE ConstraintKinds      #-}
 {-# LANGUAGE DataKinds            #-}
 {-# LANGUAGE PolyKinds            #-}
 {-# LANGUAGE TypeFamilies         #-}
@@ -12,9 +13,11 @@ module Servant.API.TypeErrors (
   PartialApplication,
   NoInstanceFor,
   NoInstanceForSub,
+  ErrorIfNoGeneric,
 ) where
 
 import Data.Kind
+import GHC.Generics (Generic(..))
 import GHC.TypeLits
 
 -- | No instance exists for @tycls (expr :> ...)@ because 
@@ -38,3 +41,19 @@ type Arity (ty :: k) = Arity' k
 type family Arity' (ty :: k) :: Nat where
   Arity' (_ -> ty) = 1 + Arity' ty
   Arity' _ = 0
+
+-- see https://blog.csongor.co.uk/report-stuck-families/
+type ErrorIfNoGeneric routes = Break (NoGeneric routes :: Type) (Rep (routes ()))
+
+data T1 a
+
+type family Break err a :: Constraint where
+  Break _ T1 = ((), ())
+  Break _ a  = ()
+
+type family NoGeneric (routes :: Type -> Type) where
+  NoGeneric routes = TypeError
+    ( 'Text "Named routes require a "
+      ':<>: 'ShowType Generic ':<>: 'Text " instance for "
+      ':<>: 'ShowType routes
+    )
diff --git a/servant/src/Servant/Links.hs b/servant/src/Servant/Links.hs
@@ -617,6 +617,7 @@ instance GLinkConstraints routes a => GLink routes a where
 instance
   ( HasLink (ToServantApi routes)
   , forall a. GLink routes a
+  , ErrorIfNoGeneric routes
   ) => HasLink (NamedRoutes routes) where
 
   type MkLink (NamedRoutes routes) a = routes (AsLink a)