mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
implement stroke list popover menu functionality
This commit is contained in:
sheaf
parent
27269809e7
commit
53243621b5
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 --
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ) )
|
||||
|
||||
|
|
|
|||
|
|
@ -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 "<Ctrl>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
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue