From 6ecfebd397ebf15b98f944386129b4aa33896b52 Mon Sep 17 00:00:00 2001 From: sheaf Date: Mon, 21 Oct 2024 14:58:53 +0200 Subject: [PATCH] allow document titles to be edited --- assets/theme.css | 11 +- src/app/MetaBrush/Application/Action.hs | 56 +++---- src/app/MetaBrush/Application/Action.hs-boot | 9 +- src/app/MetaBrush/Application/Context.hs | 3 +- .../MetaBrush/Application/UpdateDocument.hs | 4 +- src/app/MetaBrush/GTK/Util.hs | 47 +++++- src/app/MetaBrush/UI/FileBar.hs | 140 ++++++++++-------- src/app/MetaBrush/UI/Menu.hs | 15 -- src/app/MetaBrush/UI/StrokeTreeView.hs | 39 +---- 9 files changed, 170 insertions(+), 154 deletions(-) diff --git a/assets/theme.css b/assets/theme.css index c4a6381..b1f2bf3 100644 --- a/assets/theme.css +++ b/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; diff --git a/src/app/MetaBrush/Application/Action.hs b/src/app/MetaBrush/Application/Action.hs index 3752188..ae4901c 100644 --- a/src/app/MetaBrush/Application/Action.hs +++ b/src/app/MetaBrush/Application/Action.hs @@ -499,44 +499,44 @@ instance HandleAction Close where -- Switch document -- --------------------- -data SwitchFromTo = - SwitchFromTo - { mbPrevActiveDocUnique :: !( Maybe Unique ) - , newActiveDocUnique :: !Unique +data SwitchTo = + SwitchTo + { newActiveDocUnique :: !Unique } deriving stock Show -instance HandleAction SwitchFromTo where +instance HandleAction SwitchTo where handleAction uiElts vars@( Variables {..} ) - ( SwitchFromTo { mbPrevActiveDocUnique, newActiveDocUnique } ) - | mbPrevActiveDocUnique == Just newActiveDocUnique - = do - mbActiveTab <- Map.lookup newActiveDocUnique <$> STM.readTVarIO fileBarTabsTVar - for_ mbActiveTab \ ( FileBarTab { fileBarTab = activeTab, fileBarTabButton = activeTabButton } ) -> do - GTK.toggleButtonSetActive activeTabButton True - flags <- GTK.widgetGetStateFlags activeTab - 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 + ( SwitchTo { newActiveDocUnique } ) = do + uiAction <- STM.atomically $ do + mbPrevActiveDocUnique <- STM.swapTVar activeDocumentTVar ( Just newActiveDocUnique ) + if mbPrevActiveDocUnique == Just newActiveDocUnique + then + return $ return () + else do 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 -- diff --git a/src/app/MetaBrush/Application/Action.hs-boot b/src/app/MetaBrush/Application/Action.hs-boot index d4c2d35..7b3431c 100644 --- a/src/app/MetaBrush/Application/Action.hs-boot +++ b/src/app/MetaBrush/Application/Action.hs-boot @@ -55,12 +55,11 @@ data Close { docToClose :: !Unique } instance HandleAction Close -data SwitchFromTo = - SwitchFromTo - { mbPrevActiveDocUnique :: !( Maybe Unique ) - , newActiveDocUnique :: !Unique +data SwitchTo = + SwitchTo + { newActiveDocUnique :: !Unique } -instance HandleAction SwitchFromTo +instance HandleAction SwitchTo data Quit = Quit instance HandleAction Quit diff --git a/src/app/MetaBrush/Application/Context.hs b/src/app/MetaBrush/Application/Context.hs index b9bff99..786615a 100644 --- a/src/app/MetaBrush/Application/Context.hs +++ b/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 } diff --git a/src/app/MetaBrush/Application/UpdateDocument.hs b/src/app/MetaBrush/Application/UpdateDocument.hs index e119d00..b5a792a 100644 --- a/src/app/MetaBrush/Application/UpdateDocument.hs +++ b/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 - GTK.buttonSetLabel fileBarTabButton ( documentName $ documentMetadata activeDoc ) - GTK.widgetQueueDraw fileBarTab + for_ mbActiveTabDoc \ ( FileBarTab { fileBarTabCloseArea }, ( _, _activeDoc ) ) -> do GTK.widgetQueueDraw fileBarTabCloseArea updateHistoryState uiElts ( fmap snd mbDocHist ) STM.atomically ( STM.writeTVar redrawStrokesTVar True ) diff --git a/src/app/MetaBrush/GTK/Util.hs b/src/app/MetaBrush/GTK/Util.hs index 7d399a2..1a174a5 100644 --- a/src/app/MetaBrush/GTK/Util.hs +++ b/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 diff --git a/src/app/MetaBrush/UI/FileBar.hs b/src/app/MetaBrush/UI/FileBar.hs index dbffe68..a8392d8 100644 --- a/src/app/MetaBrush/UI/FileBar.hs +++ b/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 - -- File tab elements. - pgButton <- GTK.toggleButtonNewWithLabel ( documentName $ documentMetadata $ present thisTabDocHist ) - GTK.toggleButtonSetGroup pgButton ( Just fileBarPhantomToggleButton ) - closeFileButton <- GTK.buttonNew + pgLabel <- GTK.editableLabelNew ( documentName $ documentMetadata $ present thisTabDocHist ) + GTK.editableSetEditable pgLabel False + + -- Connect a signal for editing the document name. + -- + -- 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 closeFileButton - widgetAddClasses pgButton [ "fileBarTabButton" ] - widgetAddClasses closeFileButton [ "fileBarCloseButton" ] + GTK.boxAppend tab pgLabel + GTK.boxAppend tab closeFileArea + widgetAddClasses closeFileArea [ "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. - uiUpdateAction <- STM.atomically do + -- Add this document to the set of existing documents. + 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 - nowActive <- GTK.toggleButtonGetActive pgButton - flags <- GTK.widgetGetStateFlags tab - mbPrevActiveDocUnique <- STM.readTVarIO activeDocumentTVar - if nowActive - then do - -- If changing tabs, switch document. - -- This will untoggle the previously active tab - -- ('onToggleButtonToggled' will run this handler). - handleAction uiElts vars ( SwitchFromTo mbPrevActiveDocUnique thisTabDocUnique ) - 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 + void $ GTK.onGestureClickReleased pgClicks $ \ nbClicks _x _y -> do + button <- GTK.gestureSingleGetCurrentButton ?self + case button of + 1 -> do + handleAction uiElts vars ( SwitchTo thisTabDocUnique ) + when ( nbClicks > 1 ) do + GTK.editableSetEditable pgLabel True + GTK.editableLabelStartEditing pgLabel + void $ GTK.widgetGrabFocus pgLabel + _ -> return () - GTK.toggleButtonSetActive pgButton False - GTK.toggleButtonSetActive pgButton True + closeButtonClick <- GTK.gestureClickNew + void $ GTK.onGestureClickPressed closeButtonClick $ \ _ _ _ -> do + void $ GTK.gestureSetState ?self GTK.EventSequenceStateClaimed + 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 - void $ GTK.onButtonClicked closeFileButton do - GTK.widgetQueueDraw closeFileArea - handleAction uiElts vars ( CloseThis thisTabDocUnique ) + -- 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 {..} diff --git a/src/app/MetaBrush/UI/Menu.hs b/src/app/MetaBrush/UI/Menu.hs index 4d9865d..83d8be7 100644 --- a/src/app/MetaBrush/UI/Menu.hs +++ b/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 diff --git a/src/app/MetaBrush/UI/StrokeTreeView.hs b/src/app/MetaBrush/UI/StrokeTreeView.hs index ee4e526..eff2ae8 100644 --- a/src/app/MetaBrush/UI/StrokeTreeView.hs +++ b/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