Canvas: move all event handling inside module

2 files changed, 100 insertions, 80 deletions

diff --git a/Bustle/UI.hs b/Bustle/UI.hs
index 44ab426..53329bf 100644
--- a/Bustle/UI.hs
+++ b/Bustle/UI.hs
@@ -82,7 +82,7 @@ data WindowInfo =
                , wiStatsBook :: Notebook
                , wiStatsPane :: StatsPane
                , wiContentVPaned :: VPaned
-               , wiCanvas :: Canvas
+               , wiCanvas :: Canvas DetailedMessage
                , wiDetailsView :: DetailsView
 
                , wiLogDetails :: IORef (Maybe LogDetails)
@@ -248,7 +248,6 @@ emptyWindow = do
   viewStatistics <- getW castToCheckMenuItem "statistics"
   filterNames <- getW castToMenuItem "filter"
 
-  canvas <- io $ canvasNew xml
 
   [nb, statsBook] <- mapM (getW castToNotebook)
       ["diagramOrNot", "statsBook"]
@@ -286,6 +285,8 @@ emptyWindow = do
       -- message.
       widgetHide top
 
+  canvas <- io $ canvasNew xml (updateDetailsView details)
+
   logDetailsRef <- io $ newIORef Nothing
   let windowInfo = WindowInfo { wiWindow = window
                               , wiSave = saveItem
@@ -305,52 +306,33 @@ emptyWindow = do
   io $ widgetShow window
   return windowInfo
 
-type RSDM = RegionSelection DetailedMessage
-
-modifyRegionSelection :: IORef RSDM
-                      -> WindowInfo
-                      -> (RSDM -> RSDM)
-                      -> IO ()
-modifyRegionSelection regionSelectionRef wi f = do
-    let canvas      = wiCanvas wi
-        detailsView = wiDetailsView wi
-
-    rs <- readIORef regionSelectionRef
-    let currentMessage = rsCurrent rs
-        rs' = f rs
-        newMessage = rsCurrent rs'
-    writeIORef regionSelectionRef rs'
-
-    when (newMessage /= currentMessage) $ do
-        case newMessage of
-            Nothing     -> do
-                widgetHide $ detailsViewGetTop detailsView
-            Just (r, m) -> do
-                detailsViewUpdate detailsView m
-                canvasInvalidateStripe canvas r
-                widgetShow $ detailsViewGetTop detailsView
-                canvasClampAroundSelection canvas regionSelectionRef
-
-        case currentMessage of
-            Nothing -> return ()
-            Just (r, _) -> canvasInvalidateStripe canvas r
+updateDetailsView :: DetailsView
+                  -> Maybe DetailedMessage
+                  -> IO ()
+updateDetailsView detailsView newMessage = do
+    case newMessage of
+        Nothing -> do
+            widgetHide $ detailsViewGetTop detailsView
+        Just m  -> do
+            detailsViewUpdate detailsView m
+            widgetShow $ detailsViewGetTop detailsView
 
 updateDisplayedLog :: WindowInfo
                    -> RendererResult a
                    -> IORef [Shape]
                    -> IORef Double
-                   -> IORef (RegionSelection DetailedMessage)
                    -> IO ()
-updateDisplayedLog wi rr shapesRef widthRef regionSelectionRef = do
+updateDisplayedLog wi rr shapesRef widthRef = do
     let shapes = rrShapes rr
         (width, height) = diagramDimensions shapes
 
-        layout = canvasLayout $ wiCanvas wi
+        canvas = wiCanvas wi
+        layout = canvasLayout canvas
 
     writeIORef shapesRef shapes
     writeIORef widthRef width
 
-    modifyRegionSelection regionSelectionRef wi $ \rs ->
+    canvasUpdateSelection canvas $ \rs ->
       let
         rs' = regionSelectionNew (rrRegions rr)
       in
@@ -414,10 +396,9 @@ displayLog wi@(WindowInfo { wiWindow = window
 
     shapesRef <- newIORef []
     widthRef <- newIORef 0
-    regionSelectionRef <- newIORef $ regionSelectionNew []
     hiddenRef <- newIORef Set.empty
 
-    updateDisplayedLog wi rr shapesRef widthRef regionSelectionRef
+    updateDisplayedLog wi rr shapesRef widthRef
 
     widgetSetSensitivity exportItem True
     onActivateLeaf exportItem $ do
@@ -428,37 +409,15 @@ displayLog wi@(WindowInfo { wiWindow = window
     -- rather than everything that's visible.
     let layout = canvasLayout canvas
     layout `on` exposeEvent $ tryEvent $ io $ do
-        rs <- readIORef regionSelectionRef
+        current <- canvasGetSelection canvas
         shapes <- readIORef shapesRef
         width <- readIORef widthRef
         let shapes' =
-                case rsCurrent rs of
+                case current of
                     Nothing     -> shapes
                     Just (Stripe y1 y2, _) -> Highlight (0, y1, width, y2):shapes
         update layout shapes' showBounds
 
-    let modifyRS :: MonadIO io
-                 => (RSDM -> RSDM)
-                 -> io ()
-        modifyRS = io . modifyRegionSelection regionSelectionRef wi
-
-    layout `on` buttonPressEvent $ tryEvent $ do
-      io $ layout `set` [ widgetIsFocus := True ]
-      LeftButton <- eventButton
-      (_, y) <- eventCoordinates
-
-      modifyRS (regionSelectionUpdate y)
-
-    layout `on` keyPressEvent $ tryEvent $ do
-      [] <- eventModifier
-      key <- eventKeyName
-      case key of
-        "Up"        -> modifyRS regionSelectionUp
-        "Down"      -> modifyRS regionSelectionDown
-        "Home"      -> modifyRS regionSelectionFirst
-        "End"       -> modifyRS regionSelectionLast
-        _           -> stopEvent
-
     notebookSetCurrentPage nb 1
     layout `set` [ widgetIsFocus := True ]
 
@@ -481,7 +440,7 @@ displayLog wi@(WindowInfo { wiWindow = window
         writeIORef hiddenRef hidden'
         let rr' = processWithFilters (sessionMessages, hidden') (systemMessages, Set.empty)
 
-        updateDisplayedLog wi rr' shapesRef widthRef regionSelectionRef
+        updateDisplayedLog wi rr' shapesRef widthRef
 
     -- The stats start off hidden.
     widgetHide statsBook
diff --git a/Bustle/UI/Canvas.hs b/Bustle/UI/Canvas.hs
index 80dcbdd..5ae35c8 100644
--- a/Bustle/UI/Canvas.hs
+++ b/Bustle/UI/Canvas.hs
@@ -3,10 +3,11 @@ module Bustle.UI.Canvas
     Canvas
   , canvasNew
 
+  -- FIXME: move the stuff that needs this into this file.
   , canvasLayout
 
-  , canvasInvalidateStripe
-  , canvasClampAroundSelection
+  , canvasGetSelection
+  , canvasUpdateSelection
   )
 where
 
@@ -21,20 +22,26 @@ import Bustle.Diagram
 import Bustle.Regions
 import Bustle.Util
 
-data Canvas =
+data Canvas a =
     Canvas { canvasLayout :: Layout
            , canvasClampIdleId :: IORef (Maybe HandlerId)
+
+           , canvasSelection :: IORef (RegionSelection a)
+           , canvasSelectionChangedCb :: Maybe a -> IO ()
            }
 
-canvasNew :: GladeXML
-          -> IO Canvas
-canvasNew xml = do
+canvasNew :: Eq a
+          => GladeXML
+          -> (Maybe a -> IO ())
+          -> IO (Canvas a)
+canvasNew xml selectionChangedCb = do
     layout <- xmlGetWidget xml castToLayout "diagramLayout"
-
-    setupPanning layout
-
     idRef <- newIORef Nothing
-    return $ Canvas layout idRef
+    rsRef <- newIORef $ regionSelectionNew []
+
+    let canvas = Canvas layout idRef rsRef selectionChangedCb
+    setupCanvas canvas
+    return canvas
 
 -- Add/remove one step/page increment from an Adjustment, limited to the top of
 -- the last page.
@@ -55,9 +62,13 @@ incdec (+-) f adj = do
     lim <- adjustmentGetUpper adj
     adjustmentSetValue adj $ min (pos +- step) (lim - page)
 
-setupPanning :: Layout
-             -> IO ()
-setupPanning layout = do
+setupCanvas :: Eq a
+            => Canvas a
+            -> IO ()
+setupCanvas canvas = do
+    let layout = canvasLayout canvas
+
+    -- Scrolling
     hadj <- layoutGetHAdjustment layout
     vadj <- layoutGetVAdjustment layout
 
@@ -73,9 +84,30 @@ setupPanning layout = do
         "space"     -> io $ incPage vadj
         _           -> stopEvent
 
+    let updateWith f = io $ canvasUpdateSelection canvas f
+
+    -- Clicking
+    layout `on` buttonPressEvent $ tryEvent $ do
+      io $ layout `set` [ widgetIsFocus := True ]
+      LeftButton <- eventButton
+      (_, y) <- eventCoordinates
+
+      updateWith (regionSelectionUpdate y)
+
+    -- Keyboard navigation
+    layout `on` keyPressEvent $ tryEvent $ do
+      [] <- eventModifier
+      key <- eventKeyName
+      case key of
+        "Up"        -> updateWith regionSelectionUp
+        "Down"      -> updateWith regionSelectionDown
+        "Home"      -> updateWith regionSelectionFirst
+        "End"       -> updateWith regionSelectionLast
+        _           -> stopEvent
+
     return ()
 
-canvasInvalidateStripe :: Canvas
+canvasInvalidateStripe :: Canvas a
                        -> Stripe
                        -> IO ()
 canvasInvalidateStripe canvas (Stripe y1 y2) = do
@@ -86,15 +118,15 @@ canvasInvalidateStripe canvas (Stripe y1 y2) = do
 
     drawWindowInvalidateRect win pangoRectangle False
 
-canvasClampAroundSelection :: Canvas
-                           -> IORef (RegionSelection a)
+canvasClampAroundSelection :: Canvas a
                            -> IO ()
-canvasClampAroundSelection canvas regionSelectionRef = do
+canvasClampAroundSelection canvas = do
     let idRef = canvasClampIdleId canvas
+
     id_ <- readIORef idRef
     when (isNothing id_) $ do
         id' <- flip idleAdd priorityDefaultIdle $ do
-            rs <- readIORef regionSelectionRef
+            rs <- readIORef $ canvasSelection canvas
             case rsCurrent rs of
                 Nothing -> return ()
                 Just (Stripe top bottom, _) -> do
@@ -106,3 +138,32 @@ canvasClampAroundSelection canvas regionSelectionRef = do
             return False
 
         writeIORef idRef (Just id')
+
+canvasGetSelection :: Canvas a
+                   -> IO (Maybe (Stripe, a))
+canvasGetSelection canvas = do
+    rs <- readIORef $ canvasSelection canvas
+
+    return $ rsCurrent rs
+
+canvasUpdateSelection :: Eq a
+                      => Canvas a
+                      -> (RegionSelection a -> RegionSelection a)
+                      -> IO ()
+canvasUpdateSelection canvas f = do
+    let regionSelectionRef = canvasSelection canvas
+    rs <- readIORef regionSelectionRef
+    let currentMessage = rsCurrent rs
+        rs' = f rs
+        newMessage = rsCurrent rs'
+    writeIORef regionSelectionRef rs'
+
+    when (newMessage /= currentMessage) $ do
+        maybeM currentMessage $ \(r, _) ->
+            canvasInvalidateStripe canvas r
+
+        maybeM newMessage $ \(r, _) -> do
+            canvasInvalidateStripe canvas r
+            canvasClampAroundSelection canvas
+
+        canvasSelectionChangedCb canvas (fmap snd newMessage)