haskellで非同期IO処理（Parallel and Concurrent Programming in Haskellの11章中盤）

勉強会の復習としてParallel and Concurrent Programming in Haskellの11章をまとめてみる（中盤の辺りについて）
前半についてはこちらに書いた
http://jsapachehtml.hatenablog.com/entry/2014/04/03/233101

11章初めの部分でwithAsyncという関数を作った。これによって片方のasyncが例外を投げた際でもリソースの後片付けができるようになった。
しかし、もし２つ目のasyncが例外を投げたとしたら１つ目のasyncは最後まで動作した上でストップする。どちらかが例外を投げたらすぐに全体がストップするようにしたい。
waitBothでそれが実現できる

waitBoth :: Async a -> Async b -> IO (a,b)
waitBoth a1 a2 =
  atomically $ do
    r1 <- waitSTM a1 `orElse` (do waitSTM a2; retry) 
    r2 <- waitSTM a2
    return (r1,r2)

r1を取得している部分が複雑だが、まずa1を実行してまだ処理が完了していなければa2を実行。ここでのa2の実行は例外をチェックするためだけに置かれている。必ずretryされるのでa1の処理が完了するまで次の行の処理にはいかない。a1,a2のどちらかで例外が発生すればそこで処理はストップする。
（中で使われている関数についてはページ下部にまとめた）

このwaitBothを使うことでconcurrentlyを定義し、前のトピックの終わりに出てきたgeturls.hsを綺麗に書ける

main =
  withAsync (getURL "http://www.wikipedia.org/wiki/Shovel") $ \a1 ->
  withAsync (getURL "http://www.wikipedia.org/wiki/Spade")  $ \a2 -> do
  r1 <- wait a1
  r2 <- wait a2
  print (B.length r1, B.length r2)

↑これが以下のように書ける
concurrently :: IO a -> IO b -> IO (a,b)
concurrently ioa iob = 
  withAsync ioa $ \a ->
  withAsync iob $ \b ->
    waitBoth a b

main = do
  (r1,r2) <- concurrently
               (getURL "http://www.wikipedia.org/wiki/Shovel")
               (getURL "http://www.wikipedia.org/wiki/Spade")
  print (B.length r1, B.length r2)

▼waitBothにて使われている関数について
waitSTMなどは10章で定義されている関数で定義は以下。Asyncの定義など関係するもの一緒に載っけておく。

waitSTM :: Async a -> STM a
waitSTM a = do
  r <- waitCatchSTM a
  case r of
    Left e  -> throwSTM e
    Right a -> return a

waitCatchSTM :: Async a -> STM (Either SomeException a)
waitCatchSTM (Async _ var) = readTMVar var

data Async a = Async ThreadId (TMVar (Either SomeException a))

readTMVar :: TMVar a -> STM a
readTMVar (TMVar t) = do
  m <- readTVar t
  case m of
    Nothing -> retry
    Just a  -> return a

よってwaitSTMは渡した非同期アクションを実行し、結果がまだなければretry、結果があればそれを返す。例外が発生した場合はthrowSTMで処理を止めて例外を伝播させる。

orElseも10章で説明されており、以下の型をもつ
以下の型をもつ