使用具有并发MVar的管道/代理

时间:2013-02-06 14:44:21

标签: haskell

Control.Proxy包的pipes-3.1.0教程中,作者提供了此功能:

cache :: (Proxy p, Ord key) => key -> p key val key val IO r
cache = runIdentityK (loop M.empty) where
    loop _map key = case M.lookup key _map of
        Nothing -> do
            val  <- request key
            key2 <- respond val
            loop (M.insert key val _map) key2
        Just val -> do
            lift $ putStrLn "Used cache!"
            key2 <- respond val
            loop _map key2

因为我想要并发应用程序缓存请求,所以我有以下数据类型

newtype Cache k v = Cache (MVar (M.Map k v))

现在我想要一个带有签名

的新cache函数
cache :: (Proxy p, Ord k) => Cache k v -> k -> p k v k v IO r
cache (Cache c) k = readMVar c >>= \m -> runIdentityK $ loop m k
    where loop m key = case M.lookup key m of
            Nothing -> do
                val <- request key
                respond val >>= loop (M.insert key val m)
            Just val -> respond val >>= loop m

但是,由于readMVar位于IO monad中,而runIdentityK位于Proxy p => p k v k v IO r monad中,因此无法进行类型检查。当然,我可以将readMVar提升到这个代理monad中,因为它是IO上的变换器,但我找不到合适的组合器。

2 个答案:

答案 0 :(得分:5)

解决方案很简单lift。我曾经想过要用它,但显然没有用力。这是我想要的cache

的粗略的类型检查版本
cache = runIdentityK . loop
    where loop (Cache c) key = lift (takeMVar c) >>= \m -> case M.lookup key m of
            Nothing -> do
                val <- request key
                lift . putMVar c $ M.insert key val m
                respond val >>= loop (Cache c)
            Just val -> do
               lift $ putMVar c m 
               respond val >>= loop (Cache c)

答案 1 :(得分:3)

就像添加lift一样简单。但是,您的实现似乎没有按照您的意图执行。您只在开始时阅读MVar一次,然后再也不会再使用它,只需在循环中传递更新后的地图即可。如果不同的线程应该通过MVar看到更改,您还必须更新它。一个建议(编译,但我没有测试它是如何工作的):

cache :: (Proxy p, Ord k) => Cache k v -> k -> p k v k v IO r
cache (Cache c) k = runIdentityK loop k
    where 
      loop key = do
        m <- lift (readMVar c)
        case M.lookup key m of
            Nothing -> do
                val <- request key
                lift $ modifyMVar_ c (return . M.insert key val)
                respond val >>= loop
            Just val -> respond val >>= loop