类型类的servant API类型级别路由 - 如何选择实例（：<|>）？

Question

我想通过指定它的URL类型来找出在Servant API规范中选择服务器处理函数的方法。这与Servant.Util.Links不同 - 我不希望链接为文本形式，而是通过typelevel链接选择处理函数。

所以我有API和API中的端点（类似于Servant.Util.Links）。现在我想通过API“走”，拿起与EndPoint匹配的服务器处理函数。这是我想出了：

http://lpaste.net/158062

{-# LANGUAGE MultiParamTypeClasses #-} 
{-# LANGUAGE FlexibleInstances #-} 

module Gonimo.GetEndpoint where 


import GHC.TypeLits 
import Servant.API 
import Servant.Utils.Links 
import Data.Proxy 
import Servant.Server 

class GetEndpoint api endpoint where 
    getEndpoint :: Proxy m -> Proxy api -> Proxy endpoint -> ServerT api m -> ServerT endpoint m 


instance (GetEndpoint b1 endpoint) => GetEndpoint (b1 :<|> b2) endpoint where 
    getEndpoint pM _ pE (lS :<|> _) = getEndpoint pM (Proxy :: Proxy b1) pE lS 


instance (GetEndpoint b2 endpoint) => GetEndpoint (b1 :<|> b2) endpoint where 
    getEndpoint pM _ pE (_ :<|> lR) = getEndpoint pM (Proxy :: Proxy b1) pE lR 

但GHC抱怨重复的实例：

Duplicate instance declarations: 
    instance forall (k :: BOX) b1 b2 (endpoint :: k). 
      GetEndpoint b1 endpoint => 
      GetEndpoint (b1 :<|> b2) endpoint 
    -- Defined at src/Gonimo/GetEndpoint.hs:22:10 
    instance forall (k :: BOX) b1 b2 (endpoint :: k). 
      GetEndpoint b2 endpoint => 
      GetEndpoint (b1 :<|> b2) endpoint 
    -- Defined at src/Gonimo/GetEndpoint.hs:26:10 

这一点我部分理解 - 但我应该怎么回事挑选右侧或左侧路线：< |>在类型级别？

感谢您的指点！

Answer 1

谢谢user2407038那伎俩，下面的代码实际上是编译的！

作为user2407038建议的技巧是使用类型级别布尔 - 它由IsElem计算。这样我们可以将约束条件放入类型参数中，并可以根据我们的bool -yeah的值选择一个实例！

一些样板：

{-# LANGUAGE FlexibleContexts #-} 
{-# LANGUAGE FunctionalDependencies #-} 
{-# LANGUAGE DataKinds  #-} 
{-# LANGUAGE TypeOperators #-} 
{-# LANGUAGE MultiParamTypeClasses #-} 
{-# LANGUAGE FlexibleInstances #-} 
{-# LANGUAGE ConstraintKinds  #-} 
{-# LANGUAGE KindSignatures  #-} 
{-# LANGUAGE TypeFamilies  #-} 
{-# LANGUAGE UndecidableInstances  #-} 
{-# LANGUAGE RankNTypes  #-} 
{-# LANGUAGE ScopedTypeVariables  #-} 
module Lib where 


import GHC.TypeLits 
import Servant.API hiding (IsElem) 
import Servant.Utils.Links hiding (IsElem, Or) 
import Data.Proxy 
import Servant.Server 
import   GHC.Exts    (Constraint) 
import Network.Wai (Application) 
import Control.Monad.Trans.Except (ExceptT) 

我们需要的还是和而在类型级别：

type family Or (a :: Bool) (b :: Bool) :: Bool where 
    Or 'False 'False = 'False 
    Or 'False 'True = 'True 
    Or 'True 'False = 'True 
    Or 'True 'True = 'True 

type family And (a :: Bool) (b :: Bool) :: Bool where 
    And 'False 'False = 'False 
    And 'False 'True = 'False 
    And 'True 'False = 'False 
    And 'True 'True = 'True 

type family Not (a :: Bool) :: Bool where 
    Not 'False = 'True 
    Not 'True = 'False 

- 计算我们BOOL：

type family IsElem endpoint api :: Bool where 
    IsElem e (sa :<|> sb)     = Or (IsElem e sa) (IsElem e sb) 
    IsElem (e :> sa) (e :> sb)    = IsElem sa sb 
    IsElem sa (Header sym x :> sb)   = IsElem sa sb 
    IsElem sa (ReqBody y x :> sb)   = IsElem sa sb 
    IsElem (Capture z y :> sa) (Capture x y :> sb) 
              = IsElem sa sb 
    IsElem sa (QueryParam x y :> sb)  = IsElem sa sb 
    IsElem sa (QueryParams x y :> sb)  = IsElem sa sb 
    IsElem sa (QueryFlag x :> sb)   = IsElem sa sb 
    IsElem (Verb m s ct typ) (Verb m s ct' typ) 
              = IsSubList ct ct' 
    IsElem e e        = True 
    IsElem sa sb       = False 

type family IsSubList a b :: Bool where 
    IsSubList '[] b   = True 
    IsSubList (x ': xs) y = Elem x y `And` IsSubList xs y 

type family Elem e es :: Bool where 
    Elem x (x ': xs) = True 
    Elem y (x ': xs) = Elem y xs 
    Elem y '[] = False 

type family EnableConstraint (c :: Constraint) (enable :: Bool) :: Constraint where 
    EnableConstraint c 'True = c 
    EnableConstraint c 'False =() 

使用我们的IsElem到确定是采取右边还是左边的分支：

type family PickLeftRight endpoint api :: Bool where 
    PickLeftRight endpoint (sa :<|> sb) = IsElem endpoint sb 
    PickLeftRight endpoint sa = 'True 

我们的切入点：

-- | Select a handler from an API by specifying a type level link. 
callHandler :: forall api endpoint. (GetEndpoint api endpoint (PickLeftRight endpoint api)) 
      => Proxy api 
      -> ServerT api (ExceptT ServantErr IO) 
      -> Proxy endpoint 
      -> ServerT endpoint (ExceptT ServantErr IO) 
callHandler pA handlers pE = getEndpoint (Proxy :: Proxy (PickLeftRight endpoint api)) pM pA pE handlers 
    where 
    pM = Proxy :: Proxy (ExceptT ServantErr IO) 

诀窍：一种布尔的附加放慢参数！

class GetEndpoint api endpoint (chooseRight :: Bool) where 
    getEndpoint :: forall m. Proxy chooseRight -> Proxy m -> Proxy api -> Proxy endpoint -> ServerT api m -> ServerT endpoint m 

现在用它来选择一个实例，或左：

-- Left choice 
instance (GetEndpoint b1 endpoint (PickLeftRight endpoint b1)) => GetEndpoint (b1 :<|> b2) endpoint 'False where 
    getEndpoint _ pM _ pEndpoint (lS :<|> _) = getEndpoint pLeftRight pM (Proxy :: Proxy b1) pEndpoint lS 
    where pLeftRight = Proxy :: Proxy (PickLeftRight endpoint b1) 

或向右移动，如果我们放慢参数是“真：

-- Right choice 
instance (GetEndpoint b2 endpoint (PickLeftRight endpoint b2)) => GetEndpoint (b1 :<|> b2) endpoint 'True where 
    getEndpoint _ pM _ pEndpoint (_ :<|> lR) = getEndpoint pLeftRight pM (Proxy :: Proxy b2) pEndpoint lR 
    where pLeftRight = Proxy :: Proxy (PickLeftRight endpoint b2) 

其他情况下 - 不相关的到原来的问题，但这里的完整性：

-- Pathpiece 
instance (KnownSymbol sym, GetEndpoint sa endpoint (PickLeftRight endpoint sa)) => GetEndpoint (sym :> sa) (sym :> endpoint) 'True where 
    getEndpoint _ pM _ pEndpoint server = getEndpoint pLeftRight pM (Proxy :: Proxy sa) (Proxy :: Proxy endpoint) server 
    where pLeftRight = Proxy :: Proxy (PickLeftRight endpoint sa) 

-- Capture 
instance (KnownSymbol sym, GetEndpoint sa endpoint (PickLeftRight endpoint sa)) => GetEndpoint (Capture sym a :> sa) (Capture sym1 a :> endpoint) 'True where 
    getEndpoint _ pM _ pEndpoint server a = getEndpoint pLeftRight pM (Proxy :: Proxy sa) (Proxy :: Proxy endpoint) (server a) 
    where pLeftRight = Proxy :: Proxy (PickLeftRight endpoint sa) 

-- QueryParam 
instance (KnownSymbol sym, GetEndpoint sa endpoint (PickLeftRight endpoint sa)) => GetEndpoint (QueryParam sym a :> sa) (QueryParam sym a :> endpoint) 'True where 
    getEndpoint _ pM _ pEndpoint server ma = getEndpoint pLeftRight pM (Proxy :: Proxy sa) (Proxy :: Proxy endpoint) (server ma) 
    where pLeftRight = Proxy :: Proxy (PickLeftRight endpoint sa) 

-- QueryParams 
instance (KnownSymbol sym, GetEndpoint sa endpoint (PickLeftRight endpoint sa)) => GetEndpoint (QueryParams sym a :> sa) (QueryParams sym a :> endpoint) 'True where 
    getEndpoint _ pM _ pEndpoint server as = getEndpoint pLeftRight pM (Proxy :: Proxy sa) (Proxy :: Proxy endpoint) (server as) 
    where pLeftRight = Proxy :: Proxy (PickLeftRight endpoint sa) 

-- QueryFlag 
instance (KnownSymbol sym, GetEndpoint sa endpoint (PickLeftRight endpoint sa)) => GetEndpoint (QueryFlag sym :> sa) (QueryFlag sym :> endpoint) 'True where 
    getEndpoint _ pM _ pEndpoint server f = getEndpoint pLeftRight pM (Proxy :: Proxy sa) (Proxy :: Proxy endpoint) (server f) 
    where pLeftRight = Proxy :: Proxy (PickLeftRight endpoint sa) 


-- Header 
instance (KnownSymbol sym, GetEndpoint sa endpoint (PickLeftRight endpoint sa)) => GetEndpoint (Header sym a :> sa) (Header sym a :> endpoint) 'True where 
    getEndpoint _ pM _ pEndpoint server ma = getEndpoint pLeftRight pM (Proxy :: Proxy sa) (Proxy :: Proxy endpoint) (server ma) 
    where pLeftRight = Proxy :: Proxy (PickLeftRight endpoint sa) 


-- ReqBody 
instance (GetEndpoint sa endpoint (PickLeftRight endpoint sa)) => GetEndpoint (ReqBody ct a :> sa) (ReqBody ct a :> endpoint) 'True where 
    getEndpoint _ pM _ pEndpoint server a = getEndpoint pLeftRight pM (Proxy :: Proxy sa) (Proxy :: Proxy endpoint) (server a) 
    where pLeftRight = Proxy :: Proxy (PickLeftRight endpoint sa) 


-- Verb 
instance GetEndpoint (Verb n s ct a) (Verb n s ct a) 'True where 
    getEndpoint _ _ _ _ server = server 


-- Raw 
instance GetEndpoint Raw Raw 'True where 
    getEndpoint _ _ _ _ server = server 

github上的完整代码。

再次感谢提示user2407038！