Better type errors for NamedRoutes without Generic

This commit is contained in:
amesgen 2023-01-22 23:48:15 +01:00
parent c382a1f34e
commit 420d633a90
No known key found for this signature in database
GPG key ID: 1A89EC203635A13D
5 changed files with 27 additions and 1 deletions

View file

@ -850,6 +850,7 @@ instance
( forall n. GClient api n ( forall n. GClient api n
, HasClient m (ToServantApi api) , HasClient m (ToServantApi api)
, RunClient m , RunClient m
, ErrorIfNoGeneric api
) )
=> HasClient m (NamedRoutes api) where => HasClient m (NamedRoutes api) where
type Client m (NamedRoutes api) = api (AsClientT m) type Client m (NamedRoutes api) = api (AsClientT m)

View file

@ -61,6 +61,7 @@ import qualified GHC.Generics as G
import GHC.TypeLits import GHC.TypeLits
import Servant.API import Servant.API
import Servant.API.ContentTypes import Servant.API.ContentTypes
import Servant.API.TypeErrors
import Servant.API.TypeLevel import Servant.API.TypeLevel
import Servant.API.Generic import Servant.API.Generic
@ -1154,7 +1155,10 @@ instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth r
authProxy = Proxy :: Proxy (BasicAuth realm usr) authProxy = Proxy :: Proxy (BasicAuth realm usr)
action' = over authInfo (|> toAuthInfo authProxy) action 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)) docsFor Proxy = docsFor (Proxy :: Proxy (ToServantApi api))
-- ToSample instances for simple types -- ToSample instances for simple types

View file

@ -983,6 +983,7 @@ instance
( HasServer (ToServantApi api) context ( HasServer (ToServantApi api) context
, forall m. Generic (api (AsServerT m)) , forall m. Generic (api (AsServerT m))
, forall m. GServer api m , forall m. GServer api m
, ErrorIfNoGeneric api
) => HasServer (NamedRoutes api) context where ) => HasServer (NamedRoutes api) context where
type ServerT (NamedRoutes api) m = api (AsServerT m) type ServerT (NamedRoutes api) m = api (AsServerT m)

View file

@ -1,3 +1,4 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
@ -12,9 +13,11 @@ module Servant.API.TypeErrors (
PartialApplication, PartialApplication,
NoInstanceFor, NoInstanceFor,
NoInstanceForSub, NoInstanceForSub,
ErrorIfNoGeneric,
) where ) where
import Data.Kind import Data.Kind
import GHC.Generics (Generic(..))
import GHC.TypeLits import GHC.TypeLits
-- | No instance exists for @tycls (expr :> ...)@ because -- | No instance exists for @tycls (expr :> ...)@ because
@ -38,3 +41,19 @@ type Arity (ty :: k) = Arity' k
type family Arity' (ty :: k) :: Nat where type family Arity' (ty :: k) :: Nat where
Arity' (_ -> ty) = 1 + Arity' ty Arity' (_ -> ty) = 1 + Arity' ty
Arity' _ = 0 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
)

View file

@ -613,6 +613,7 @@ instance GLinkConstraints routes a => GLink routes a where
instance instance
( HasLink (ToServantApi routes) ( HasLink (ToServantApi routes)
, forall a. GLink routes a , forall a. GLink routes a
, ErrorIfNoGeneric routes
) => HasLink (NamedRoutes routes) where ) => HasLink (NamedRoutes routes) where
type MkLink (NamedRoutes routes) a = routes (AsLink a) type MkLink (NamedRoutes routes) a = routes (AsLink a)