Move most remaining canvas code to module

2 files changed, 79 insertions, 63 deletions

diff --git a/Bustle/UI.hs b/Bustle/UI.hs
index 175a314..5dd9779 100644
--- a/Bustle/UI.hs
+++ b/Bustle/UI.hs
@@ -283,7 +283,8 @@ emptyWindow = do
       -- message.
       widgetHide top
 
-  canvas <- io $ canvasNew xml (updateDetailsView details)
+  showBounds <- asks debugEnabled
+  canvas <- io $ canvasNew xml showBounds (updateDetailsView details)
 
   logDetailsRef <- io $ newIORef Nothing
   let windowInfo = WindowInfo { wiWindow = window
@@ -317,40 +318,15 @@ updateDetailsView detailsView newMessage = do
 
 updateDisplayedLog :: WindowInfo
                    -> RendererResult a
-                   -> IORef [Shape]
-                   -> IORef Double
                    -> IO ()
-updateDisplayedLog wi rr shapesRef widthRef = do
+updateDisplayedLog wi rr = do
     let shapes = rrShapes rr
-        (width, height) = diagramDimensions shapes
-
+        regions = rrRegions rr
         canvas = wiCanvas wi
-        layout = canvasLayout canvas
-
-    writeIORef shapesRef shapes
-    writeIORef widthRef width
-
-    canvasUpdateSelection canvas $ \rs ->
-      let
-        rs' = regionSelectionNew (rrRegions rr)
-      in
-        case rsCurrent rs of
-            Just (_, x) -> regionSelectionSelect x rs'
-            Nothing     -> rs'
-
-    layoutSetSize layout (floor width) (floor height)
 
-    -- FIXME: only do this the first time maybe?
-    -- Shift to make the timestamp column visible
-    hadj <- layoutGetHAdjustment layout
     (windowWidth, _) <- windowGetSize (wiWindow wi)
-    -- Roughly centre the timestamp-and-member column
-    adjustmentSetValue hadj
-        ((rrCentreOffset rr) -
-            (fromIntegral windowWidth - timestampAndMemberWidth) / 2
-        )
 
-    return ()
+    canvasSetShapes canvas shapes regions (rrCentreOffset rr) windowWidth
 
 logTitle :: LogDetails
          -> String
@@ -387,37 +363,20 @@ displayLog wi@(WindowInfo { wiWindow = window
            sessionMessages
            systemMessages
            rr = do
-  showBounds <- asks debugEnabled
-
   io $ do
     wiSetLogDetails wi logDetails
 
-    shapesRef <- newIORef []
-    widthRef <- newIORef 0
     hiddenRef <- newIORef Set.empty
 
-    updateDisplayedLog wi rr shapesRef widthRef
+    updateDisplayedLog wi rr
 
     widgetSetSensitivity exportItem True
     onActivateLeaf exportItem $ do
-        shapes <- readIORef shapesRef
+        shapes <- canvasGetShapes canvas
         saveToPDFDialogue wi shapes
 
-    -- I think we could speed things up by only showing the revealed area
-    -- rather than everything that's visible.
-    let layout = canvasLayout canvas
-    layout `on` exposeEvent $ tryEvent $ io $ do
-        current <- canvasGetSelection canvas
-        shapes <- readIORef shapesRef
-        width <- readIORef widthRef
-        let shapes' =
-                case current of
-                    Nothing     -> shapes
-                    Just (Stripe y1 y2, _) -> Highlight (0, y1, width, y2):shapes
-        canvasUpdate canvas shapes' showBounds
-
     notebookSetCurrentPage nb 1
-    layout `set` [ widgetIsFocus := True ]
+    canvasFocus canvas
 
     -- FIXME: this currently shows stats for all messages, not post-filtered messages
     statsPaneSetMessages statsPane sessionMessages systemMessages
@@ -438,7 +397,7 @@ displayLog wi@(WindowInfo { wiWindow = window
         writeIORef hiddenRef hidden'
         let rr' = processWithFilters (sessionMessages, hidden') (systemMessages, Set.empty)
 
-        updateDisplayedLog wi rr' shapesRef widthRef
+        updateDisplayedLog wi rr'
 
     -- The stats start off hidden.
     widgetHide statsBook
diff --git a/Bustle/UI/Canvas.hs b/Bustle/UI/Canvas.hs
index b5394f4..22b819b 100644
--- a/Bustle/UI/Canvas.hs
+++ b/Bustle/UI/Canvas.hs
@@ -3,13 +3,10 @@ module Bustle.UI.Canvas
     Canvas
   , canvasNew
 
-  -- FIXME: move the stuff that needs this into this file.
-  , canvasLayout
+  , canvasGetShapes
+  , canvasSetShapes
 
-  , canvasGetSelection
-  , canvasUpdateSelection
-
-  , canvasUpdate
+  , canvasFocus
   )
 where
 
@@ -28,20 +25,28 @@ data Canvas a =
     Canvas { canvasLayout :: Layout
            , canvasClampIdleId :: IORef (Maybe HandlerId)
 
+           , canvasShapes :: IORef Diagram
+           , canvasWidth :: IORef Double
+
            , canvasSelection :: IORef (RegionSelection a)
            , canvasSelectionChangedCb :: Maybe a -> IO ()
+
+           , canvasShowBounds :: Bool
            }
 
 canvasNew :: Eq a
           => GladeXML
+          -> Bool
           -> (Maybe a -> IO ())
           -> IO (Canvas a)
-canvasNew xml selectionChangedCb = do
+canvasNew xml showBounds selectionChangedCb = do
     layout <- xmlGetWidget xml castToLayout "diagramLayout"
     idRef <- newIORef Nothing
+    shapesRef <- newIORef []
+    widthRef <- newIORef 0
     rsRef <- newIORef $ regionSelectionNew []
 
-    let canvas = Canvas layout idRef rsRef selectionChangedCb
+    let canvas = Canvas layout idRef shapesRef widthRef rsRef selectionChangedCb showBounds
     setupCanvas canvas
     return canvas
 
@@ -107,6 +112,11 @@ setupCanvas canvas = do
         "End"       -> updateWith regionSelectionLast
         _           -> stopEvent
 
+    -- Expose events
+    -- I think we could speed things up by only showing the revealed area
+    -- rather than everything that's visible.
+    layout `on` exposeEvent $ tryEvent $ io $ canvasUpdate canvas
+
     return ()
 
 canvasInvalidateStripe :: Canvas a
@@ -170,12 +180,54 @@ canvasUpdateSelection canvas f = do
 
         canvasSelectionChangedCb canvas (fmap snd newMessage)
 
--- | Redraws the currently-visible area of the canvas with the provided shapes
+canvasSetShapes :: Eq a
+                => Canvas a
+                -> Diagram
+                -> Regions a
+                -> Double -- Yuck. These shouldn't be here.
+                -> Int    -- No no no!
+                -> IO ()
+canvasSetShapes canvas shapes regions centreOffset windowWidth = do
+    let (width, height) = diagramDimensions shapes
+        layout = canvasLayout canvas
+
+    writeIORef (canvasShapes canvas) shapes
+    writeIORef (canvasWidth canvas) width
+
+    canvasUpdateSelection canvas $ \rs ->
+      let
+        rs' = regionSelectionNew regions
+      in
+        case rsCurrent rs of
+            Just (_, x) -> regionSelectionSelect x rs'
+            Nothing     -> rs'
+
+    layoutSetSize layout (floor width) (floor height)
+
+    -- FIXME: only do this the first time maybe?
+    -- Shift to make the timestamp column visible
+    hadj <- layoutGetHAdjustment layout
+    -- Roughly centre the timestamp-and-member column
+    adjustmentSetValue hadj
+        (centreOffset -
+            (fromIntegral windowWidth - timestampAndMemberWidth) / 2
+        )
+
+canvasGetShapes :: Canvas a
+                -> IO Diagram
+canvasGetShapes = readIORef . canvasShapes
+
+-- | Redraws the currently-visible area of the canvas
 canvasUpdate :: Canvas a
-             -> Diagram
-             -> Bool
              -> IO ()
-canvasUpdate canvas shapes showBounds = do
+canvasUpdate canvas = do
+    current <- canvasGetSelection canvas
+    shapes <- canvasGetShapes canvas
+    width <- readIORef $ canvasWidth canvas
+    let shapes' = case current of
+            Nothing     -> shapes
+            Just (Stripe y1 y2, _) -> Highlight (0, y1, width, y2):shapes
+
     let layout = canvasLayout canvas
 
     hadj <- layoutGetHAdjustment layout
@@ -189,4 +241,9 @@ canvasUpdate canvas shapes showBounds = do
     let r = (hpos, vpos, hpos + hpage, vpos + vpage)
 
     win <- layoutGetDrawWindow layout
-    renderWithDrawable win $ drawRegion r showBounds shapes
+    renderWithDrawable win $ drawRegion r (canvasShowBounds canvas) shapes'
+
+canvasFocus :: Canvas a
+            -> IO ()
+canvasFocus canvas = do
+    (canvasLayout canvas) `set` [ widgetIsFocus := True ]