haskell - 努力在仆人中连接一对类型类约束单子
问题描述
请向下滚动以阅读对此问题的重要编辑
原始(冗长)问题
我的网络应用程序的代码是用类型类约束的 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
函数是“一对”单子的来源。我想要runForUser
以下类型-sig,它将“内部单子”n
转换为外部单子,m
而不会使它们中的任何一个具体化:
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 _)
, ...
}
解决方案
尽管我的整个代码库尚未编译,但我可能有一个可能的答案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
}
推荐阅读
- python - pip freeze 不显示包版本
- python - 如何在 Kivy 中删除动态添加的 BoxLayout
- android-fragments - 如何在 TabLayout 中找到由 RecyclerView 打开的对话框的上下文?
- avro - Avro 文件从 Snowflake 表加载和读取
- javascript - 在Vue js中将复选框选择的值分组到数组中
- dart - 如何检查飞镖中的两个地图是否相等
- javascript - 将对象插入数组遇到访问问题(Nodejs)
- c++ - 在 Visual Studio 中使用括号但传入 g++/clang++ 时编译错误
- c++ - 错误:#include 在 Dev C++ 中嵌套太深
- google-sheets - 使用 SUMIFS 对一组产品求和