Ticket #1191: window-tick

--- a/Graphics/SOE/Gtk.chs
+++ b/Graphics/SOE/Gtk.chs
@@ -80,6 +80,7 @@
   maybeGetWindowEvent,
   getWindowEvent,
   Word32,
+  getWindowTick,
   timeGetTime,
   word32ToInt
   ) where
@@ -139,15 +140,17 @@
   window :: Gtk.Window,
   canvas :: Gtk.DrawingArea,
   graphicVar :: MVar Graphic,
-  eventsChan :: Chan Event
+  eventsChan :: Chan Event,
+  tickChan :: Chan Tick
 }
 
 openWindow :: Title -> Size -> IO Window
 openWindow title size =
-  openWindowEx title Nothing (Just size) drawBufferedGraphic
+  openWindowEx title Nothing (Just size) drawBufferedGraphic Nothing
 
-openWindowEx :: Title -> Maybe Point -> Maybe Size -> RedrawMode -> IO Window
-openWindowEx title position size (RedrawMode useDoubleBuffer) =
+openWindowEx :: Title -> Maybe Point -> Maybe Size -> RedrawMode ->
+                Maybe Time -> IO Window
+openWindowEx title position size (RedrawMode useDoubleBuffer) tick =
   Gtk.postGUISync $ do
   window <- Gtk.windowNew
   Gtk.windowSetTitle window title
@@ -170,6 +173,8 @@
   graphicVar <- newMVar emptyGraphic
   eventsChan <- newChan
 
+  tickChan <- newChan
+
   -- set up the fonts
 #ifdef USE_CAIRO
   pc <- Gtk.Cairo.cairoCreateContext Nothing
@@ -214,10 +219,24 @@
 #endif
     return True
 
-  Gtk.onDelete window $ \_ -> do writeChan eventsChan Closed
-                                 Gtk.widgetHide window
-                                 return True
-                     
+  case tick of
+    Just t  -> do
+         timer <- Gtk.timeoutAddFull
+                    (writeChan tickChan () >> return True)
+                    Gtk.priorityDefaultIdle t
+         Gtk.onDelete window $ \_ -> do
+                    writeChan eventsChan Closed
+                    Gtk.timeoutRemove timer
+                    Gtk.widgetHide window
+                    return True
+         return ()
+    Nothing -> do
+        Gtk.onDelete window $ \_ -> do
+                    writeChan eventsChan Closed
+                    Gtk.widgetHide window
+                    return True
+        return ()
+
   Gtk.onMotionNotify canvas True $ \Events.Motion { Events.eventX=x, Events.eventY=y} ->
     writeChan eventsChan MouseMove {
       pt = (round x, round y)
@@ -250,7 +269,8 @@
     window  = window,
     canvas  = canvas,
     graphicVar = graphicVar,
-    eventsChan = eventsChan
+    eventsChan = eventsChan,
+    tickChan = tickChan
   }
 
 getWindowSize :: Window -> IO Size
@@ -767,6 +787,22 @@
 getRBP :: Window -> IO Point
 getRBP w = getButton w 2 True
 
+---------------------------------
+-- Window Tick Handling Functions
+---------------------------------
+
+type Time = Int
+
+type Tick = ()
+
+-- We make sure we completely clear the channel when getting a window tick,
+-- so that if we have been delayed, we don't keep running to catch up with
+-- ourselves
+getWindowTick :: Window -> IO ()
+getWindowTick w = do readChan (tickChan w)
+                     noTicks <- isEmptyChan (tickChan w)
+                     if not noTicks then getWindowTick w else return ()
+
 timeGetTime :: IO Word32
 timeGetTime = do
   System.Time.TOD sec psec <- System.Time.getClockTime