allow document titles to be edited

assets/theme.css

@@ -466,11 +466,20 @@ To specify it in CSS, set the box-shadow of the contents node."
   border-color: @active;
 }
 
-.metabrush .fileBarTab:active, .metabrush .fileBarTab:checked {
+.metabrush .activeTab {
   border-color: @base;
   background-color: @active;
 }
 
+.metabrush .activeTab:hover {
+  border-color: @base;
+}
+
+.metabrush .fileBarTab label {
+  margin-left: 4px;
+  color: @plain;
+}
+
 .metabrush .fileBarTabButton {
   padding-left: 8px;
   padding-right: 2px;

src/app/MetaBrush/Application/Action.hs

@@ -499,44 +499,44 @@ instance HandleAction Close where
 -- Switch document --
 ---------------------
 
-data SwitchFromTo =
+data SwitchTo =
-  SwitchFromTo
+  SwitchTo
-    { mbPrevActiveDocUnique :: !( Maybe Unique )
+    { newActiveDocUnique :: !Unique
-    , newActiveDocUnique    :: !Unique
     }
   deriving stock Show
 
-instance HandleAction SwitchFromTo where
+instance HandleAction SwitchTo where
   handleAction
     uiElts
     vars@( Variables {..} )
-    ( SwitchFromTo { mbPrevActiveDocUnique, newActiveDocUnique } )
+    ( SwitchTo { newActiveDocUnique } ) = do
-      | mbPrevActiveDocUnique == Just newActiveDocUnique
+      uiAction <- STM.atomically $ do
-      = do
+        mbPrevActiveDocUnique <- STM.swapTVar activeDocumentTVar ( Just newActiveDocUnique )
-          mbActiveTab <- Map.lookup newActiveDocUnique <$> STM.readTVarIO fileBarTabsTVar
+        if mbPrevActiveDocUnique == Just newActiveDocUnique
-          for_ mbActiveTab \ ( FileBarTab { fileBarTab = activeTab, fileBarTabButton = activeTabButton } ) -> do
+        then
-            GTK.toggleButtonSetActive activeTabButton True
+          return $ return ()
-            flags <- GTK.widgetGetStateFlags activeTab
+        else do
-            GTK.widgetSetStateFlags activeTab
-              ( GTK.StateFlagsActive : filter (/= GTK.StateFlagsActive) flags )
-              True
-      | otherwise
-      = do
-        uiUpdateAction <- STM.atomically do
-          STM.writeTVar activeDocumentTVar ( Just newActiveDocUnique )
-          mbHist <- Map.lookup newActiveDocUnique <$> STM.readTVar openDocumentsTVar
           let change = ActiveDocChange { mbOldDocUnique = mbPrevActiveDocUnique }
+          mbHist      <- Map.lookup newActiveDocUnique <$> STM.readTVar openDocumentsTVar
+          mbActiveTab <- Map.lookup newActiveDocUnique <$> STM.readTVar fileBarTabsTVar
+          mbPrevActiveTab <-
+                     case mbPrevActiveDocUnique of
+                       Nothing -> return Nothing
+                       Just prevActiveDocUnique ->
+                         Map.lookup prevActiveDocUnique <$> STM.readTVar fileBarTabsTVar
           uiUpdateAction <- updateUIAction change uiElts vars
-          pure do
+          return $ do
+            for_ mbActiveTab $ \ ( FileBarTab { fileBarTab = activeTab } ) -> do
+              GTK.widgetAddCssClass activeTab "activeTab"
+
+              GTK.widgetQueueDraw activeTab
+
+            for_ mbPrevActiveTab \ ( FileBarTab { fileBarTab = prevActiveTab } ) -> do
+              GTK.widgetRemoveCssClass prevActiveTab "activeTab"
+              GTK.widgetQueueDraw prevActiveTab
             uiUpdateAction
-            for_ mbPrevActiveDocUnique \ prevActiveDocUnique -> do
-              mbPrevActiveTab <- Map.lookup prevActiveDocUnique <$> STM.readTVarIO fileBarTabsTVar
-              for_ mbPrevActiveTab \ ( FileBarTab { fileBarTab = prevActiveTab, fileBarTabButton = prevActiveTabButton } ) -> do
-                GTK.toggleButtonSetActive prevActiveTabButton False
-                flags <- GTK.widgetGetStateFlags prevActiveTab
-                GTK.widgetSetStateFlags prevActiveTab ( filter (/= GTK.StateFlagsActive) flags ) True
             updateHistoryState uiElts mbHist
-        uiUpdateAction
+      uiAction
 
 --------------
 -- Quitting --

src/app/MetaBrush/Application/Action.hs-boot

@@ -55,12 +55,11 @@ data Close
     { docToClose :: !Unique }
 instance HandleAction Close
 
-data SwitchFromTo =
+data SwitchTo =
-  SwitchFromTo
+  SwitchTo
-    { mbPrevActiveDocUnique :: !( Maybe Unique )
+    { newActiveDocUnique :: !Unique
-    , newActiveDocUnique    :: !Unique
     }
-instance HandleAction SwitchFromTo
+instance HandleAction SwitchTo
 
 data Quit = Quit
 instance HandleAction Quit

src/app/MetaBrush/Application/Context.hs

@@ -216,13 +216,12 @@ data FileBar
   = FileBar
   { fileBarBox  :: !GTK.Box
   , fileTabsBox :: !GTK.Box
-  , fileBarPhantomToggleButton :: !GTK.ToggleButton
   }
 
 data FileBarTab
   = FileBarTab
   { fileBarTab          :: !GTK.Box
-  , fileBarTabButton    :: !GTK.ToggleButton
+  , fileBarTabLabel     :: !GTK.EditableLabel
   , fileBarTabCloseArea :: !GTK.DrawingArea
   }
 

src/app/MetaBrush/Application/UpdateDocument.hs

@@ -226,9 +226,7 @@ updateUIAction _docChange uiElts@( UIElements { viewport = Viewport {..}, .. } )
     _ <- GLib.idleAdd GLib.PRIORITY_DEFAULT_IDLE $ do
           switchStrokeView strokesListView vars ( fst <$> mbDoc )
           return False
-    for_ mbActiveTabDoc \ ( FileBarTab { fileBarTab, fileBarTabButton, fileBarTabCloseArea }, ( _, activeDoc ) ) -> do
+    for_ mbActiveTabDoc \ ( FileBarTab { fileBarTabCloseArea }, ( _, _activeDoc ) ) -> do
-      GTK.buttonSetLabel fileBarTabButton ( documentName $ documentMetadata activeDoc )
-      GTK.widgetQueueDraw fileBarTab
       GTK.widgetQueueDraw fileBarTabCloseArea
       updateHistoryState uiElts ( fmap snd mbDocHist )
       STM.atomically ( STM.writeTVar redrawStrokesTVar True )

src/app/MetaBrush/GTK/Util.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module MetaBrush.GTK.Util
@@ -7,12 +8,13 @@ module MetaBrush.GTK.Util
   , widgetAddClasses, widgetAddClass
   , widgetShow
   , (>=?=>), (>>?=)
+  , editableLabelNew
   )
   where
 
 -- base
 import Control.Monad
-  ( (>=>) )
+  ( (>=>), unless )
 import Data.Coerce
   ( coerce )
 import Data.Foldable
@@ -20,6 +22,9 @@ import Data.Foldable
 import GHC.Stack
   ( HasCallStack )
 
+-- gi-gio
+import qualified GI.Gio as GIO
+
 -- gi-gdk
 import qualified GI.Gdk as GDK
 
@@ -94,3 +99,43 @@ infixr 1 >=?=>
 infixl 1 >>?=
 (>>?=) :: forall m a b. Monad m => m ( Maybe a ) -> ( a -> m ( Maybe b ) ) -> m ( Maybe b )
 (>>?=) = coerce ( (>>=) @( MaybeT m ) @a @b )
+
+--------------------------------------------------------------------------------
+
+-- | Create a new editable label, but remove any 'DragSource' or 'DropTarget'
+-- controllers attached to it, as we don't want the label to participate in
+-- drag-and-drop operations, especially because having it participate in
+-- drag-and-drop operations triggers segfaults due to a GTK bug.
+editableLabelNew :: IO GTK.EditableLabel
+editableLabelNew = do
+  label <- GTK.editableLabelNew " "
+  widget <- GTK.toWidget label
+  removeControllers widget
+  return label
+
+  where
+    removeControllers :: GTK.Widget -> IO ()
+    removeControllers widget = do
+      controllers <- GTK.widgetObserveControllers widget
+      nbControllers <- GIO.listModelGetNItems controllers
+      unless ( nbControllers == 0 ) $
+        for_ [ 0 .. nbControllers - 1 ] $ \ i -> do
+          mbController <- GIO.listModelGetItem controllers i
+          for_ mbController $ \ controller -> do
+            mbDrag <- GTK.castTo GTK.DragSource controller
+            mbDrop <- GTK.castTo GTK.DropTarget controller
+            for_ mbDrag $ GTK.widgetRemoveController widget
+            for_ mbDrop $ GTK.widgetRemoveController widget
+      mbChild <- GTK.widgetGetFirstChild widget
+      case mbChild of
+        Nothing -> return ()
+        Just c -> do
+          removeControllers c
+          removeControllersSiblings c
+    removeControllersSiblings c = do
+      mbNext <- GTK.widgetGetNextSibling c
+      case mbNext of
+        Nothing -> return ()
+        Just next -> do
+          removeControllers next
+          removeControllersSiblings next

src/app/MetaBrush/UI/FileBar.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module MetaBrush.UI.FileBar
@@ -9,7 +11,7 @@ module MetaBrush.UI.FileBar
 
 -- base
 import Control.Monad
-  ( join, void )
+  ( join, void, when )
 import Data.Foldable
   ( sequenceA_ )
 import Data.Traversable
@@ -18,6 +20,10 @@ import Data.Traversable
 -- containers
 import qualified Data.Map.Strict as Map
 
+-- generic-lens
+import Data.Generics.Product.Fields
+  ( field' )
+
 -- gi-cairo-connector
 import qualified GI.Cairo.Render.Connector as Cairo
   ( renderWithContext )
@@ -28,11 +34,20 @@ import qualified GI.Gio as GIO
 -- gi-gtk
 import qualified GI.Gtk as GTK
 
+-- haskell-gi-base
+import qualified Data.GI.Base as GI
+
+-- lens
+import Control.Lens
+  ( set )
+import Control.Lens.At
+  ( ix )
+
 -- stm
 import qualified Control.Concurrent.STM      as STM
   ( atomically )
 import qualified Control.Concurrent.STM.TVar as STM
-  ( writeTVar, readTVar, readTVarIO, modifyTVar' )
+  ( readTVar, readTVarIO, modifyTVar' )
 
 -- transformers
 import Control.Monad.Trans.Reader
@@ -44,8 +59,10 @@ import Data.HashMap.Lazy
 
 -- MetaBrush
 import {-# SOURCE #-} MetaBrush.Application.Action
-  ( SwitchFromTo(..), Close(..), handleAction )
+  ( SwitchTo(..), Close(..), handleAction )
 import MetaBrush.Application.Context
+import MetaBrush.Application.UpdateDocument
+  ( ActiveDocChange (..), updateUIAction )
 import MetaBrush.Asset.CloseTabButton
   ( drawCloseTabButton )
 import MetaBrush.Asset.Colours
@@ -53,8 +70,6 @@ import MetaBrush.Asset.Colours
 import MetaBrush.Document
 import MetaBrush.Document.History
   ( DocumentHistory(..), newHistory )
-import MetaBrush.Application.UpdateDocument
-  ( updateUIAction, ActiveDocChange (..) )
 import MetaBrush.UI.Panels
   ( PanelsBar )
 import MetaBrush.UI.Viewport
@@ -88,29 +103,49 @@ newFileTab
           newDocUniq <- STM.atomically $ runReaderT freshUnique uniqueSupply
           pure ( newDocUniq, newHistory $ emptyDocument ( "Untitled " <> uniqueText newDocUniq ) )
 
-    -- TODO: make the file tab an EditableLabel
+    pgLabel <- GTK.editableLabelNew ( documentName $ documentMetadata $ present thisTabDocHist )
-    -- File tab elements.
+    GTK.editableSetEditable pgLabel False
-    pgButton <- GTK.toggleButtonNewWithLabel ( documentName $ documentMetadata $ present thisTabDocHist )
+
-    GTK.toggleButtonSetGroup pgButton ( Just fileBarPhantomToggleButton )
+    -- Connect a signal for editing the document name.
-    closeFileButton <- GTK.buttonNew
+    --
+    -- NB: we don't use the 'onEditableChanged' signal, as that updates
+    -- after every key stroke.
+    void $ GI.on pgLabel ( GI.PropertyNotify #hasFocus ) $ \ _ -> do
+      hasFocus <- GTK.widgetHasFocus pgLabel
+      when hasFocus do
+        newDocName <- GTK.editableGetText pgLabel
+        uiUpdate <-
+          STM.atomically $ do
+            STM.modifyTVar' openDocumentsTVar
+              ( set ( ix thisTabDocUnique
+                    . field' @"present"
+                    . field' @"documentMetadata"
+                    . field' @"documentName"
+                    )
+              newDocName
+              )
+            updateUIAction NoActiveDocChange uiElts vars
+        uiUpdate
+        GTK.editableSetEditable pgLabel False
+
     closeFileArea <- GTK.drawingAreaNew
-    GTK.buttonSetChild closeFileButton ( Just closeFileArea )
 
     GTK.drawingAreaSetDrawFunc closeFileArea $ Just \ _ cairoContext _ _ -> void do
       mbTabDoc <- fmap present . Map.lookup thisTabDocUnique <$> STM.readTVarIO openDocumentsTVar
       let
         unsaved :: Bool
         unsaved = maybe False ( unsavedChanges . documentContent ) mbTabDoc
-      flags <- GTK.widgetGetStateFlags closeFileButton
+      flags <- GTK.widgetGetStateFlags closeFileArea
       Cairo.renderWithContext ( drawCloseTabButton colours unsaved flags ) cairoContext
 
     -- Create box for file tab elements.
     tab <- GTK.boxNew GTK.OrientationHorizontal 0
     widgetAddClasses tab [ "fileBarTab" ]
-    GTK.boxAppend tab pgButton
+    GTK.boxAppend tab pgLabel
-    GTK.boxAppend tab closeFileButton
+    GTK.boxAppend tab closeFileArea
-    widgetAddClasses pgButton        [ "fileBarTabButton" ]
+    widgetAddClasses closeFileArea [ "fileBarCloseButton" ]
-    widgetAddClasses closeFileButton [ "fileBarCloseButton" ]
+
+    pgClicks <- GTK.gestureClickNew
 
     -- Place the new tab in the correct position within the file bar.
     case newTabLoc of
@@ -131,55 +166,41 @@ newFileTab
       fileBarTab =
         FileBarTab
           { fileBarTab          = tab
-          , fileBarTabButton    = pgButton
+          , fileBarTabLabel     = pgLabel
           , fileBarTabCloseArea = closeFileArea
           }
-    -- Update the state: switch to this new document.
+    -- Add this document to the set of existing documents.
-    uiUpdateAction <- STM.atomically do
+    STM.atomically do
       STM.modifyTVar' openDocumentsTVar ( Map.insert thisTabDocUnique thisTabDocHist )
       STM.modifyTVar' fileBarTabsTVar   ( Map.insert thisTabDocUnique fileBarTab )
-      mbOldDoc <- STM.readTVar  activeDocumentTVar
-      STM.writeTVar activeDocumentTVar ( Just thisTabDocUnique )
-      let change = ActiveDocChange { mbOldDocUnique = mbOldDoc }
-      updateUIAction change uiElts vars
-    uiUpdateAction
 
-    void $ GTK.afterToggleButtonToggled pgButton do
+    void $ GTK.onGestureClickReleased pgClicks $ \ nbClicks _x _y -> do
-      nowActive <- GTK.toggleButtonGetActive pgButton
+      button <- GTK.gestureSingleGetCurrentButton ?self
-      flags <- GTK.widgetGetStateFlags tab
+      case button of
-      mbPrevActiveDocUnique <- STM.readTVarIO activeDocumentTVar
+        1 -> do
-      if nowActive
+          handleAction uiElts vars ( SwitchTo thisTabDocUnique )
-      then do
+          when ( nbClicks > 1 ) do
-        -- If changing tabs, switch document.
+            GTK.editableSetEditable pgLabel True
-        -- This will untoggle the previously active tab
+            GTK.editableLabelStartEditing pgLabel
-        -- ('onToggleButtonToggled' will run this handler).
+            void $ GTK.widgetGrabFocus pgLabel
-        handleAction uiElts vars ( SwitchFromTo mbPrevActiveDocUnique thisTabDocUnique )
+        _ -> return ()
-        GTK.widgetSetStateFlags tab
-          ( GTK.StateFlagsActive : filter (/= GTK.StateFlagsActive) flags )
-          True
-      else do
-        -- Otherwise, ensure the tab hasn't been toggled off on its own
-        -- (clicking on an already selected tab shouldn't do anything, not untoggle the tab).
-        mbNewActiveDocUnique <- STM.readTVarIO activeDocumentTVar
-        case mbNewActiveDocUnique of
-          -- Clicking on already selected document: don't allow the tab to be toggled off.
-          Just unique | unique == thisTabDocUnique
-            -> do
-              GTK.toggleButtonSetActive pgButton True
-              GTK.widgetSetStateFlags tab
-                ( GTK.StateFlagsActive : filter (/= GTK.StateFlagsActive) flags )
-                True
-          -- Otherwise: leave it toggled off.
-          _ -> GTK.widgetSetStateFlags tab
-                ( filter (/= GTK.StateFlagsActive) flags )
-                True
 
-    GTK.toggleButtonSetActive pgButton False
+    closeButtonClick <- GTK.gestureClickNew
-    GTK.toggleButtonSetActive pgButton True
+    void $ GTK.onGestureClickPressed closeButtonClick $ \ _ _ _ -> do
-
+      void $ GTK.gestureSetState ?self GTK.EventSequenceStateClaimed
-    void $ GTK.onButtonClicked closeFileButton do
+    void $ GTK.onGestureClickReleased closeButtonClick $ \ _ _ _ -> do
+      button <- GTK.gestureSingleGetCurrentButton ?self
+      case button of
+        1 -> do
           GTK.widgetQueueDraw closeFileArea
           handleAction uiElts vars ( CloseThis thisTabDocUnique )
+        _ -> return ()
+      void $ GTK.gestureSetState ?self GTK.EventSequenceStateClaimed
+    GTK.widgetAddController closeFileArea closeButtonClick
+    GTK.widgetAddController tab pgClicks
+
+    -- Switch to this tab.
+    handleAction uiElts vars ( SwitchTo thisTabDocUnique )
 
 -- | Create a file bar: tabs allowing selection of the active document.
 --
@@ -219,9 +240,6 @@ createFileBar
     GTK.scrolledWindowSetChild fileTabsScroll ( Just fileTabsBox )
     widgetAddClasses fileTabsBox [ "fileBar", "plain", "text" ]
 
-    -- Phantom toggle button for when no page is selected (e.g. no documents opened yet).
-    fileBarPhantomToggleButton <- GTK.toggleButtonNew
-
     let
       fileBar :: FileBar
       fileBar = FileBar {..}

src/app/MetaBrush/UI/Menu.hs

@@ -273,21 +273,6 @@ createMenuBar uiElts@( UIElements { application, window, titleBar } ) vars colou
   widgetAddClasses menuBar [ "headerMenu", "text", "plain" ]
   GTK.headerBarPackStart titleBar menuBar
 
-  -- TODO: this is a bit of a workaround to add hover highlight to top-level menu items.
-  -- Activating a menu somehow sets the "hover" setting,
-  -- so instead we use the "selected" setting for actual hover highlighting.
-  -- GTK4 FIXME
-  --topLevelMenuItems <- GTK.containerGetChildren menuBar
-  --for_ topLevelMenuItems \ topLevelMenuItem -> do
-  --  void $ GTK.onWidgetEnterNotifyEvent topLevelMenuItem \ _ -> do
-  --    flags <- GTK.widgetGetStateFlags topLevelMenuItem
-  --    GTK.widgetSetStateFlags topLevelMenuItem ( GTK.StateFlagsSelected : flags ) True
-  --    pure False
-  --  void $ GTK.onWidgetLeaveNotifyEvent topLevelMenuItem \ _ -> do
-  --    flags <- GTK.widgetGetStateFlags topLevelMenuItem
-  --    GTK.widgetSetStateFlags topLevelMenuItem ( filter ( /= GTK.StateFlagsSelected ) flags ) True
-  --    pure False
-
   windowIcons <- GTK.boxNew GTK.OrientationHorizontal 0
   widgetAddClasses windowIcons [ "windowIcons" ]
   GTK.headerBarPackEnd titleBar windowIcons

src/app/MetaBrush/UI/StrokeTreeView.hs

@@ -22,7 +22,7 @@ module MetaBrush.UI.StrokeTreeView
 import Control.Arrow
   ( second )
 import Control.Monad
-  ( unless, void )
+  ( void )
 import Data.Foldable
   ( for_ )
 import Data.List
@@ -367,43 +367,6 @@ newLayerViewWidget = do
 
   return expander
 
--- | Create a new editable label, but remove any 'DragSource' or 'DropTarget'
--- controllers attached to it, as we don't want the label to participate in
--- drag-and-drop operations, especially because having it participate in
--- drag-and-drop operations triggers segfaults due to a GTK bug.
-editableLabelNew :: IO GTK.EditableLabel
-editableLabelNew = do
-  label <- GTK.editableLabelNew " "
-  widget <- GTK.toWidget label
-  removeControllers widget
-  return label
-
-  where
-    removeControllers widget = do
-      controllers <- GTK.widgetObserveControllers widget
-      nbControllers <- GIO.listModelGetNItems controllers
-      unless ( nbControllers == 0 ) $
-        for_ [ 0 .. nbControllers - 1 ] $ \ i -> do
-          mbController <- GIO.listModelGetItem controllers i
-          for_ mbController $ \ controller -> do
-            mbDrag <- GTK.castTo GTK.DragSource controller
-            mbDrop <- GTK.castTo GTK.DropTarget controller
-            for_ mbDrag $ GTK.widgetRemoveController widget
-            for_ mbDrop $ GTK.widgetRemoveController widget
-      mbChild <- GTK.widgetGetFirstChild widget
-      case mbChild of
-        Nothing -> return ()
-        Just c -> do
-          removeControllers c
-          removeControllersSiblings c
-    removeControllersSiblings c = do
-      mbNext <- GTK.widgetGetNextSibling c
-      case mbNext of
-        Nothing -> return ()
-        Just next -> do
-          removeControllers next
-          removeControllersSiblings next
-
 -- | Get the widget hierarchy for a list item, so that we can modify
 -- the wdigets to display the appropriate content.
 getLayerViewWidget :: GTK.TreeExpander -> IO LayerViewWidget