diff --git a/servant-client-core/src/Servant/Client/Core/HasClient.hs b/servant-client-core/src/Servant/Client/Core/HasClient.hs index a2e6ae25..8ae2d764 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 1f5f1ea8..970813d6 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)