Haskell でシグナルで中断された時にクリーンナップ処理をしてから終了する

最近 Programming in Haskell という本を読んでいるのですが 9.7 Game of Life（ターミナルに Game of Life をアニメーション表示）を動かしてみたらカーソルが邪魔だったので、プログラムの開始時にカーソルを消して終了時にまた表示するようにしようとしました。

import System.Process (system)

main :: IO ()
main = do
  -- カーソルを隠す
  system "tput civis"
  -- Game of Life を画面に表示
  life glider
  -- カーソルを表示（ここに到達しない！！！）
  system "tput cvvis"
  return ()

life :: Board -> IO ()
glider :: Board

しかし life が無限ループで Game of Life を表示するため、カーソルを表示するところまで到達しません。Ctrl+C で中断するとカーソルが隠れたままになってしまいます。

unix - Killing a Haskell binary - Stack Overflow を参考にして、シグナルで中断されるまで a -> IO a な処理をループさせる関数を書いてみました。MVar で中断されたかどうかを管理し、中断されていた場合はループを止めます。

import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, tryTakeMVar)
import System.Posix.Signals (Handler, Handler(CatchOnce), installHandler, sigINT, sigTERM)

loopUntilInterruption :: (a -> IO a) -> a -> IO ()
loopUntilInterruption p init = do
  v <- newEmptyMVar
  installHandler sigINT (handler v) Nothing
  installHandler sigTERM (handler v) Nothing
  loop v p init

handler :: MVar () -> Handler
handler v = CatchOnce $ putMVar v ()

loop :: MVar () -> (a -> IO a) -> a -> IO ()
loop v p prev = do
  x <- p prev
  val <- tryTakeMVar v
  case val of
    Just _ -> return ()
    Nothing -> loop v p x >> return ()

Game of Life の例では life の型を変えて前回の結果を返すようにして、loopUntilInterruption でループさせました。今度はシグナルで中断しても終了処理が呼ばれます。

import System.Process (system)

main :: IO ()
main = do
  -- カーソルを隠す
  system "tput civis"
  -- 中断されるまでループ
  loopUntilInterruption life glider
  -- カーソルを表示（今度は呼ばれる！！！）
  system "tput cvvis"
  return ()

life :: Board -> IO Board
glider :: Board

めでたし、めでたし。

ちなみに Programming in Haskell は edX の Introduction to Functinal Programming で Erik Meijer がおすすめしていたので読んでいます。約 150 ページと薄いのに内容が凝縮されていていい感じです。Monad などについてもごちゃごちゃ言わないので、個人的にはすごい Haskell たのしく学ぼう！よりもわかりやすいと思いました。日本語版の方が安いのでさらにおすすめです。