2

我试图找出一种实现请求响应模式的好方法，其中 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 ()
4

1 回答 1

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 ())))))
于 2018-07-30T11:11:42.063 回答