Better type errors for NamedRoutes
without Generic
This commit is contained in:
parent
c382a1f34e
commit
420d633a90
5 changed files with 27 additions and 1 deletions
|
@ -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)
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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
|
||||||
|
)
|
||||||
|
|
|
@ -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)
|
||||||
|
|
Loading…
Reference in a new issue