allow document titles to be edited

This commit is contained in:
sheaf 2024-10-21 14:58:53 +02:00
parent 71f42894f8
commit 6ecfebd397
9 changed files with 170 additions and 154 deletions

View file

@ -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;

View file

@ -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 --

View file

@ -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

View file

@ -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
}

View file

@ -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 )

View file

@ -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

View file

@ -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
void $ GTK.onButtonClicked closeFileButton do
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
-- 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 {..}

View file

@ -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

View file

@ -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