我正在尝试找到一种实现请求响应模式的好方法，其中monad可以请求monad运行器执行操作并将值返回给monad。
之所以要这样做，是因为我要执行许多任务，其中一些工作是基于IO的，而有些则是基于CPU的。我希望一堆cpu线程来执行cpu工作，将io任务交给另一个指定用于执行磁盘工作的线程，然后在磁盘线程为它们找到值的同时自由地执行其他CPU任务。任务可能类似于：
do some cpu work
request load a value from disk
do some more cpu work
request another value from disk
... etc ..
我创建了以下内容作为执行此操作的简单方法，其中下面的ReqRes代表基于磁盘的任务。但是，由于嵌套函数，在testIO中，每次发出新请求时，它都会向瀑布右移，从而使代码向右倾斜。
我想知道是否有一种更清洁的方法，不需要这种嵌套的函数结构。
module ReqResPattern where
import Control.Monad.IO.Class (MonadIO(..))
data ReqRes m = RR1 String (String -> m (ReqRes m)) | RR2 Int (Int -> m (ReqRes m)) | Fin
testIO :: MonadIO m => m (ReqRes m)
testIO =
do
return $ RR1 "fred"
(\x ->
do
liftIO $ putStrLn $ "str: " ++ x
return $ RR2 1
(\y ->
do
liftIO $ putStrLn $ "int: " ++ (show y)
return $ Fin
)
)
runTestIO :: IO ()
runTestIO =
doit testIO
where
doit :: IO (ReqRes IO) -> IO ()
doit m =
do
v <- m
case v of
RR1 v f -> doit $ f (v ++ " foo")
RR2 v f -> doit $ f (v+1)
Fin -> return ()
return ()
答案 0 :(得分：0)
我专门创建了一个monad变压器。除非有人能告诉我它很容易以另一种方式完成并且很混乱，否则我可能会为此创建一个haskell程序包。
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module ReqResPattern where
import Control.Monad.IO.Class (MonadIO(..))
import Data.Fix (Fix(..))
import Control.Monad.Fix
import Debug.Trace(trace)
-- | This is a monad transformer that contains a simple category that tells what
-- type of operation it is. Then when run, the monad will stop everytime the category
-- changes. A specific example of use would be if you wanted to run some code within
-- a thread pool for cpu tasks, another for disk tasks, and a final thread pool for
-- network tasks.
--
-- You could then easily designate which work to do in which thread
-- by using "switchCat" and then feeding the monad to the appropriate thread pool using
-- an MVar or something.
data CatT catType m a = CatT { runCatT :: (m (Either (CatT catType m a) a)),
cat :: Maybe catType
-- ^ This is the category that the monad starts in.
-- It may switch categories at any time by returning
-- a new CatT.
}
instance Functor m => Functor (CatT cat m) where
fmap f (CatT a cat) = CatT (fmap (cattfmap f) a) cat
cattfmap :: Functor m => (a -> b) -> (Either (CatT cat m a) a) -> (Either (CatT cat m b) b)
cattfmap f (Left ct) = Left $ fmap f ct
cattfmap f (Right a) = Right $ f a
instance Monad m => Applicative (CatT cat m) where
pure x = CatT (pure (Right x)) Nothing
(<*>) = cattapp
cattapp :: forall m a b cat . Monad m => CatT cat m (a -> b) -> CatT cat m a -> CatT cat m b
cattapp cmf@(CatT mf cat1) cma@(CatT ma cat2) = CatT (ma >>= mappedMf mf) cat2
--the type is cat2 because this is the type the resulting structure will start with
where
mappedMf :: m (Either (CatT cat m (a -> b)) (a -> b)) -> Either (CatT cat m a) a -> m (Either (CatT cat m b) b)
mappedMf mf ea = fmap (doit ea) mf
doit :: Either (CatT cat m a) a -> Either (CatT cat m (a -> b)) (a -> b) -> (Either (CatT cat m b) b)
doit (Left ca) (Left cf) = Left $ cf <*> ca
doit (Right a) (Left cf) = Left $ cf <*> (pure a)
doit (Left ca) (Right f) = Left $ (pure f) <*> ca
doit (Right a) (Right f) = Right $ f a
instance (Eq cat, Monad m) => Monad (CatT cat m) where
(>>=) = cattglue
cattglue :: forall m a b cat . (Monad m, Eq cat) => (CatT cat m a) -> (a -> (CatT cat m b)) -> (CatT cat m b)
cattglue (CatT ma cat1) cfmb = CatT (doit ma cfmb) cat1
where
doit :: m (Either (CatT cat m a) a) -> (a -> (CatT cat m b)) -> m (Either (CatT cat m b) b)
doit ma famb = ma >>= (flip doit2 famb)
doit2 :: (Either (CatT cat m a) a) -> (a -> (CatT cat m b)) -> m (Either (CatT cat m b) b)
--if we are already calling another cat, we just glue that one and use it as the inner cat
doit2 (Left ca) f = return $ Left $ (ca >>= f)
--otherwise we are returning an object directly
doit2 (Right a) f =
--in this case we have a value, so we pass it to the function to extract
--the next cat, then run them until we get a cat with a conflicting category
runCatsUntilIncompatible cat1 (f a)
runCatsUntilIncompatible :: Maybe cat -> CatT cat m b -> m (Either (CatT cat m b) b)
runCatsUntilIncompatible cat1 cm2 =
case (cat1, (cat cm2)) of
(Nothing, Nothing) -> runCatT cm2
(Nothing, Just _) -> return $ Left cm2
(Just a, Just b) | a == b -> runCatT cm2
(Just _, Nothing) -> (runCatT cm2) >>=
(\cm2v ->
case cm2v of
(Right v) -> return (Right v)
(Left cm3) -> runCatsUntilIncompatible cat1 cm3
)
_ -> return $ Left cm2
isCompatibleCats :: Eq ct => (Maybe ct) -> (Maybe ct) -> Bool
isCompatibleCats Nothing _ = False
isCompatibleCats _ Nothing = True
isCompatibleCats (Just a) (Just b) = a == b
switchCat :: (Eq cat, Monad m) => cat -> CatT cat m ()
switchCat c = CatT (return $ Right ()) $ Just c
instance (Eq cat, MonadIO m) => MonadIO (CatT cat m) where
liftIO io = CatT (fmap Right $ liftIO io) Nothing
data MyCat = DiskCat | CPUCat
deriving (Eq, Show)
type IOCat cat a = CatT cat IO a
test1 :: IOCat MyCat Int
test1 = do
liftIO $ putStrLn "A simple cat"
return 1
test2 :: IOCat MyCat ()
test2 = do
switchCat CPUCat
liftIO $ putStrLn "CPU Cat 1"
switchCat CPUCat
liftIO $ putStrLn "CPU Cat 2"
return ()
test2' :: IOCat MyCat ()
test2' =
switchCat CPUCat >>
(liftIO $ putStrLn "CPU Cat 1") >>
switchCat CPUCat >>
(liftIO $ putStrLn "CPU Cat 2") >>
return ()
test2'' :: IOCat MyCat ()
test2'' =
switchCat CPUCat >>
((liftIO $ putStrLn "CPU Cat 1") >>
(switchCat CPUCat >>
((liftIO $ putStrLn "CPU Cat 2") >>
return ())))
test3 :: IOCat MyCat ()
test3 = do
switchCat CPUCat
liftIO $ putStrLn "CPU Cat 1"
switchCat DiskCat
liftIO $ putStrLn "Disk Cat 2"
switchCat CPUCat
liftIO $ putStrLn "CPU Cat 3"
return ()
test3' :: IOCat MyCat ()
test3' =
switchCat CPUCat >>
(liftIO $ putStrLn "CPU Cat 1") >>
switchCat DiskCat >>
(liftIO $ putStrLn "Disk Cat 2") >>
switchCat CPUCat >>
(liftIO $ putStrLn "CPU Cat 3") >>
return ()
test3'' :: IOCat MyCat ()
test3'' =
switchCat CPUCat >>
((liftIO $ putStrLn "CPU Cat 1") >>
(switchCat DiskCat >>
((liftIO $ putStrLn "Disk Cat 2") >>
(switchCat CPUCat >>
((liftIO $ putStrLn "CPU Cat 3") >>
return ())))))