Request, Response pattern within Haskell

Question

I'm trying to figure out a good way to implement a request response pattern, where a monad can request the monad runner to perform an action and return a value back to the monad.

The reason I want to do this is because I have a bunch of tasks to perform where some of the work is IO based and some is CPU based. I want a bunch of cpu threads to do the cpu work, hand off io tasks to another thread designated to do disk work, and be then free to work on other CPU tasks while the disk thread finds a value for them. A task might be something like:

do some cpu work 
request load a value from disk
do some more cpu work  
request another value from disk
... etc ..

I created the following as a simple way to do this, where ReqRes, below, represent the disk based tasks. However, in testIO, it has a waterfall look to it where the code marches off to the right, every time it makes a new request, due to nested functions.

I was wondering if there is a cleaner way to do it, that doesn't require this nested function structure.

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

I created a monad transformer specifically to do this. Unless someone can show me that it's easily done another way, and is just clutter, I'll probably create a haskell package for this.

{-# 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 ())))))