サーバントAPI型レベルルーティング（typeclasses） - 選択するインスタンスを選択する方法（：<|>）？

Question

Servant API仕様のサーバーハンドラ関数をURL型を指定して選択する方法を解明しようとしています。これは、Servant.Util.Linksとは異なります。リンクをテキスト形式ではなく、タイプレベルのリンクでハンドラ関数を選択する点です。

だから私は（Servant.Util.Linksに似）APIのAPIおよびエンドポイントを持っています。今私は、APIを "歩き回り"、エンドポイントと一致するサーバーハンドラ関数を取り上げたいと思います。これは私が思い付いたものです：

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トリックをした、次のコードは実際にコンパイルします！ IsElemによって算出されます -

トリックuser2407038が示唆されているように、型レベルブール値を使用することです。このようにして、型パラメータに制約を与えることができ、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) 

我々は、ORとを必要とし、タイプレベルで： - ：

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 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 

たちのブール値を計算します右または左の分岐を取るかどうかを調べる：

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) 

トリック：種類ブールの追加PARAMTER！

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) 

または右、私たちのPARAMTERが「Trueの場合：

-- 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をもう一度おねがいします。