gtk2hs: double buffering and timer

test.hs

import Graphics.UI.Gtk 
import Graphics.Rendering.Cairo
import Control.Applicative
import Control.Monad.Trans 

import System.Random
import Data.IORef
import Data.Sequence
import Data.Foldable

import Prelude hiding (mapM_, length)

rollDice :: IO (Double,Double) 
rollDice = do 
  x <- return . fromIntegral =<< getStdRandom (randomR (0,400 :: Int)) 
  y <- return . fromIntegral =<< getStdRandom (randomR (0,400 :: Int))
  return (x,y)

main :: IO () 
main = do 
  putStrLn "test"
  initGUI
  (xref,yref) <- (,) <$> newIORef 100 <*> newIORef 100
  currentstatusref <- newIORef (Data.Sequence.empty :: Seq (Double,Double))
  window <- windowNew 
  button <- buttonNewWithLabel "test"
  vbox <- vBoxNew False 0 
  canvas <- drawingAreaNew 
  set canvas [ widgetWidthRequest := 400 
             , widgetHeightRequest := 400 ] 
  boxPackStart vbox canvas PackNatural 0 
  boxPackStart vbox button PackGrow 0 
  containerAdd window vbox 
  mysurface <- createImageSurface FormatARGB32 400 400 
  let drawOneLineMore = do 
        (x0,y0) <- (,) <$> readIORef xref <*> readIORef yref 
        (x1,y1) <- rollDice
        writeIORef xref x1
        writeIORef yref y1
        modifyIORef currentstatusref (\z -> z |> (x1,y1))
        cseq <- readIORef currentstatusref 
        putStrLn $ show (length cseq)
        win <- widgetGetDrawWindow canvas 
        withSimilarSurface mysurface ContentColorAlpha 400 400 $ \new_surface -> do 
          renderWith new_surface $ do 
            setLineCap  LineCapRound
            setLineJoin LineJoinRound
            setSourceRGBA 1 1 1 1 
            rectangle 0 0 400 400 
            fill 
            setSourceRGBA 0 0 0 0.5
            setLineWidth 1 
            moveTo 100 100 
            mapM_ (\(x,y) -> lineTo x y) cseq
            stroke
          renderWithDrawable win $ do    
            setSourceSurface new_surface 0 0 
            setOperator OperatorSource 
            paint 
  button `on` buttonActivated $ do 
    liftIO $ putStrLn "button press" 
    liftIO $ timeoutAdd (drawOneLineMore >> return True) 50 
    return ()
  window `on` deleteEvent $ tryEvent $ do 
    liftIO $ mainQuit 
  widgetShowAll window
  mainGUI