Show messages in the UI as they're received.

Outstanding issues:

• There are no timestamps;
• You can't interact with it while it's logging; it just scrolls past
  wildly;
• I'm sure it's really inefficient.

3 files changed, 49 insertions, 5 deletions

diff --git a/Bustle/UI.hs b/Bustle/UI.hs
index 538f0a8..b311a7d 100644
--- a/Bustle/UI.hs
+++ b/Bustle/UI.hs
@@ -223,9 +223,16 @@ startRecording = do
     let filename = cacheDir </> yyyy_mm_dd_hh_mm_ss <.> "bustle"
 
     io $ setPage wi CanvasPage
-    embedIO $ \r -> recorderRun filename (Just (wiWindow wi)) $
+    embedIO $ \r -> recorderRun filename (Just (wiWindow wi)) (aChallengerAppears wi) $
           makeCallback (finishedRecording wi filename) r
 
+aChallengerAppears :: WindowInfo
+                   -> RendererResult a
+                   -> IO ()
+aChallengerAppears wi rr = do
+    updateDisplayedLog wi rr
+    canvasScrollToBottom (wiCanvas wi)
+
 finishedRecording :: WindowInfo
                   -> FilePath
                   -> B ()
diff --git a/Bustle/UI/Canvas.hs b/Bustle/UI/Canvas.hs
index 08d1f07..51895b2 100644
--- a/Bustle/UI/Canvas.hs
+++ b/Bustle/UI/Canvas.hs
@@ -7,6 +7,7 @@ module Bustle.UI.Canvas
   , canvasSetShapes
 
   , canvasFocus
+  , canvasScrollToBottom
   )
 where
 
@@ -119,6 +120,21 @@ setupCanvas canvas = do
 
     return ()
 
+canvasInvalidateArea :: Canvas a
+                     -> Int
+                     -> Int
+                     -> Int
+                     -> Int
+                     -> IO ()
+canvasInvalidateArea canvas x1 y1 x2 y2 = do
+    let layout = canvasLayout canvas
+    realized <- widgetGetRealized layout
+
+    when realized $ do
+        win <- layoutGetDrawWindow layout
+        let pangoRectangle = Rectangle x1 y1 x2 y2
+        drawWindowInvalidateRect win pangoRectangle False
+
 canvasInvalidateStripe :: Canvas a
                        -> Stripe
                        -> IO ()
@@ -207,6 +223,7 @@ canvasSetShapes canvas shapes regions centreOffset windowWidth = do
             Nothing     -> rs'
 
     layoutSetSize layout (floor width) (floor height)
+    canvasInvalidateArea canvas 0 0 (floor width) (floor height)
 
     -- FIXME: only do this the first time maybe?
     -- Shift to make the timestamp column visible
@@ -251,3 +268,11 @@ canvasFocus :: Canvas a
             -> IO ()
 canvasFocus canvas = do
     (canvasLayout canvas) `set` [ widgetIsFocus := True ]
+
+canvasScrollToBottom :: Canvas a
+                     -> IO ()
+canvasScrollToBottom canvas = do
+    vadj <- layoutGetVAdjustment (canvasLayout canvas)
+    page <- adjustmentGetPageSize vadj
+    lim <- adjustmentGetUpper vadj
+    adjustmentSetValue vadj (max 0 (lim - page))
diff --git a/Bustle/UI/Recorder.hs b/Bustle/UI/Recorder.hs
index d86dac4..161ca88 100644
--- a/Bustle/UI/Recorder.hs
+++ b/Bustle/UI/Recorder.hs
@@ -9,6 +9,7 @@ import Control.Monad (when)
 import Control.Concurrent.MVar
 import qualified Data.Map as Map
 import Data.Map (Map)
+import Data.Monoid
 import Control.Monad.State (runStateT)
 
 import System.Glib.GError
@@ -22,13 +23,16 @@ import Bustle.Types
 import Bustle.UI.Util (displayError)
 import Bustle.Util
 
-type RecorderCallback = IO ()
+type RecorderIncomingCallback = RendererResult Participants
+                             -> IO ()
+type RecorderFinishedCallback = IO ()
 
 recorderRun :: FilePath
             -> Maybe Window
-            -> RecorderCallback
+            -> RecorderIncomingCallback
+            -> RecorderFinishedCallback
             -> IO ()
-recorderRun filename mwindow callback = handleGError newFailed $ do
+recorderRun filename mwindow incoming finished = handleGError newFailed $ do
     monitor <- monitorNew BusTypeSession filename NoDebugOutput
     dialog <- dialogNew
 
@@ -40,6 +44,9 @@ recorderRun filename mwindow callback = handleGError newFailed $ do
     n <- newMVar (0 :: Integer)
     loaderStateRef <- newMVar Map.empty
     rendererStateRef <- newMVar rendererStateNew
+    -- FIXME: this is stupid. If we have to manually combine the outputs, it's
+    -- basically just more state.
+    rendererResultRef <- newMVar mempty
     let updateLabel body = do
         -- of course, modifyMVar and runStateT have their tuples back to front.
         m <- modifyMVar loaderStateRef $ \s -> do
@@ -62,6 +69,11 @@ recorderRun filename mwindow callback = handleGError newFailed $ do
                     labelSetMarkup label $
                         "Logged <b>" ++ show j ++ "</b> messages…"
                     putMVar n j
+
+                oldRR <- takeMVar rendererResultRef
+                let rr' = oldRR `mappend` rr
+                putMVar rendererResultRef rr'
+                incoming rr'
               | otherwise -> return ()
 
     handlerId <- monitor `on` monitorMessageLogged $ updateLabel
@@ -80,7 +92,7 @@ recorderRun filename mwindow callback = handleGError newFailed $ do
         signalDisconnect handlerId
         timeoutRemove pulseId
         widgetDestroy dialog
-        callback
+        finished
 
     widgetShowAll dialog
   where