implement stroke list popover menu functionality

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

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

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

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

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

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 )

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

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