努力在仆人中连接一对类型类约束单子

Question

请向下滚动阅读对此问题的重要修改

原始（冗长）问题

我的网络应用程序的代码是用类型类约束的 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 函数是“一对” monad 的来源。我希望 runForUser 具有以下类型信号，它将“内部 monad”n 转换为外部 monad @ 987654327@ 没有具体化：

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

这种“类型类魔法”要求尽可能长时间地不提交具体的 monad，希望这能让我编写测试。

当最终为生产应用程序连接时，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
  }