Запрос, шаблон ответа в Haskell

Question

Я пытаюсь найти хороший способ реализовать шаблон ответа на запрос, где монада может запросить бегуна монады выполнить действие и вернуть значение обратно в монаду.

Причина, по которой я хочу это сделать, заключается в том, что у меня есть куча задач, в которых часть работы выполняется на основе ввода-вывода, а часть - на основе процессора. Я хочу, чтобы куча потоков процессора выполняла работу процессора, передавала задачи io другому потоку, предназначенному для работы с диском, а затем была свободна для работы с другими задачами ЦП, пока поток диска находит для них значение. Задача может быть что-то вроде:

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

Я создал монадный трансформатор специально для этого. Если кто-то не покажет мне, что это легко сделать по-другому, и это просто беспорядок, я, вероятно, создам для этого пакет на 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 ())))))