在仆人内部与一对受类型类约束的单元组进行连接。

Question

请向下滚动阅读此问题的重要编辑。

原(长卷)问题

我的web应用程序的代码是用类型类受限的monad编写的，如下所示：

fetchOrderById :: (HasDatabase m) => Args -> m Result

sendConfirmationMail :: (HasSmtp m) => Args -> m EmailId

每个模块都有自己的server块，如下所示：

data Routes route = Routes
  { rFetchOrder :: route :- CustomAuth :> "orders" :> Capture "OrderId" OrderId :> Get '[JSON] Order
  , rDeleteOrder :: route :- CustomAuth :> "deleteOrder" :> Capture "OrderId" OrderId :> Delete '[JSON] ()
  }

--
-- NOTE: This type-signature WILL NOT compile...
--
server :: Routes (AsServerT m)
server = Routes
  { rFetchOrder = \userId orderId -> runForUser fetchOrderPerms userId $ fetchOrderById orderId
  , rDeleteOrder = \userId orderId -> runForUser deleteOrderPerms userId $ deleteOrderById orderId
  }

fetchOrderPerms :: Proxy '[ 'PermissionFetchOrder]
fetchOrderPerms = Proxy

deleteOrderPerms :: Proxy '[ 'PermissionDeleteOrder]
deleteOrderPerms = Proxy

现在，runForUser函数就是“一对”monads出现的地方。我希望runForUser有以下类型的sig，其中它将“内部monad”n转换为外部monad m，而不将它们中的任何一个具体化：

runForUser :: UserId -> n a -> m a

这种“类型类魔法”需要尽可能长的时间不要承诺一个具体的单块，希望这将允许我编写测试。

当最终连接到生产应用程序时，下面是runForUid将转换的内容：

AppM '[PermissionFetchOrder] a -> ServantM a

AppM '[PermissionDeleteOrder] a -> ServantM a

-- and so on...

当连线进行测试时：

TestM '[PermissionFetchOrder] a -> TestServantM a

TestM '[PermissionDeleteOrder] a -> TestServantM a

-- and so on...

我很难为runForUid函数编写一个类型类。我尝试过各种技术，我得到的最接近的方法是：

-- 
-- This compiles...
--
class (HasDatabase (InnerMonad m), HasSmtp (InnerMonad m)) => RunForUser m where
  type InnerMonad m :: * -> *

  runForUser :: Proxy (p :: [Permission]) ->  UserId -> (InnerMonad m) a -> m a


--
-- Even this compiles...
--
server :: (RunForUser m) => Routes (ServerT m)
server = Route
  { rFetchOrder = \uid orderId -> runForUser fetchOrderPerms userId $ fetchOrderById orderId
  , rDeleteOrder = ...
  }

-- 
-- And this is where it gets stuck, because the compiler 
-- doesn't know how to deal with `perms` as it is not in 
-- scope
--
instance (HasDatabase (AppM perms), HasSmtp (AppM perms)) => RunForUser ServantM where
  type InnerMonad ServantM = AppM (perms :: [Permission])

  runForUser permProxy userId action = ...

如果我前面提到的解决方案是正确的，那么我的问题是--我如何告诉编译器不要担心perms？这是实现runForUser的一项工作。我可以以任何方式使用RankNTypes并在某个地方安装一个forall perms并使其正常工作吗？

另一方面，如果上面给出的方法是完全垃圾，那么有什么更好的方法来完成这个任务呢？

编辑

我可能已经找到了一个可以接受的解决方案，但我仍然在寻找一种更好的方法来避免与类型相关的样板。

{-# LANGUAGE DataKinds, RankNTypes, PartialSignature, ScopedTypeVariables -#}

type HasApp m = (HasDatabase m, HasSmtp m)

class HasServant ...

class (HasApp m, HasServant n) => RunForUser m n where
  runForUser :: Proxy (perms :: [Permission]) -> UserId -> m a -> n a

server :: forall m n . (RunForUser m n, HasApp m) => Routes (AsServerT n)
server = Routes
  { rFetchOrder = \userId orderId -> 
      runForUser fetchOrderPerms userId 
        --
        -- NOTE: Had to manually annotate the type `m a` and had
        -- to use PartialTypeSignatures to avoid having to specify
        -- the type `a` again.
        --
        (fetchOrderById orderId :: m _)
  , ...
  }

Answer 1

虽然我的全部代码库尚未编译，但我可能有一个使用RankNTypes的可能答案。

type HasApp m = (HasDatabase m, HasSmtp m)

type UserRunner m n = (forall perms a . Proxy (perms :: [Permission]) -> UserId -> (HasApp (m perms) => m perms a) -> n a)

server :: UserRunner m n -> Routes (AsServerT n)
server runForUid = Routes
  { rFetchOrder = \uid orderId -> runForUid fetchOrderPerms uid $ fetchOrderById orderId
  , rDeleteOrder = \uid orderId -> runForUid deleteOrderPerms uid $ deleteOrderById orderId
  }