From 420d633a90d663f25bd697a713695ab4404a8090 Mon Sep 17 00:00:00 2001
From: amesgen <amesgen@amesgen.de>
Date: Sun, 22 Jan 2023 23:48:15 +0100
Subject: [PATCH] Better type errors for `NamedRoutes` without `Generic`

---
 .../src/Servant/Client/Core/HasClient.hs      |  1 +
 servant-docs/src/Servant/Docs/Internal.hs     |  6 +++++-
 servant-server/src/Servant/Server/Internal.hs |  1 +
 servant/src/Servant/API/TypeErrors.hs         | 19 +++++++++++++++++++
 servant/src/Servant/Links.hs                  |  1 +
 5 files changed, 27 insertions(+), 1 deletion(-)

diff --git a/servant-client-core/src/Servant/Client/Core/HasClient.hs b/servant-client-core/src/Servant/Client/Core/HasClient.hs
index 18e6ef6c..d610c89c 100644
--- a/servant-client-core/src/Servant/Client/Core/HasClient.hs
+++ b/servant-client-core/src/Servant/Client/Core/HasClient.hs
@@ -850,6 +850,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
index 7e7706b5..555d367e 100644
--- 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
index d1bde0bf..8a5cd88e 100644
--- a/servant-server/src/Servant/Server/Internal.hs
+++ b/servant-server/src/Servant/Server/Internal.hs
@@ -983,6 +983,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
index 81a0e7eb..f1af8ad0 100644
--- 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
index 52ff4ae4..91b686d3 100644
--- a/servant/src/Servant/Links.hs
+++ b/servant/src/Servant/Links.hs
@@ -613,6 +613,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)