From 53243621b5636d3bcc22a25f1d2d313c3af28c97 Mon Sep 17 00:00:00 2001 From: sheaf Date: Sat, 19 Oct 2024 11:50:05 +0200 Subject: [PATCH] implement stroke list popover menu functionality --- src/app/MetaBrush/Application.hs | 1 - src/app/MetaBrush/Application/Action.hs | 36 +-- src/app/MetaBrush/Application/Action.hs-boot | 8 +- src/app/MetaBrush/Application/Context.hs | 9 +- src/app/MetaBrush/UI/Menu.hs | 87 ++++--- src/app/MetaBrush/UI/StrokeTreeView.hs | 240 +++++++++---------- src/app/MetaBrush/UI/StrokeTreeView.hs-boot | 6 +- src/metabrushes/MetaBrush/Layer.hs | 8 +- 8 files changed, 215 insertions(+), 180 deletions(-) diff --git a/src/app/MetaBrush/Application.hs b/src/app/MetaBrush/Application.hs index 7ca628d..61be6b5 100644 --- a/src/app/MetaBrush/Application.hs +++ b/src/app/MetaBrush/Application.hs @@ -208,7 +208,6 @@ runApplication application = do openDocumentsTVar <- STM.newTVarIO testDocuments strokeListModelsTVar <- STM.newTVarIO Map.empty parStoresTVar <- STM.newTVarIO Map.empty - listModelUpToDateTMVar <- STM.newTMVarIO () mousePosTVar <- STM.newTVarIO Nothing mouseHoldTVar <- STM.newTVarIO Nothing modifiersTVar <- STM.newTVarIO Set.empty diff --git a/src/app/MetaBrush/Application/Action.hs b/src/app/MetaBrush/Application/Action.hs index 3b9c675..fd234b9 100644 --- a/src/app/MetaBrush/Application/Action.hs +++ b/src/app/MetaBrush/Application/Action.hs @@ -115,6 +115,10 @@ import MetaBrush.Application.UpdateDocument import MetaBrush.Asset.WindowIcons ( drawClose ) import MetaBrush.Document.Diff + ( Diff(..) + , HierarchyDiff(..), HistoryDiff(..), ContentDiff(..) + , DragMoveSelect(..), SelectionMode(..) + ) import MetaBrush.Document.History ( DocumentHistory(..), Do(..) , newHistory, back, fwd @@ -136,7 +140,7 @@ import MetaBrush.UI.InfoBar import MetaBrush.UI.FileBar ( newFileTab, removeFileTab ) import MetaBrush.UI.StrokeTreeView - ( applyDeletionToStrokeHierarchy, applyDiffToListModel ) + ( applyDeletionToStrokeHierarchy, applyDiffToListModel, updateLayerHierarchy, DoLayerChange (..), LayerChange (..) ) import MetaBrush.UI.Viewport ( Viewport(..) ) import MetaBrush.Unique @@ -690,29 +694,33 @@ instance HandleAction Delete where -- Delete layer -- ------------------ -data DeleteLayer = DeleteLayer !MetaBrush.Layer.Layer +data DeleteLayer = DeleteLayer !ChildLayer deriving stock Show -instance HandleAction MetaBrush.Application.Action.DeleteLayer where - handleAction - uiElts - vars@( Variables { toolTVar, modeTVar } ) - _ = - return () +instance HandleAction DeleteLayer where + handleAction _ vars + ( DeleteLayer l ) = + updateLayerHierarchy vars $ + DoLayerChange $ + DeleteItems ( NE.singleton l ) --------------- -- New group -- --------------- -data GroupPosition = GroupAbove | GroupBelow | GroupContaining - deriving stock Show - -data NewGroup = NewGroup !GroupPosition !MetaBrush.Layer.Layer +data NewGroup = NewGroup !RelativePosition !ChildLayer deriving stock Show instance HandleAction NewGroup where - handleAction ( UIElements { viewport = Viewport {..} } ) ( Variables { redrawStrokesTVar, showGuidesTVar } ) ( NewGroup pos lay ) = do - return () + handleAction _ vars ( NewGroup pos lay ) = do + u <- Reader.runReaderT freshUnique ( uniqueSupply vars ) + updateLayerHierarchy vars $ + DoLayerChange $ + NewItem + { newUnique = u + , newIsGroup = True + , newPosition = ( lay, pos ) + } ------------------- -- Toggle guides -- diff --git a/src/app/MetaBrush/Application/Action.hs-boot b/src/app/MetaBrush/Application/Action.hs-boot index e74cf5b..d4c2d35 100644 --- a/src/app/MetaBrush/Application/Action.hs-boot +++ b/src/app/MetaBrush/Application/Action.hs-boot @@ -15,11 +15,12 @@ import Data.Text import Math.Linear ( ℝ(..), T(..) ) import MetaBrush.Application.Context +import MetaBrush.Layer + ( ChildLayer, RelativePosition ) import MetaBrush.UI.Viewport ( Ruler(..) ) import MetaBrush.Unique ( Unique ) -import MetaBrush.Layer (Layer) -------------------------------------------------------------------------------- @@ -86,11 +87,10 @@ instance HandleAction Duplicate data Delete = Delete instance HandleAction Delete -data DeleteLayer = DeleteLayer !Layer +data DeleteLayer = DeleteLayer !ChildLayer instance HandleAction DeleteLayer -data GroupPosition = GroupAbove | GroupBelow | GroupContaining -data NewGroup = NewGroup !GroupPosition !Layer +data NewGroup = NewGroup !RelativePosition !ChildLayer instance HandleAction NewGroup data ToggleGuides = ToggleGuides diff --git a/src/app/MetaBrush/Application/Context.hs b/src/app/MetaBrush/Application/Context.hs index 7336a62..5dc5d03 100644 --- a/src/app/MetaBrush/Application/Context.hs +++ b/src/app/MetaBrush/Application/Context.hs @@ -32,8 +32,7 @@ import Data.Hashable ( Hashable ) -- stm -import qualified Control.Concurrent.STM.TVar as STM -import qualified Control.Concurrent.STM.TMVar as STM +import qualified Control.Concurrent.STM as STM -- text import Data.Text @@ -111,10 +110,8 @@ data Variables -- This allows us to know, given a parent and a child index, -- how to insert/delete from the 'GTK.TreeListModel'. , parStoresTVar :: !( STM.TVar ( Map Unique ( Map ( Parent Unique ) GIO.ListStore ) ) ) - - -- | This TMVar is used to ensure that the layer hierarchy data - -- is kept in-sync between the application and the UI's 'GTK.TreeListModel'. - , listModelUpToDateTMVar :: !( STM.TMVar () ) + -- ^ The TMVar is used to ensure that the layer hierarchy data + -- is kept in-sync between the application and the UI's 'GTK.TreeListModel'. , selectedBrushTVar :: !( STM.TVar ( Maybe SomeBrush ) ) diff --git a/src/app/MetaBrush/UI/Menu.hs b/src/app/MetaBrush/UI/Menu.hs index 7a7812c..4d9865d 100644 --- a/src/app/MetaBrush/UI/Menu.hs +++ b/src/app/MetaBrush/UI/Menu.hs @@ -7,6 +7,14 @@ import Control.Monad ( void ) import Data.Foldable ( for_, traverse_ ) +import Data.IORef + ( IORef, newIORef, atomicModifyIORef' ) +import qualified Data.List.NonEmpty as NE +import System.IO.Unsafe + ( unsafePerformIO ) + +-- haskell-gi-base +import qualified Data.GI.Base.Signals as GI -- gi-cairo-connector import qualified GI.Cairo.Render.Connector as Cairo @@ -15,6 +23,9 @@ import qualified GI.Cairo.Render.Connector as Cairo -- gi-gio import qualified GI.Gio as GIO +-- gi-gobject +import qualified GI.GObject as GObject + -- gi-gtk import qualified GI.Gtk as GTK @@ -32,7 +43,7 @@ import Control.Monad.IO.Class import Data.HashMap.Strict ( HashMap ) import qualified Data.HashMap.Strict as HashMap - ( lookup, traverseWithKey ) + ( insert, lookup, traverseWithKey, empty ) import Data.HashSet ( HashSet ) import qualified Data.HashSet as HashSet @@ -48,7 +59,7 @@ import MetaBrush.Asset.WindowIcons import MetaBrush.GTK.Util ( widgetAddClass, widgetAddClasses ) import MetaBrush.Layer - ( Layer(..) ) + ( Layer(..), RelativePosition(..), WithinParent(.. )) -------------------------------------------------------------------------------- -- Types for describing menu items. @@ -93,18 +104,20 @@ menuActionNames = HashSet.fromList , WinAction "about" -- preferences , WinAction "prefs" - -- stroke actions + ] + +strokeMenuActionNames :: HashSet ActionName +strokeMenuActionNames = HashSet.fromList + [ WinAction "deleteLayer" , WinAction "newGroupAbove" , WinAction "newGroupBelow" - , WinAction "newGroupContaining" - , WinAction "deleteLayer" ] createMenuActions :: IO ( HashMap ActionName GIO.SimpleAction ) createMenuActions = HashMap.traverseWithKey ( \ actionName _ -> GIO.simpleActionNew ( actionSimpleName actionName ) Nothing ) - ( HashSet.toMap menuActionNames ) + ( HashSet.toMap menuActionNames <> HashSet.toMap strokeMenuActionNames ) -------------------------------------------------------------------------------- -- Menu used in MetaBrush. @@ -171,21 +184,26 @@ helpMenuDescription = [ MenuItemDescription "About MetaBrush" ( Just $ WinAction "about", About ) ( Just "question" ) ] -strokeMenuDescription :: Layer -> [ MenuItem ] -strokeMenuDescription lay = +strokeMenuDescription :: WithinParent Layer -> [ MenuItem ] +strokeMenuDescription item@( WithinParent _ lay ) = [ case lay of - StrokeLayer {} -> MenuItemDescription "Delete stroke" ( Nothing, DeleteLayer lay) Nothing - GroupLayer {} -> MenuItemDescription "Delete group" ( Nothing, DeleteLayer lay) Nothing + StrokeLayer {} -> MenuItemDescription "Delete stroke" ( Just $ WinAction "deleteLayer", DeleteLayer child ) Nothing + GroupLayer {} -> MenuItemDescription "Delete group" ( Just $ WinAction "deleteLayer", DeleteLayer child ) Nothing , Section ( Just "New group" ) $ - [ MenuItemDescription "...above" ( Nothing, NewGroup GroupAbove lay ) Nothing - , MenuItemDescription "...containing" ( Nothing, NewGroup GroupContaining lay ) Nothing - , MenuItemDescription "...below" ( Nothing, NewGroup GroupBelow lay ) Nothing + [ MenuItemDescription "...above" ( Just $ WinAction "newGroupAbove", NewGroup Above child ) Nothing + , MenuItemDescription "...below" ( Just $ WinAction "newGroupBelow", NewGroup Below child ) Nothing ] ] + where + child = fmap layerUnique item -------------------------------------------------------------------------------- -- Creating a GTK popover menu bar from a menu description. +{-# NOINLINE previousActions #-} +previousActions :: IORef ( HashMap Text ( NE.NonEmpty GI.SignalHandlerId ) ) +previousActions = unsafePerformIO $ newIORef HashMap.empty + makeMenu :: MonadIO m => UIElements -> Variables -> GIO.Menu -> [ MenuItem ] -> m () makeMenu uiElts@( UIElements { application, window, menuActions } ) vars menu = traverse_ \case SubmenuDescription @@ -200,23 +218,32 @@ makeMenu uiElts@( UIElements { application, window, menuActions } ) vars menu = , menuItemAction = ( mbActionName, actionData ) , menuItemAccel } -> do - for_ mbActionName \ actionName -> do - let - simpleName :: Text - simpleName = actionSimpleName actionName - case HashMap.lookup actionName menuActions of - Nothing -> - error - ( "Could not create menu item labelled " <> Text.unpack menuItemLabel <> - ": missing action " <> show actionName - ) - Just menuItemAction -> do - _ <- GIO.onSimpleActionActivate menuItemAction - ( \ _ -> handleAction uiElts vars actionData ) - GIO.actionMapAddAction window menuItemAction - for_ menuItemAccel \ accelText -> do - actionDetailedName <- GIO.actionPrintDetailedName simpleName Nothing - GTK.applicationSetAccelsForAction application ( actionPrefix actionName <> actionDetailedName ) [accelText] + for_ mbActionName $ \ actionName -> do + let + simpleName :: Text + simpleName = actionSimpleName actionName + case HashMap.lookup actionName menuActions of + Nothing -> + error + ( "Could not create menu item labelled " <> Text.unpack menuItemLabel <> + ": missing action " <> show actionName + ) + Just menuItemAction -> do + -- Un-register any previously registered actions. + -- (For stroke menu actions in which we create a new set of actions + -- each time the popover menu pop ups.) + signalId + <- GIO.onSimpleActionActivate menuItemAction + ( \ _ -> handleAction uiElts vars actionData ) + prevActions <- liftIO $ atomicModifyIORef' previousActions $ \ oldActionsMap -> + let old = HashMap.lookup simpleName oldActionsMap + in ( HashMap.insert simpleName ( NE.singleton signalId ) oldActionsMap, maybe [] NE.toList old ) + for_ prevActions $ GObject.signalHandlerDisconnect menuItemAction + GIO.actionMapRemoveAction window simpleName + GIO.actionMapAddAction window menuItemAction + for_ menuItemAccel \ accelText -> do + actionDetailedName <- GIO.actionPrintDetailedName simpleName Nothing + GTK.applicationSetAccelsForAction application ( actionPrefix actionName <> actionDetailedName ) [accelText] menuItem <- GIO.menuItemNew ( Just menuItemLabel ) ( fmap ( \ name -> actionPrefix name <> actionSimpleName name ) mbActionName ) GIO.menuAppendItem menu menuItem Section diff --git a/src/app/MetaBrush/UI/StrokeTreeView.hs b/src/app/MetaBrush/UI/StrokeTreeView.hs index 18123e9..2f6ece6 100644 --- a/src/app/MetaBrush/UI/StrokeTreeView.hs +++ b/src/app/MetaBrush/UI/StrokeTreeView.hs @@ -8,11 +8,13 @@ module MetaBrush.UI.StrokeTreeView ( newLayersListModel , newLayerView , switchStrokeView + , updateLayerHierarchy , applyDeletionToStrokeHierarchy , applyChangeToLayerHierarchy , applyDiffToListModel , getSelectedItem , DragSourceData(..) + , DoLayerChange(..), LayerChange(..) ) where @@ -20,7 +22,7 @@ module MetaBrush.UI.StrokeTreeView import Control.Arrow ( second ) import Control.Monad - ( unless, void, when ) + ( unless, void ) import Data.Foldable ( for_ ) import Data.List @@ -33,7 +35,6 @@ import Data.Traversable import Data.Word ( Word32 ) import GHC.Stack - ( HasCallStack ) -- containers import Data.Map.Strict @@ -49,6 +50,9 @@ import Data.Generics.Product.Fields -- gi-gdk import qualified GI.Gdk as GDK +-- gi-glib +import qualified GI.GLib as GLib + -- gi-gio import qualified GI.Gio as GIO @@ -70,9 +74,7 @@ import Control.Lens ( over ) -- stm -import qualified Control.Concurrent.STM.TVar as STM -import qualified Control.Concurrent.STM.TMVar as STM -import qualified Control.Monad.STM as STM +import qualified Control.Concurrent.STM as STM -- text import Data.Text @@ -96,7 +98,6 @@ import MetaBrush.Unique import MetaBrush.UI.Menu ( strokeMenuDescription, makeMenu ) - -------------------------------------------------------------------------------- -- | Custom GTK object used to hold layer data. @@ -225,13 +226,9 @@ newLayersListModel ( Variables { .. } ) docUnique = do mbOldChildStore <- STM.atomically $ do parStores <- STM.readTVar parStoresTVar - let mbOldStore = - Map.lookup ( Parent groupUnique ) =<< Map.lookup docUnique parStores - when ( isNothing mbOldStore ) $ - -- Take a lock to avoid creating multiple child stores - -- for the same group. - STM.takeTMVar listModelUpToDateTMVar - return mbOldStore + return $ + Map.lookup ( Parent groupUnique ) + =<< Map.lookup docUnique parStores newChildStore <- case mbOldChildStore of @@ -258,8 +255,6 @@ newLayersListModel ( Variables { .. } ) docUnique = do STM.atomically $ do STM.modifyTVar parStoresTVar ( Map.insertWith Map.union docUnique ( Map.singleton ( Parent groupUnique ) childStore ) ) - STM.putTMVar listModelUpToDateTMVar () - return childStore -- Pass a copy of the (reference to the) child store @@ -469,11 +464,16 @@ newLayerView uiElts@( UIElements { window } ) vars = mdo -- void $ GTK.widgetGrabFocus label | button == 3 -> do + mbTreeListRow <- traverse ( GTK.unsafeCastTo GTK.TreeListRow ) =<< GTK.listItemGetItem listItem + treeListRow <- case mbTreeListRow of + Nothing -> error "newLayerView ListItem onSetup: no TreeListRow" + Just r -> return r + srcPar <- fmap snd <$> getParent treeListRow GTK.widgetUnparent layerPopover GTK.widgetSetParent layerPopover expander layer <- getLayerData listItem GIO.menuRemoveAll layerMenu - makeMenu uiElts vars layerMenu ( strokeMenuDescription layer ) + makeMenu uiElts vars layerMenu ( strokeMenuDescription ( WithinParent srcPar layer ) ) GTK.popoverMenuSetMenuModel layerPopover ( Just layerMenu ) rect <- GDK.newZeroRectangle GDK.setRectangleX rect ( round x ) @@ -617,7 +617,7 @@ newLayerView uiElts@( UIElements { window } ) vars = mdo updateLayerHierarchy vars $ DoLayerChange $ SetBrush - { setBrushStroke = WithinParent ( fmap snd dstPar ) tgtStrokeUnique + { setBrushStroke = WithinParent ( fmap snd dstPar ) tgtStrokeUnique , setBrushName = brushName } return True @@ -626,14 +626,16 @@ newLayerView uiElts@( UIElements { window } ) vars = mdo let dropTgtUniq = layerUnique dropTgt dstFlatIndex <- GTK.treeListRowGetPosition treeListRow h <- GTK.widgetGetHeight expander - let droppedAbove = y < 0.5 * fromIntegral h + let dropRelPos = if y < 0.5 * fromIntegral h + then Above + else Below expanded <- GTK.treeListRowGetExpanded treeListRow isDescendant <- isDescendantOf dragSrcUniq listItem let mbDropIntoGroup | expanded - , not droppedAbove + , Below <- dropRelPos , not isDescendant = Just treeListRow | otherwise @@ -641,7 +643,7 @@ newLayerView uiElts@( UIElements { window } ) vars = mdo mbDropOutsideGroup | dragSrcUniq == dropTgtUniq , Parent par <- dstPar - , not droppedAbove + , Below <- dropRelPos = Just par | otherwise = Nothing @@ -691,9 +693,11 @@ newLayerView uiElts@( UIElements { window } ) vars = mdo { parent = fmap snd dstPar , item = dropTgtUniq } - , moveAbove = droppedAbove + , moveRelPos = dropRelPos } - , if droppedAbove then dstFlatIndex else dstFlatIndex + 1 + , case dropRelPos of + Above -> dstFlatIndex + Below -> dstFlatIndex + 1 ) -- Compute the position that the item we are moving will have @@ -957,7 +961,7 @@ data LayerChange | NewItem { newUnique :: !Unique , newIsGroup :: !Bool - , newSelected :: !( Maybe ChildLayer ) + , newPosition :: !( ChildLayer, RelativePosition ) } | DeleteItems { deleteItems :: !( NE.NonEmpty ChildLayer ) @@ -985,7 +989,7 @@ data MoveDst -- | Move an item above or below another item. | MoveAboveOrBelow { moveDstItem :: !ChildLayer - , moveAbove :: !Bool + , moveRelPos :: !RelativePosition -- ^ Whether to move above or below the destination. } @@ -994,91 +998,85 @@ data MoveDst -- | Update the layer hierarchy, keeping both the application state and -- the GTK ListModel in sync. updateLayerHierarchy :: Variables -> DoLayerChange -> IO () -updateLayerHierarchy - vars@( Variables { parStoresTVar, listModelUpToDateTMVar } ) - doOrUndo = do - mbDiff <- STM.atomically $ do +updateLayerHierarchy vars@( Variables { parStoresTVar } ) doOrUndo = do + mbDiff <- STM.atomically $ do - -- Ensure the GTK ListModel is up to date before continuing - -- (just a precaution). - STM.takeTMVar listModelUpToDateTMVar + -- TODO: need to use 'modifyingCurrentDocument' in some form, + -- but that function doesn't permit modifying history. - -- TODO: need to use 'modifyingCurrentDocument' in some form, - -- but that function doesn't permit modifying history. + mbActiveDoc <- activeDocument vars + ( mbNewHist, mbDiff ) <- + case mbActiveDoc of + Nothing -> return ( Nothing, Nothing) + Just ( activeDocUnique, History past ( Document oldPresent oldMeta ) future ) -> do + let oldHierarchy = strokeHierarchy oldPresent + case doOrUndo of + DoLayerChange change -> do + let !( !hierarchy', !newNames, mbDiff ) = applyChangeToLayerHierarchy change oldHierarchy + !content' = oldPresent { strokeHierarchy = hierarchy' } + !meta' = over ( field' @"layerMetadata" . field' @"layerNames" ) ( newNames <> ) oldMeta + !( !history', mbDoOrUndo ) = + case mbDiff of + Nothing -> + ( History + { past = past + , present = Document content' meta' + , future = future + } + , Nothing ) + Just diff -> + ( History + { past = past Seq.:|> ( oldPresent, HierarchyDiff diff ) + , present = Document content' meta' + , future = [] + } + , Just ( Do, diff ) ) + return ( Just ( activeDocUnique, history' ), mbDoOrUndo ) + UndoChange -> case past of + past' Seq.:|> ( present', diff ) -> do + let !history' = + History + { past = past' + , present = Document present' oldMeta + , future = ( diff, oldPresent ) : future + } + return + ( Just ( activeDocUnique, history' ) + , case diff of + HierarchyDiff hDiff -> + Just ( Undo, hDiff ) + _ -> Nothing + ) + Seq.Empty -> + return ( Nothing, Nothing ) + RedoChange -> case future of + ( diff, present' ) : future' -> do + let history' = + History + { past = past Seq.:|> ( oldPresent, diff ) + , present = Document present' oldMeta + , future = future' + } + return + ( Just ( activeDocUnique, history' ) + , case diff of + HierarchyDiff hDiff -> + Just ( Do, hDiff ) + _ -> Nothing + ) + [] -> + return ( Nothing, Nothing ) - mbActiveDoc <- activeDocument vars - ( mbNewHist, mbDiff ) <- - case mbActiveDoc of - Nothing -> return ( Nothing, Nothing) - Just ( activeDocUnique, History past ( Document oldPresent oldMeta ) future ) -> do - let oldHierarchy = strokeHierarchy oldPresent - case doOrUndo of - DoLayerChange change -> do - let !( !hierarchy', !newNames, mbDiff ) = applyChangeToLayerHierarchy change oldHierarchy - !content' = oldPresent { strokeHierarchy = hierarchy' } - !meta' = over ( field' @"layerMetadata" . field' @"layerNames" ) ( newNames <> ) oldMeta - !( !history', mbDoOrUndo ) = - case mbDiff of - Nothing -> - ( History - { past = past - , present = Document content' meta' - , future = future - } - , Nothing ) - Just diff -> - ( History - { past = past Seq.:|> ( oldPresent, HierarchyDiff diff ) - , present = Document content' meta' - , future = [] - } - , Just ( Do, diff ) ) - return ( Just ( activeDocUnique, history' ), mbDoOrUndo ) - UndoChange -> case past of - past' Seq.:|> ( present', diff ) -> do - let !history' = - History - { past = past' - , present = Document present' oldMeta - , future = ( diff, oldPresent ) : future - } - return - ( Just ( activeDocUnique, history' ) - , case diff of - HierarchyDiff hDiff -> - Just ( Undo, hDiff ) - _ -> Nothing - ) - Seq.Empty -> - return ( Nothing, Nothing ) - RedoChange -> case future of - ( diff, present' ) : future' -> do - let history' = - History - { past = past Seq.:|> ( oldPresent, diff ) - , present = Document present' oldMeta - , future = future' - } - return - ( Just ( activeDocUnique, history' ) - , case diff of - HierarchyDiff hDiff -> - Just ( Do, hDiff ) - _ -> Nothing - ) - [] -> - return ( Nothing, Nothing ) + for_ mbNewHist $ \ ( activeDoc, hist ) -> do + STM.modifyTVar' ( openDocumentsTVar vars ) ( Map.insert activeDoc hist ) + STM.writeTVar ( redrawStrokesTVar vars ) True + return $ ( , ) <$> ( fst <$> mbNewHist ) <*> mbDiff - for_ mbNewHist $ \ ( activeDoc, hist ) -> do - STM.modifyTVar' ( openDocumentsTVar vars ) ( Map.insert activeDoc hist ) - STM.writeTVar ( redrawStrokesTVar vars ) True - return $ ( , ) <$> ( fst <$> mbNewHist ) <*> mbDiff - - for_ mbDiff $ \ ( docUnique, diff ) -> + for_ mbDiff $ \ ( docUnique, diff ) -> + GLib.idleAdd GLib.PRIORITY_HIGH_IDLE $ do applyDiffToListModel parStoresTVar docUnique diff + return False - STM.atomically $ - STM.writeTMVar listModelUpToDateTMVar () -- | Apply a change to the application layer hierarchy. @@ -1093,11 +1091,11 @@ applyChangeToLayerHierarchy change hierarchy = let mbDst = case moveDst of MoveAboveOrBelow - { moveAbove + { moveRelPos , moveDstItem = WithinParent parUniq tgtUniq } -> Just ( parUniq - , Just ( tgtUniq , moveAbove ) + , Just ( tgtUniq , moveRelPos ) ) MoveToTopOfGroup { dstParUnique } -> @@ -1118,7 +1116,7 @@ applyChangeToLayerHierarchy change hierarchy = | otherwise = False , not expandedGroupWithChildren - -> Just ( grandParentUnique, Just ( parentUnique, False ) ) + -> Just ( grandParentUnique, Just ( parentUnique, Below ) ) | otherwise -> Nothing in case mbDst of @@ -1143,14 +1141,9 @@ applyChangeToLayerHierarchy change hierarchy = } Nothing -> Nothing ) - NewItem { newUnique = u, newIsGroup, newSelected } -> - let ( dstParUniq, dstChild ) = case newSelected of - Nothing -> ( Root, Nothing ) - Just ( WithinParent { parent = par, item = dstUniq } ) -> - -- TODO: this means we always create a new item **above** the - -- selected item. It would make sense to customise this. - ( par, Just ( dstUniq, True ) ) - !( !hierarchy', dstChildIx ) = insertLayerIntoParent hierarchy ( dstParUniq, dstChild ) u + NewItem { newUnique = u, newIsGroup, newPosition = ( WithinParent dstParUniq childUniq, relPos ) } -> + let dropPos = Just ( childUniq, relPos ) + !( !hierarchy', dstChildIx ) = insertLayerIntoParent hierarchy ( dstParUniq, dropPos ) u !hierarchy'' = if newIsGroup then insertGroup ( Parent u ) [] hierarchy' @@ -1228,7 +1221,8 @@ applyDeletionToStrokeHierarchy hierarchy0 = go hierarchy0 -- -- The change to the application 'StrokeHierarchy' is done beforehand, -- in 'applyChangeToLayerHierarchy'. -applyDiffToListModel :: STM.TVar ( Map Unique ( Map ( Parent Unique ) GIO.ListStore ) ) +applyDiffToListModel :: HasCallStack + => STM.TVar ( Map Unique ( Map ( Parent Unique ) GIO.ListStore ) ) -> Unique -> ( Do, HierarchyDiff ) -> IO () @@ -1287,7 +1281,7 @@ applyDiffToListModel parStoreTVar docUnique ( doOrUndo, diff ) = do Just item -> do GIO.listStoreRemove dstStore dstIx GIO.listStoreInsert srcStore srcIx item - NewLayer { newPosition = WithinParent dstPar dstIx, newUnique, newIsGroup } -> + NewLayer { newPosition = WithinParent dstPar dstIx, newUnique, newIsGroup } -> do case Map.lookup dstPar parStoreFromUniq of Nothing -> putStrLn $ unlines @@ -1372,7 +1366,7 @@ sequentialOn f ( a NE.:| as ) = go ( f a ) as moveLayerUpdate :: ( Parent Unique, Unique ) -- ^ source - -> ( Parent Unique, Maybe ( Unique, Bool ) ) + -> ( Parent Unique, Maybe ( Unique, RelativePosition ) ) -- ^ destination -- -- - @Nothing@: drop as first element of group @@ -1423,7 +1417,7 @@ removeLayerFromParent hierarchy ( parent, u ) = -- -- NB: does not add the layer itself. insertLayerIntoParent :: StrokeHierarchy - -> ( Parent Unique, Maybe ( Unique, Bool ) ) + -> ( Parent Unique, Maybe ( Unique, RelativePosition ) ) -- ^ destination -- -- - @Nothing@: drop as first element of group @@ -1441,12 +1435,12 @@ insertLayerIntoParent hierarchy ( newPar, mbTgtUniq ) srcUniq = , 0 ) -- Drop (before or after) given child. - Just ( tgtUniq, dropAbove ) -> + Just ( tgtUniq, dropRelPos ) -> let ( bef, aft ) = break ( == tgtUniq ) $ filter ( /= srcUniq ) newPar_oldCs - in ( if dropAbove - then bef ++ [ srcUniq ] ++ aft - else bef ++ take 1 aft ++ [ srcUniq ] ++ drop 1 aft + in ( case dropRelPos of + Above -> bef ++ [ srcUniq ] ++ aft + Below -> bef ++ take 1 aft ++ [ srcUniq ] ++ drop 1 aft , fromIntegral ( length ( takeWhile ( /= tgtUniq ) $ newPar_oldCs ) ) - + if dropAbove then 0 else 1 + + case dropRelPos of { Above -> 0; Below -> 1 } ) in ( insertGroup newPar newPar_newCs hierarchy, newChildPos ) diff --git a/src/app/MetaBrush/UI/StrokeTreeView.hs-boot b/src/app/MetaBrush/UI/StrokeTreeView.hs-boot index 6aec8c4..7076b95 100644 --- a/src/app/MetaBrush/UI/StrokeTreeView.hs-boot +++ b/src/app/MetaBrush/UI/StrokeTreeView.hs-boot @@ -1,5 +1,8 @@ module MetaBrush.UI.StrokeTreeView where +-- base +import GHC.Stack + -- containers import Data.Map.Strict ( Map ) @@ -28,7 +31,8 @@ switchStrokeView :: GTK.ListView -> Variables -> Maybe Unique -> IO () newLayerView :: UIElements -> Variables -> IO GTK.ListView -applyDiffToListModel :: STM.TVar ( Map Unique ( Map ( Parent Unique ) GIO.ListStore ) ) +applyDiffToListModel :: HasCallStack + => STM.TVar ( Map Unique ( Map ( Parent Unique ) GIO.ListStore ) ) -> Unique -> ( Do, HierarchyDiff ) -> IO () diff --git a/src/metabrushes/MetaBrush/Layer.hs b/src/metabrushes/MetaBrush/Layer.hs index 84da821..6a1d28f 100644 --- a/src/metabrushes/MetaBrush/Layer.hs +++ b/src/metabrushes/MetaBrush/Layer.hs @@ -64,7 +64,7 @@ data WithinParent a = { parent :: !( Parent Unique ) , item :: !a } - deriving stock ( Show, Eq, Generic ) + deriving stock ( Show, Eq, Generic, Functor ) deriving anyclass NFData -- | A child layer within a parent. @@ -72,6 +72,12 @@ type ChildLayer = WithinParent Unique -- | A child layer, with its index among the list of children of its parent. type ChildLayerPosition = WithinParent Word32 +-- | Where to position something relative to another layer. +data RelativePosition + = Above + | Below + deriving stock ( Eq, Ord, Show ) + -- | Content in a hierarchical tree-like structure. data Hierarchy a = Hierarchy