Shuhei Kagawa

Clean up before exiting in Haskell

Apr 6, 2016 - Haskell

Once upon a time (or a several days ago), I was reading Programming in Haskell. When I ran 9.7's Game of Life, which shows Game of Life animation on the terminal, the terminal's cursor was flickering and annoying. So I tried to hide it when starting and show when exiting.

import System.Process (system)

main :: IO ()
main = do
  -- Hide the cursor
  system "tput civis"
  -- Show the Game of Life
  life glider
  -- Show the cursor (but the code does not reach here!)
  system "tput cvvis"
  return ()

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

But the code does not reach the line that shows the cursor because life is a infinite loop. If I quit the program with Ctrl+C, the cursor remains hidden.

So I wrote a function that loops a -> IO a until interrupted by a signal, referring to unix - Killing a Haskell binary - Stack Overflow. It manages a state of whether the program was interrupted in a MVar and stops the loop when interrupted.

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

In the Game of Life, I changed the type of life so that it returns the result of its previous result and loop with loop. Now the clean up code will be called when interrupted by a signal.

import System.Process (system)

main :: IO ()
main = do
  -- Hide the cursor
  system "tput civis"
  -- Loop until interrupted
  loopUntilInterruption life glider
  -- Show the cursor (the code will reach here now!)
  system "tput cvvis"
  return ()

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

And they lived happily ever after.