類型類的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！