Haskell 内的请求、响应模式

Question

我正在尝试找到一种实现请求响应模式的好方法，其中 monad 可以请求 monad runner 执行操作，然后 return 将值返回给 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 ()

Answer 1

我专门为此创建了一个 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 ())))))

Haskell 内的请求、响应模式

Request, Response pattern within Haskell

haskell

monads

request-response