implement stroke list popover menu functionality

This commit is contained in:
sheaf 2024-10-19 11:50:05 +02:00
parent 27269809e7
commit 53243621b5
8 changed files with 215 additions and 180 deletions

View file

@ -208,7 +208,6 @@ runApplication application = do
openDocumentsTVar <- STM.newTVarIO testDocuments openDocumentsTVar <- STM.newTVarIO testDocuments
strokeListModelsTVar <- STM.newTVarIO Map.empty strokeListModelsTVar <- STM.newTVarIO Map.empty
parStoresTVar <- STM.newTVarIO Map.empty parStoresTVar <- STM.newTVarIO Map.empty
listModelUpToDateTMVar <- STM.newTMVarIO ()
mousePosTVar <- STM.newTVarIO Nothing mousePosTVar <- STM.newTVarIO Nothing
mouseHoldTVar <- STM.newTVarIO Nothing mouseHoldTVar <- STM.newTVarIO Nothing
modifiersTVar <- STM.newTVarIO Set.empty modifiersTVar <- STM.newTVarIO Set.empty

View file

@ -115,6 +115,10 @@ import MetaBrush.Application.UpdateDocument
import MetaBrush.Asset.WindowIcons import MetaBrush.Asset.WindowIcons
( drawClose ) ( drawClose )
import MetaBrush.Document.Diff import MetaBrush.Document.Diff
( Diff(..)
, HierarchyDiff(..), HistoryDiff(..), ContentDiff(..)
, DragMoveSelect(..), SelectionMode(..)
)
import MetaBrush.Document.History import MetaBrush.Document.History
( DocumentHistory(..), Do(..) ( DocumentHistory(..), Do(..)
, newHistory, back, fwd , newHistory, back, fwd
@ -136,7 +140,7 @@ import MetaBrush.UI.InfoBar
import MetaBrush.UI.FileBar import MetaBrush.UI.FileBar
( newFileTab, removeFileTab ) ( newFileTab, removeFileTab )
import MetaBrush.UI.StrokeTreeView import MetaBrush.UI.StrokeTreeView
( applyDeletionToStrokeHierarchy, applyDiffToListModel ) ( applyDeletionToStrokeHierarchy, applyDiffToListModel, updateLayerHierarchy, DoLayerChange (..), LayerChange (..) )
import MetaBrush.UI.Viewport import MetaBrush.UI.Viewport
( Viewport(..) ) ( Viewport(..) )
import MetaBrush.Unique import MetaBrush.Unique
@ -690,29 +694,33 @@ instance HandleAction Delete where
-- Delete layer -- -- Delete layer --
------------------ ------------------
data DeleteLayer = DeleteLayer !MetaBrush.Layer.Layer data DeleteLayer = DeleteLayer !ChildLayer
deriving stock Show deriving stock Show
instance HandleAction MetaBrush.Application.Action.DeleteLayer where instance HandleAction DeleteLayer where
handleAction handleAction _ vars
uiElts ( DeleteLayer l ) =
vars@( Variables { toolTVar, modeTVar } ) updateLayerHierarchy vars $
_ = DoLayerChange $
return () DeleteItems ( NE.singleton l )
--------------- ---------------
-- New group -- -- New group --
--------------- ---------------
data GroupPosition = GroupAbove | GroupBelow | GroupContaining data NewGroup = NewGroup !RelativePosition !ChildLayer
deriving stock Show
data NewGroup = NewGroup !GroupPosition !MetaBrush.Layer.Layer
deriving stock Show deriving stock Show
instance HandleAction NewGroup where instance HandleAction NewGroup where
handleAction ( UIElements { viewport = Viewport {..} } ) ( Variables { redrawStrokesTVar, showGuidesTVar } ) ( NewGroup pos lay ) = do handleAction _ vars ( NewGroup pos lay ) = do
return () u <- Reader.runReaderT freshUnique ( uniqueSupply vars )
updateLayerHierarchy vars $
DoLayerChange $
NewItem
{ newUnique = u
, newIsGroup = True
, newPosition = ( lay, pos )
}
------------------- -------------------
-- Toggle guides -- -- Toggle guides --

View file

@ -15,11 +15,12 @@ import Data.Text
import Math.Linear import Math.Linear
( (..), T(..) ) ( (..), T(..) )
import MetaBrush.Application.Context import MetaBrush.Application.Context
import MetaBrush.Layer
( ChildLayer, RelativePosition )
import MetaBrush.UI.Viewport import MetaBrush.UI.Viewport
( Ruler(..) ) ( Ruler(..) )
import MetaBrush.Unique import MetaBrush.Unique
( Unique ) ( Unique )
import MetaBrush.Layer (Layer)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -86,11 +87,10 @@ instance HandleAction Duplicate
data Delete = Delete data Delete = Delete
instance HandleAction Delete instance HandleAction Delete
data DeleteLayer = DeleteLayer !Layer data DeleteLayer = DeleteLayer !ChildLayer
instance HandleAction DeleteLayer instance HandleAction DeleteLayer
data GroupPosition = GroupAbove | GroupBelow | GroupContaining data NewGroup = NewGroup !RelativePosition !ChildLayer
data NewGroup = NewGroup !GroupPosition !Layer
instance HandleAction NewGroup instance HandleAction NewGroup
data ToggleGuides = ToggleGuides data ToggleGuides = ToggleGuides

View file

@ -32,8 +32,7 @@ import Data.Hashable
( Hashable ) ( Hashable )
-- stm -- stm
import qualified Control.Concurrent.STM.TVar as STM import qualified Control.Concurrent.STM as STM
import qualified Control.Concurrent.STM.TMVar as STM
-- text -- text
import Data.Text import Data.Text
@ -111,10 +110,8 @@ data Variables
-- This allows us to know, given a parent and a child index, -- This allows us to know, given a parent and a child index,
-- how to insert/delete from the 'GTK.TreeListModel'. -- how to insert/delete from the 'GTK.TreeListModel'.
, parStoresTVar :: !( STM.TVar ( Map Unique ( Map ( Parent Unique ) GIO.ListStore ) ) ) , parStoresTVar :: !( STM.TVar ( Map Unique ( Map ( Parent Unique ) GIO.ListStore ) ) )
-- ^ The TMVar is used to ensure that the layer hierarchy data
-- | This TMVar is used to ensure that the layer hierarchy data -- is kept in-sync between the application and the UI's 'GTK.TreeListModel'.
-- is kept in-sync between the application and the UI's 'GTK.TreeListModel'.
, listModelUpToDateTMVar :: !( STM.TMVar () )
, selectedBrushTVar :: !( STM.TVar ( Maybe SomeBrush ) ) , selectedBrushTVar :: !( STM.TVar ( Maybe SomeBrush ) )

View file

@ -7,6 +7,14 @@ import Control.Monad
( void ) ( void )
import Data.Foldable import Data.Foldable
( for_, traverse_ ) ( 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 -- gi-cairo-connector
import qualified GI.Cairo.Render.Connector as Cairo import qualified GI.Cairo.Render.Connector as Cairo
@ -15,6 +23,9 @@ import qualified GI.Cairo.Render.Connector as Cairo
-- gi-gio -- gi-gio
import qualified GI.Gio as GIO import qualified GI.Gio as GIO
-- gi-gobject
import qualified GI.GObject as GObject
-- gi-gtk -- gi-gtk
import qualified GI.Gtk as GTK import qualified GI.Gtk as GTK
@ -32,7 +43,7 @@ import Control.Monad.IO.Class
import Data.HashMap.Strict import Data.HashMap.Strict
( HashMap ) ( HashMap )
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
( lookup, traverseWithKey ) ( insert, lookup, traverseWithKey, empty )
import Data.HashSet import Data.HashSet
( HashSet ) ( HashSet )
import qualified Data.HashSet as HashSet import qualified Data.HashSet as HashSet
@ -48,7 +59,7 @@ import MetaBrush.Asset.WindowIcons
import MetaBrush.GTK.Util import MetaBrush.GTK.Util
( widgetAddClass, widgetAddClasses ) ( widgetAddClass, widgetAddClasses )
import MetaBrush.Layer import MetaBrush.Layer
( Layer(..) ) ( Layer(..), RelativePosition(..), WithinParent(.. ))
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Types for describing menu items. -- Types for describing menu items.
@ -93,18 +104,20 @@ menuActionNames = HashSet.fromList
, WinAction "about" , WinAction "about"
-- preferences -- preferences
, WinAction "prefs" , WinAction "prefs"
-- stroke actions ]
strokeMenuActionNames :: HashSet ActionName
strokeMenuActionNames = HashSet.fromList
[ WinAction "deleteLayer"
, WinAction "newGroupAbove" , WinAction "newGroupAbove"
, WinAction "newGroupBelow" , WinAction "newGroupBelow"
, WinAction "newGroupContaining"
, WinAction "deleteLayer"
] ]
createMenuActions :: IO ( HashMap ActionName GIO.SimpleAction ) createMenuActions :: IO ( HashMap ActionName GIO.SimpleAction )
createMenuActions = createMenuActions =
HashMap.traverseWithKey HashMap.traverseWithKey
( \ actionName _ -> GIO.simpleActionNew ( actionSimpleName actionName ) Nothing ) ( \ actionName _ -> GIO.simpleActionNew ( actionSimpleName actionName ) Nothing )
( HashSet.toMap menuActionNames ) ( HashSet.toMap menuActionNames <> HashSet.toMap strokeMenuActionNames )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Menu used in MetaBrush. -- Menu used in MetaBrush.
@ -171,21 +184,26 @@ helpMenuDescription =
[ MenuItemDescription "About MetaBrush" ( Just $ WinAction "about", About ) ( Just "<Ctrl>question" ) [ MenuItemDescription "About MetaBrush" ( Just $ WinAction "about", About ) ( Just "<Ctrl>question" )
] ]
strokeMenuDescription :: Layer -> [ MenuItem ] strokeMenuDescription :: WithinParent Layer -> [ MenuItem ]
strokeMenuDescription lay = strokeMenuDescription item@( WithinParent _ lay ) =
[ case lay of [ case lay of
StrokeLayer {} -> MenuItemDescription "Delete stroke" ( Nothing, DeleteLayer lay) Nothing StrokeLayer {} -> MenuItemDescription "Delete stroke" ( Just $ WinAction "deleteLayer", DeleteLayer child ) Nothing
GroupLayer {} -> MenuItemDescription "Delete group" ( Nothing, DeleteLayer lay) Nothing GroupLayer {} -> MenuItemDescription "Delete group" ( Just $ WinAction "deleteLayer", DeleteLayer child ) Nothing
, Section ( Just "New group" ) $ , Section ( Just "New group" ) $
[ MenuItemDescription "...above" ( Nothing, NewGroup GroupAbove lay ) Nothing [ MenuItemDescription "...above" ( Just $ WinAction "newGroupAbove", NewGroup Above child ) Nothing
, MenuItemDescription "...containing" ( Nothing, NewGroup GroupContaining lay ) Nothing , MenuItemDescription "...below" ( Just $ WinAction "newGroupBelow", NewGroup Below child ) Nothing
, MenuItemDescription "...below" ( Nothing, NewGroup GroupBelow lay ) Nothing
] ]
] ]
where
child = fmap layerUnique item
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Creating a GTK popover menu bar from a menu description. -- 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 :: MonadIO m => UIElements -> Variables -> GIO.Menu -> [ MenuItem ] -> m ()
makeMenu uiElts@( UIElements { application, window, menuActions } ) vars menu = traverse_ \case makeMenu uiElts@( UIElements { application, window, menuActions } ) vars menu = traverse_ \case
SubmenuDescription SubmenuDescription
@ -200,23 +218,32 @@ makeMenu uiElts@( UIElements { application, window, menuActions } ) vars menu =
, menuItemAction = ( mbActionName, actionData ) , menuItemAction = ( mbActionName, actionData )
, menuItemAccel , menuItemAccel
} -> do } -> do
for_ mbActionName \ actionName -> do for_ mbActionName $ \ actionName -> do
let let
simpleName :: Text simpleName :: Text
simpleName = actionSimpleName actionName simpleName = actionSimpleName actionName
case HashMap.lookup actionName menuActions of case HashMap.lookup actionName menuActions of
Nothing -> Nothing ->
error error
( "Could not create menu item labelled " <> Text.unpack menuItemLabel <> ( "Could not create menu item labelled " <> Text.unpack menuItemLabel <>
": missing action " <> show actionName ": missing action " <> show actionName
) )
Just menuItemAction -> do Just menuItemAction -> do
_ <- GIO.onSimpleActionActivate menuItemAction -- Un-register any previously registered actions.
( \ _ -> handleAction uiElts vars actionData ) -- (For stroke menu actions in which we create a new set of actions
GIO.actionMapAddAction window menuItemAction -- each time the popover menu pop ups.)
for_ menuItemAccel \ accelText -> do signalId
actionDetailedName <- GIO.actionPrintDetailedName simpleName Nothing <- GIO.onSimpleActionActivate menuItemAction
GTK.applicationSetAccelsForAction application ( actionPrefix actionName <> actionDetailedName ) [accelText] ( \ _ -> 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 ) menuItem <- GIO.menuItemNew ( Just menuItemLabel ) ( fmap ( \ name -> actionPrefix name <> actionSimpleName name ) mbActionName )
GIO.menuAppendItem menu menuItem GIO.menuAppendItem menu menuItem
Section Section

View file

@ -8,11 +8,13 @@ module MetaBrush.UI.StrokeTreeView
( newLayersListModel ( newLayersListModel
, newLayerView , newLayerView
, switchStrokeView , switchStrokeView
, updateLayerHierarchy
, applyDeletionToStrokeHierarchy , applyDeletionToStrokeHierarchy
, applyChangeToLayerHierarchy , applyChangeToLayerHierarchy
, applyDiffToListModel , applyDiffToListModel
, getSelectedItem , getSelectedItem
, DragSourceData(..) , DragSourceData(..)
, DoLayerChange(..), LayerChange(..)
) )
where where
@ -20,7 +22,7 @@ module MetaBrush.UI.StrokeTreeView
import Control.Arrow import Control.Arrow
( second ) ( second )
import Control.Monad import Control.Monad
( unless, void, when ) ( unless, void )
import Data.Foldable import Data.Foldable
( for_ ) ( for_ )
import Data.List import Data.List
@ -33,7 +35,6 @@ import Data.Traversable
import Data.Word import Data.Word
( Word32 ) ( Word32 )
import GHC.Stack import GHC.Stack
( HasCallStack )
-- containers -- containers
import Data.Map.Strict import Data.Map.Strict
@ -49,6 +50,9 @@ import Data.Generics.Product.Fields
-- gi-gdk -- gi-gdk
import qualified GI.Gdk as GDK import qualified GI.Gdk as GDK
-- gi-glib
import qualified GI.GLib as GLib
-- gi-gio -- gi-gio
import qualified GI.Gio as GIO import qualified GI.Gio as GIO
@ -70,9 +74,7 @@ import Control.Lens
( over ) ( over )
-- stm -- stm
import qualified Control.Concurrent.STM.TVar as STM import qualified Control.Concurrent.STM as STM
import qualified Control.Concurrent.STM.TMVar as STM
import qualified Control.Monad.STM as STM
-- text -- text
import Data.Text import Data.Text
@ -96,7 +98,6 @@ import MetaBrush.Unique
import MetaBrush.UI.Menu import MetaBrush.UI.Menu
( strokeMenuDescription, makeMenu ) ( strokeMenuDescription, makeMenu )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Custom GTK object used to hold layer data. -- | Custom GTK object used to hold layer data.
@ -225,13 +226,9 @@ newLayersListModel ( Variables { .. } ) docUnique = do
mbOldChildStore <- mbOldChildStore <-
STM.atomically $ do STM.atomically $ do
parStores <- STM.readTVar parStoresTVar parStores <- STM.readTVar parStoresTVar
let mbOldStore = return $
Map.lookup ( Parent groupUnique ) =<< Map.lookup docUnique parStores Map.lookup ( Parent groupUnique )
when ( isNothing mbOldStore ) $ =<< Map.lookup docUnique parStores
-- Take a lock to avoid creating multiple child stores
-- for the same group.
STM.takeTMVar listModelUpToDateTMVar
return mbOldStore
newChildStore <- newChildStore <-
case mbOldChildStore of case mbOldChildStore of
@ -258,8 +255,6 @@ newLayersListModel ( Variables { .. } ) docUnique = do
STM.atomically $ do STM.atomically $ do
STM.modifyTVar parStoresTVar STM.modifyTVar parStoresTVar
( Map.insertWith Map.union docUnique ( Map.singleton ( Parent groupUnique ) childStore ) ) ( Map.insertWith Map.union docUnique ( Map.singleton ( Parent groupUnique ) childStore ) )
STM.putTMVar listModelUpToDateTMVar ()
return childStore return childStore
-- Pass a copy of the (reference to the) child store -- Pass a copy of the (reference to the) child store
@ -469,11 +464,16 @@ newLayerView uiElts@( UIElements { window } ) vars = mdo
-- void $ GTK.widgetGrabFocus label -- void $ GTK.widgetGrabFocus label
| button == 3 | button == 3
-> do -> 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.widgetUnparent layerPopover
GTK.widgetSetParent layerPopover expander GTK.widgetSetParent layerPopover expander
layer <- getLayerData listItem layer <- getLayerData listItem
GIO.menuRemoveAll layerMenu GIO.menuRemoveAll layerMenu
makeMenu uiElts vars layerMenu ( strokeMenuDescription layer ) makeMenu uiElts vars layerMenu ( strokeMenuDescription ( WithinParent srcPar layer ) )
GTK.popoverMenuSetMenuModel layerPopover ( Just layerMenu ) GTK.popoverMenuSetMenuModel layerPopover ( Just layerMenu )
rect <- GDK.newZeroRectangle rect <- GDK.newZeroRectangle
GDK.setRectangleX rect ( round x ) GDK.setRectangleX rect ( round x )
@ -617,7 +617,7 @@ newLayerView uiElts@( UIElements { window } ) vars = mdo
updateLayerHierarchy vars $ updateLayerHierarchy vars $
DoLayerChange $ DoLayerChange $
SetBrush SetBrush
{ setBrushStroke = WithinParent ( fmap snd dstPar ) tgtStrokeUnique { setBrushStroke = WithinParent ( fmap snd dstPar ) tgtStrokeUnique
, setBrushName = brushName , setBrushName = brushName
} }
return True return True
@ -626,14 +626,16 @@ newLayerView uiElts@( UIElements { window } ) vars = mdo
let dropTgtUniq = layerUnique dropTgt let dropTgtUniq = layerUnique dropTgt
dstFlatIndex <- GTK.treeListRowGetPosition treeListRow dstFlatIndex <- GTK.treeListRowGetPosition treeListRow
h <- GTK.widgetGetHeight expander 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 expanded <- GTK.treeListRowGetExpanded treeListRow
isDescendant <- isDescendantOf dragSrcUniq listItem isDescendant <- isDescendantOf dragSrcUniq listItem
let mbDropIntoGroup let mbDropIntoGroup
| expanded | expanded
, not droppedAbove , Below <- dropRelPos
, not isDescendant , not isDescendant
= Just treeListRow = Just treeListRow
| otherwise | otherwise
@ -641,7 +643,7 @@ newLayerView uiElts@( UIElements { window } ) vars = mdo
mbDropOutsideGroup mbDropOutsideGroup
| dragSrcUniq == dropTgtUniq | dragSrcUniq == dropTgtUniq
, Parent par <- dstPar , Parent par <- dstPar
, not droppedAbove , Below <- dropRelPos
= Just par = Just par
| otherwise | otherwise
= Nothing = Nothing
@ -691,9 +693,11 @@ newLayerView uiElts@( UIElements { window } ) vars = mdo
{ parent = fmap snd dstPar { parent = fmap snd dstPar
, item = dropTgtUniq , 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 -- Compute the position that the item we are moving will have
@ -957,7 +961,7 @@ data LayerChange
| NewItem | NewItem
{ newUnique :: !Unique { newUnique :: !Unique
, newIsGroup :: !Bool , newIsGroup :: !Bool
, newSelected :: !( Maybe ChildLayer ) , newPosition :: !( ChildLayer, RelativePosition )
} }
| DeleteItems | DeleteItems
{ deleteItems :: !( NE.NonEmpty ChildLayer ) { deleteItems :: !( NE.NonEmpty ChildLayer )
@ -985,7 +989,7 @@ data MoveDst
-- | Move an item above or below another item. -- | Move an item above or below another item.
| MoveAboveOrBelow | MoveAboveOrBelow
{ moveDstItem :: !ChildLayer { moveDstItem :: !ChildLayer
, moveAbove :: !Bool , moveRelPos :: !RelativePosition
-- ^ Whether to move above or below the destination. -- ^ Whether to move above or below the destination.
} }
@ -994,91 +998,85 @@ data MoveDst
-- | Update the layer hierarchy, keeping both the application state and -- | Update the layer hierarchy, keeping both the application state and
-- the GTK ListModel in sync. -- the GTK ListModel in sync.
updateLayerHierarchy :: Variables -> DoLayerChange -> IO () updateLayerHierarchy :: Variables -> DoLayerChange -> IO ()
updateLayerHierarchy updateLayerHierarchy vars@( Variables { parStoresTVar } ) doOrUndo = do
vars@( Variables { parStoresTVar, listModelUpToDateTMVar } ) mbDiff <- STM.atomically $ do
doOrUndo = do
mbDiff <- STM.atomically $ do
-- Ensure the GTK ListModel is up to date before continuing -- TODO: need to use 'modifyingCurrentDocument' in some form,
-- (just a precaution). -- but that function doesn't permit modifying history.
STM.takeTMVar listModelUpToDateTMVar
-- TODO: need to use 'modifyingCurrentDocument' in some form, mbActiveDoc <- activeDocument vars
-- but that function doesn't permit modifying history. ( 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 for_ mbNewHist $ \ ( activeDoc, hist ) -> do
( mbNewHist, mbDiff ) <- STM.modifyTVar' ( openDocumentsTVar vars ) ( Map.insert activeDoc hist )
case mbActiveDoc of STM.writeTVar ( redrawStrokesTVar vars ) True
Nothing -> return ( Nothing, Nothing) return $ ( , ) <$> ( fst <$> mbNewHist ) <*> mbDiff
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 for_ mbDiff $ \ ( docUnique, diff ) ->
STM.modifyTVar' ( openDocumentsTVar vars ) ( Map.insert activeDoc hist ) GLib.idleAdd GLib.PRIORITY_HIGH_IDLE $ do
STM.writeTVar ( redrawStrokesTVar vars ) True
return $ ( , ) <$> ( fst <$> mbNewHist ) <*> mbDiff
for_ mbDiff $ \ ( docUnique, diff ) ->
applyDiffToListModel parStoresTVar docUnique diff applyDiffToListModel parStoresTVar docUnique diff
return False
STM.atomically $
STM.writeTMVar listModelUpToDateTMVar ()
-- | Apply a change to the application layer hierarchy. -- | Apply a change to the application layer hierarchy.
@ -1093,11 +1091,11 @@ applyChangeToLayerHierarchy change hierarchy =
let mbDst = let mbDst =
case moveDst of case moveDst of
MoveAboveOrBelow MoveAboveOrBelow
{ moveAbove { moveRelPos
, moveDstItem = WithinParent parUniq tgtUniq , moveDstItem = WithinParent parUniq tgtUniq
} -> } ->
Just ( parUniq Just ( parUniq
, Just ( tgtUniq , moveAbove ) , Just ( tgtUniq , moveRelPos )
) )
MoveToTopOfGroup MoveToTopOfGroup
{ dstParUnique } -> { dstParUnique } ->
@ -1118,7 +1116,7 @@ applyChangeToLayerHierarchy change hierarchy =
| otherwise | otherwise
= False = False
, not expandedGroupWithChildren , not expandedGroupWithChildren
-> Just ( grandParentUnique, Just ( parentUnique, False ) ) -> Just ( grandParentUnique, Just ( parentUnique, Below ) )
| otherwise | otherwise
-> Nothing -> Nothing
in case mbDst of in case mbDst of
@ -1143,14 +1141,9 @@ applyChangeToLayerHierarchy change hierarchy =
} }
Nothing -> Nothing Nothing -> Nothing
) )
NewItem { newUnique = u, newIsGroup, newSelected } -> NewItem { newUnique = u, newIsGroup, newPosition = ( WithinParent dstParUniq childUniq, relPos ) } ->
let ( dstParUniq, dstChild ) = case newSelected of let dropPos = Just ( childUniq, relPos )
Nothing -> ( Root, Nothing ) !( !hierarchy', dstChildIx ) = insertLayerIntoParent hierarchy ( dstParUniq, dropPos ) u
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
!hierarchy'' = !hierarchy'' =
if newIsGroup if newIsGroup
then insertGroup ( Parent u ) [] hierarchy' then insertGroup ( Parent u ) [] hierarchy'
@ -1228,7 +1221,8 @@ applyDeletionToStrokeHierarchy hierarchy0 = go hierarchy0
-- --
-- The change to the application 'StrokeHierarchy' is done beforehand, -- The change to the application 'StrokeHierarchy' is done beforehand,
-- in 'applyChangeToLayerHierarchy'. -- in 'applyChangeToLayerHierarchy'.
applyDiffToListModel :: STM.TVar ( Map Unique ( Map ( Parent Unique ) GIO.ListStore ) ) applyDiffToListModel :: HasCallStack
=> STM.TVar ( Map Unique ( Map ( Parent Unique ) GIO.ListStore ) )
-> Unique -> Unique
-> ( Do, HierarchyDiff ) -> ( Do, HierarchyDiff )
-> IO () -> IO ()
@ -1287,7 +1281,7 @@ applyDiffToListModel parStoreTVar docUnique ( doOrUndo, diff ) = do
Just item -> do Just item -> do
GIO.listStoreRemove dstStore dstIx GIO.listStoreRemove dstStore dstIx
GIO.listStoreInsert srcStore srcIx item 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 case Map.lookup dstPar parStoreFromUniq of
Nothing -> Nothing ->
putStrLn $ unlines putStrLn $ unlines
@ -1372,7 +1366,7 @@ sequentialOn f ( a NE.:| as ) = go ( f a ) as
moveLayerUpdate moveLayerUpdate
:: ( Parent Unique, Unique ) :: ( Parent Unique, Unique )
-- ^ source -- ^ source
-> ( Parent Unique, Maybe ( Unique, Bool ) ) -> ( Parent Unique, Maybe ( Unique, RelativePosition ) )
-- ^ destination -- ^ destination
-- --
-- - @Nothing@: drop as first element of group -- - @Nothing@: drop as first element of group
@ -1423,7 +1417,7 @@ removeLayerFromParent hierarchy ( parent, u ) =
-- --
-- NB: does not add the layer itself. -- NB: does not add the layer itself.
insertLayerIntoParent :: StrokeHierarchy insertLayerIntoParent :: StrokeHierarchy
-> ( Parent Unique, Maybe ( Unique, Bool ) ) -> ( Parent Unique, Maybe ( Unique, RelativePosition ) )
-- ^ destination -- ^ destination
-- --
-- - @Nothing@: drop as first element of group -- - @Nothing@: drop as first element of group
@ -1441,12 +1435,12 @@ insertLayerIntoParent hierarchy ( newPar, mbTgtUniq ) srcUniq =
, 0 , 0
) )
-- Drop (before or after) given child. -- Drop (before or after) given child.
Just ( tgtUniq, dropAbove ) -> Just ( tgtUniq, dropRelPos ) ->
let ( bef, aft ) = break ( == tgtUniq ) $ filter ( /= srcUniq ) newPar_oldCs let ( bef, aft ) = break ( == tgtUniq ) $ filter ( /= srcUniq ) newPar_oldCs
in ( if dropAbove in ( case dropRelPos of
then bef ++ [ srcUniq ] ++ aft Above -> bef ++ [ srcUniq ] ++ aft
else bef ++ take 1 aft ++ [ srcUniq ] ++ drop 1 aft Below -> bef ++ take 1 aft ++ [ srcUniq ] ++ drop 1 aft
, fromIntegral ( length ( takeWhile ( /= tgtUniq ) $ newPar_oldCs ) ) , 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 ) in ( insertGroup newPar newPar_newCs hierarchy, newChildPos )

View file

@ -1,5 +1,8 @@
module MetaBrush.UI.StrokeTreeView where module MetaBrush.UI.StrokeTreeView where
-- base
import GHC.Stack
-- containers -- containers
import Data.Map.Strict import Data.Map.Strict
( Map ) ( Map )
@ -28,7 +31,8 @@ switchStrokeView :: GTK.ListView -> Variables -> Maybe Unique -> IO ()
newLayerView :: UIElements -> Variables -> IO GTK.ListView 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 -> Unique
-> ( Do, HierarchyDiff ) -> ( Do, HierarchyDiff )
-> IO () -> IO ()

View file

@ -64,7 +64,7 @@ data WithinParent a =
{ parent :: !( Parent Unique ) { parent :: !( Parent Unique )
, item :: !a , item :: !a
} }
deriving stock ( Show, Eq, Generic ) deriving stock ( Show, Eq, Generic, Functor )
deriving anyclass NFData deriving anyclass NFData
-- | A child layer within a parent. -- | 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. -- | A child layer, with its index among the list of children of its parent.
type ChildLayerPosition = WithinParent Word32 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. -- | Content in a hierarchical tree-like structure.
data Hierarchy a = data Hierarchy a =
Hierarchy Hierarchy