読者です 読者をやめる 読者になる 読者になる

きくらげ観察日記

好きなことを、適当に。

モナドで擬似マルチタスク

Haskell

継続のことばかり考えていたらなんとなく思いついてしまったので載せておきます。

{-# LANGUAGE GADTs #-}

module Concurrent where

import Control.Monad
import Control.Monad.IO.Class
import Data.Either

data ConT m b where
  Done :: m b -> ConT m b
  Bind :: ConT m a -> (a -> ConT m b) -> ConT m b
  Fork :: Int -> ConT m Int

isDone :: ConT m a -> Bool
isDone (Done _) = True
isDone _ = False

instance Monad m => Monad (ConT m) where
  return = Done . return
  (>>=) = Bind

runConTs :: Monad m => [ConT m a] -> m [a]
runConTs cons
  | all isDone cons = mapM (\(Done x) -> x) cons
  | otherwise = do
      cons' <- foldM step [] cons
      runConTs cons'
  where
    step cons con = do
      cons' <- stepConT con
      return $ cons' ++ cons

runConT :: Monad m => ConT m a -> m [a]
runConT con = runConTs [con]

runConT_ :: Monad m => ConT m a -> m ()
runConT_ con = runConTs_ [con]

runConTs_ :: Monad m => [ConT m a] -> m ()
runConTs_ cons = runConTs cons >> return ()

stepConT :: Monad m => ConT m a -> m [ConT m a]
stepConT (Done res) = do
  r <- res
  return [Done (return r)]
stepConT (Bind (Done res) cont) = do
  r <- res
  return [cont r]
stepConT (Bind ma cont) = do
  mas <- stepConT ma
  return $ map (\ma' -> Bind ma' cont) mas
stepConT (Fork num) = return [Done (return i) | i <- [0..num-1]]

instance MonadIO m => MonadIO (ConT m) where
  liftIO = Done . liftIO

-- (擬似)プロセスをn個に分ける
-- 戻り地は自分が何番目のプロセスか
fork :: Int -> ConT m Int
fork = Fork

a >>= bがそのままBind a bというデータ構造になっているため、doブロック内の命令1行ごとに処理を停止することができるようになっています。
Forkは本来は特に必要ないのですが、なんとなくfork()的なことがしたかったので入れてみました。

以下実行例。

count :: MonadIO m => String -> Int -> ConT m ()
count name times = forM_ [0..times-1] $ \i -> do
  liftIO $ putStrLn $ name ++ ": " ++ show i

forkExample :: MonadIO m => ConT m ()
forkExample = do
  pid <- fork 5
  case pid of
    0 -> do
      liftIO $ putStrLn "I am zero!"
      count "zero" 3
    _ -> do
      liftIO $ putStrLn $ "I am process " ++ show pid ++ "!"
      count ("process" ++ show pid) 3

実行結果:

>>> runConT forkExample 
I am process 4!
I am process 3!
I am process 2!
I am process 1!
I am zero!
zero: 0
process1: 0
process2: 0
process3: 0
process4: 0
process4: 1
process3: 1
process2: 1
process1: 1
zero: 1
zero: 2
process1: 2
process2: 2
process3: 2
process4: 2
[(),(),(),(),()]

まず最初にfork 5でzeroとprocess1〜4の5つに分かれ、それぞれが平行して0〜2までのカウントを行っています。