remove stroke from list stores when deleting all stroke points

src/app/MetaBrush/Application/Action.hs

@@ -14,6 +14,7 @@ import Data.Function
   ( on )
 import Data.List
   ( uncons )
+import qualified Data.List.NonEmpty as NE
 import Data.Maybe
   ( catMaybes, fromMaybe, isNothing )
 import Data.String
@@ -135,7 +136,7 @@ import MetaBrush.UI.InfoBar
 import MetaBrush.UI.FileBar
   ( newFileTab, removeFileTab )
 import MetaBrush.UI.StrokeTreeView
-  ( applyDiffToListModel )
+  ( applyDeletionToStrokeHierarchy, applyDiffToListModel )
 import MetaBrush.UI.Viewport
   ( Viewport(..) )
 import MetaBrush.Unique
@@ -659,14 +660,29 @@ instance HandleAction Delete where
                   Nothing ->
                     pure Don'tModifyDoc
                   Just ( doc', affectedPoints, delStrokes ) -> do
-                    -- TODO: only a hierarchy diff if there are
-                    -- any deleted strokes.
-                    let diff = HistoryDiff $ HierarchyDiff $
-                               DeletePoints
-                                 { deletedPoints = affectedPoints
-                                 , deletedStrokes = delStrokes
-                                 }
+                    let delStrokeList = Map.toList delStrokes
+                        diff = case NE.nonEmpty delStrokeList of
+                          Nothing ->
+                            HistoryDiff $ ContentDiff $ DeletePoints affectedPoints
+                          Just delStrokesNE ->
+                            let
+                              -- TODO: here we are re-doing the deletion, but using 'applyChangeToLayerHierarchy'
+                              -- as this gives us the child indices we need for the list model update.
+                              -- It would be better to refactor this to avoid going around the houses.
+                              ( _hierarchy', deletedLayers ) =
+                                applyDeletionToStrokeHierarchy
+                                ( strokeHierarchy $ documentContent doc )
+                                    -- NB: original doc, not doc'!
+                                    -- (we don't want to attempt to delete what has already been deleted)
+                                ( fmap (uncurry $ flip WithinParent) delStrokesNE )
+                            in
+                              HistoryDiff $ HierarchyDiff $
+                                DeleteLayers
+                                   { deletedPoints = affectedPoints
+                                   , deletedLayers
+                                   }
                     pure $ UpdateDoc ( UpdateDocumentTo doc' diff )
+
   -- TODO: handle deletion of layers by checking the current focus.
           _ -> pure ()
 

src/app/MetaBrush/Render/Document.hs

@@ -113,6 +113,7 @@ import MetaBrush.Unique
   ( Unique )
 import MetaBrush.GTK.Util
   ( withRGBA )
+import MetaBrush.Layer (WithinParent(..))
 
 --------------------------------------------------------------------------------
 
@@ -253,7 +254,7 @@ getVisibleStrokes ( Document { documentMetadata, documentContent } ) =
     forStrokeHierarchy
        ( layerMetadata documentMetadata )
        ( strokeHierarchy documentContent )
-       ( \ uniq stroke ( StrokeMetadata { strokeVisible } ) -> do
+       ( \ ( WithinParent _ uniq ) stroke ( StrokeMetadata { strokeVisible } ) -> do
           when strokeVisible $
             Writer.tell [ ( Just uniq, stroke ) ]
           return PreserveStroke

src/app/MetaBrush/UI/StrokeTreeView.hs

@@ -2,16 +2,30 @@
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecursiveDo #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
-module MetaBrush.UI.StrokeTreeView where
+module MetaBrush.UI.StrokeTreeView
+  ( newLayersListModel
+  , newLayerView
+  , switchStrokeView
+  , applyDeletionToStrokeHierarchy
+  , applyChangeToLayerHierarchy
+  , applyDiffToListModel
+  , getSelectedItem
+  , DragSourceData(..)
+  )
+  where
 
 -- base
+import Control.Arrow
+  ( second )
 import Control.Monad
   ( unless, void, when )
 import Data.Foldable
   ( for_ )
 import Data.List
   ( elemIndex )
+import qualified Data.List.NonEmpty as NE
 import Data.Maybe
   ( fromJust, isJust, isNothing )
 import Data.Traversable
@@ -65,6 +79,8 @@ import Data.Text
   ( Text )
 
 -- MetaBrush
+import Debug.Utils
+  ( trace )
 import MetaBrush.Application.Context
 import MetaBrush.Application.UpdateDocument
 import MetaBrush.Asset.Brushes
@@ -76,8 +92,6 @@ import MetaBrush.Document.History
 import MetaBrush.Layer
 import MetaBrush.Stroke hiding ( Layer(..) )
 import MetaBrush.Unique
-import MetaBrush.Util
-  ( (!) )
 
 --------------------------------------------------------------------------------
 
@@ -146,11 +160,12 @@ newLayersListModel ( Variables { .. } ) docUnique = do
     mbDocHist <- Map.lookup docUnique <$> STM.readTVar openDocumentsTVar
     mbDocStore <- Map.lookup docUnique <$> STM.readTVar parStoresTVar
     store <- case mbDocStore of
-      Nothing -> do
+      Just store
+        | Just rootStore <- Map.lookup Root store
+        -> return rootStore
+      _ -> do
         STM.modifyTVar' parStoresTVar ( Map.insert docUnique ( Map.singleton Root store0 ) )
         return store0
-      Just store ->
-        return ( store ! Root )
     return ( store, mbDocHist )
 
   for_ mbDocHist $ \ activeDocHist -> do
@@ -205,8 +220,9 @@ newLayersListModel ( Variables { .. } ) docUnique = do
                 -- Try to re-use an existing list store, if there is one.
                 mbOldChildStore <-
                   STM.atomically $ do
-                    mbOldStore <-
-                      Map.lookup ( Parent groupUnique ) . ( ! docUnique ) <$> STM.readTVar parStoresTVar
+                    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.
@@ -759,7 +775,7 @@ newLayerView uiElts@( UIElements { window } ) vars = mdo
 
           -- All we do is set the name and visibility of this layer/group.
 
-          let layerText    = layerNames meta ! layerUnique layer
+          let mbLayerText  = Map.lookup ( layerUnique layer ) ( layerNames meta )
               layerVisible = not $ Set.member ( layerUnique layer ) ( invisibleLayers meta )
 
           mbTreeListRow <- traverse ( GTK.unsafeCastTo GTK.TreeListRow ) =<< GTK.listItemGetItem listItem
@@ -770,7 +786,7 @@ newLayerView uiElts@( UIElements { window } ) vars = mdo
 
           GTK.widgetSetVisible checkButton True
           GTK.checkButtonSetActive checkButton layerVisible
-          GTK.editableSetText layerLabel layerText
+          for_ mbLayerText $ GTK.editableSetText layerLabel
 
   listView <- GTK.listViewNew ( Nothing @GTK.SingleSelection ) ( Just layersListFactory )
   return listView
@@ -906,8 +922,8 @@ data LayerChange
       , newIsGroup  :: !Bool
       , newSelected :: !( Maybe ChildLayer )
       }
-  | Delete
-      { deleteItem :: !ChildLayer
+  | DeleteItems
+      { deleteItems :: !( NE.NonEmpty ChildLayer )
       }
   | SetBrush
       { setBrushStroke :: !ChildLayer
@@ -1112,45 +1128,63 @@ applyChangeToLayerHierarchy change hierarchy =
               , newIsGroup
               }
         )
-    Delete { deleteItem = WithinParent parUniq delUniq } ->
-      let !( !hierarchy', childIx ) = removeLayerFromParent hierarchy ( parUniq, delUniq )
-          !( !hierarchy'', mbHadChildren ) =
-              deleteLayerKey delUniq hierarchy'
-      in
-        ( hierarchy''
-        , Map.empty
-        , Just $
-            DeleteLayer
-              { delPosition = WithinParent parUniq childIx
-              , delUnique   = delUniq
-              , delIsGroup  = isJust mbHadChildren
-              }
-        )
-    SetBrush { setBrushStroke = WithinParent parUniq strokeUnique, setBrushName } ->
+    DeleteItems { deleteItems } ->
       let
-        oldStroke, newStroke :: Stroke
-        oldStroke = content hierarchy ! strokeUnique
-        newStroke = case setBrushName of
-          Just brushNm
-            | Just ( SomeBrush brush ) <- lookupBrush brushNm
-            -> setStrokeBrush ( Just brush ) oldStroke
-          _ -> setStrokeBrush Nothing oldStroke
-
-        strokeIx :: Word32
-        strokeIx =
-          let oldPar_cs = lookupChildren parUniq hierarchy
-          in  fromIntegral $ fromJust $ elemIndex strokeUnique oldPar_cs
-
-        hierarchy' = hierarchy { content = Map.insert strokeUnique newStroke ( content hierarchy ) }
+        !( !hierarchy', delLayers ) = applyDeletionToStrokeHierarchy hierarchy deleteItems
       in
         ( hierarchy'
         , Map.empty
-        , Just $
-            StrokeSetBrush
-              { changedBrushStroke = WithinParent parUniq strokeIx
-              , newBrushName = setBrushName
-              }
+        , Just $ DeleteLayers mempty delLayers
         )
+    SetBrush { setBrushStroke = WithinParent parUniq strokeUnique, setBrushName } ->
+      case Map.lookup strokeUnique ( content hierarchy ) of
+        Just oldStroke
+          | Just oldPar_cs <- lookupChildren_maybe parUniq hierarchy
+          , Just strokeIx  <- elemIndex strokeUnique oldPar_cs
+          ->
+          let
+            newStroke :: Stroke
+            newStroke =
+              case setBrushName of
+                Just brushNm
+                  | Just ( SomeBrush brush ) <- lookupBrush brushNm
+                  -> setStrokeBrush ( Just brush ) oldStroke
+                _ -> setStrokeBrush Nothing oldStroke
+            hierarchy' = hierarchy { content = Map.insert strokeUnique newStroke ( content hierarchy ) }
+          in
+            ( hierarchy'
+            , Map.empty
+            , Just $
+                StrokeSetBrush
+                  { changedBrushStroke = WithinParent parUniq ( fromIntegral strokeIx )
+                  , newBrushName = setBrushName
+                  }
+            )
+          | otherwise
+          -> trace ( unlines [ "internal error in 'applyChangeToLayerHierarchy' SetBrush"
+                             , "could not find index within parent of stroke " ++ show strokeUnique
+                             , "parent: " ++ show parUniq ])
+            ( hierarchy, Map.empty, Nothing )
+        Nothing ->
+          trace ( unlines [ "internal error in 'applyChangeToLayerHierarchy' SetBrush"
+                          , "no content for stroke with unique " ++ show strokeUnique ])
+            ( hierarchy, Map.empty, Nothing )
+
+
+applyDeletionToStrokeHierarchy :: StrokeHierarchy -> NE.NonEmpty ChildLayer -> ( StrokeHierarchy, Map (Parent Unique) [DeleteLayer] )
+applyDeletionToStrokeHierarchy hierarchy0 = go hierarchy0
+  where
+    go :: StrokeHierarchy -> NE.NonEmpty ChildLayer -> ( StrokeHierarchy, Map (Parent Unique) [DeleteLayer] )
+    go h (WithinParent parUniq delUniq NE.:| items) =
+      let !( !h', _ )      = removeLayerFromParent h ( parUniq, delUniq )
+          !( _, !childIx ) = removeLayerFromParent hierarchy0 ( parUniq, delUniq )
+          !( !h'', !mbChildren ) = deleteLayerKey delUniq h'
+      in second ( Map.insertWith (++) parUniq
+                  [DeleteLayer { delPosition = childIx
+                               , delUnique   = delUniq
+                               , delIsGroup  = isJust mbChildren
+                               }] ) $ ( case items of { [] -> ( h'', Map.empty )
+                                                      ; (i:is) -> ( go h'' (i NE.:| is) ) } )
 
 -- | Apply a change to the 'ListModel' underlying the UI
 -- representation of the layer hierarchy.
@@ -1172,44 +1206,122 @@ applyDiffToListModel parStoreTVar docUnique ( doOrUndo, diff ) = do
   --   parent --> list store used to hold its children
   --
   -- and use that child list store to perform updates.
-  parStoreFromUniq <- ( ! docUnique ) <$> STM.readTVarIO parStoreTVar
-  case diff of
-    MoveLayer { srcPos = WithinParent srcPar srcIx
-              , dstPos = WithinParent dstPar dstIx } -> do
-      let srcStore = parStoreFromUniq ! srcPar
-          dstStore = parStoreFromUniq ! dstPar
-      case doOrUndo of
-        Do -> do
-          item <- fromJust <$> GIO.listModelGetItem srcStore srcIx
-          GIO.listStoreRemove srcStore srcIx
-          GIO.listStoreInsert dstStore dstIx item
-        Undo -> do
-          item <- fromJust <$> GIO.listModelGetItem dstStore dstIx
-          GIO.listStoreRemove dstStore dstIx
-          GIO.listStoreInsert srcStore srcIx item
-    NewLayer { newPosition = WithinParent dstPar dstIx, newUnique, newIsGroup } -> do
-      let dstStore = parStoreFromUniq ! dstPar
-      case doOrUndo of
-        Do -> do
-          item <- GI.new LayerItem []
-          GI.gobjectSetPrivateData item ( Just $ if newIsGroup then GroupLayer newUnique else StrokeLayer newUnique )
-          GIO.listStoreInsert dstStore dstIx item
-        Undo ->
-          GIO.listStoreRemove dstStore dstIx
-    DeleteLayer { delPosition = WithinParent srcPar srcIx, delUnique, delIsGroup } -> do
-      let srcStore = parStoreFromUniq ! srcPar
-      case doOrUndo of
-        Do -> GIO.listStoreRemove srcStore srcIx
-        Undo -> do
-          item <- GI.new LayerItem []
-          GI.gobjectSetPrivateData item ( Just $ if delIsGroup then GroupLayer delUnique else StrokeLayer delUnique )
-          GIO.listStoreInsert srcStore srcIx item
-    DeletePoints { deletedStrokes } ->
-      unless ( null deletedStrokes ) $
-        putStrLn "TODO: delete strokes"
-    StrokeSetBrush { changedBrushStroke = WithinParent changedPar changedIx } -> do
-      let changedStrokeStore = parStoreFromUniq ! changedPar
-      GIO.listModelItemsChanged changedStrokeStore changedIx 0 0
+
+  mbParStoreFromUniq <- Map.lookup docUnique <$> STM.readTVarIO parStoreTVar
+  case mbParStoreFromUniq of
+    Nothing ->
+      putStrLn $ unlines
+        [ "internal error in 'applyDiffToListModel'"
+        , "failed to look up list store map for document with unique " ++ show docUnique ]
+    Just parStoreFromUniq -> do
+      case diff of
+        MoveLayer { srcPos = WithinParent srcPar srcIx
+                  , dstPos = WithinParent dstPar dstIx } ->
+          case Map.lookup srcPar parStoreFromUniq of
+            Nothing ->
+              putStrLn $ unlines
+                [ "internal error in 'applyDiffToListModel' MoveLayer"
+                , "failed to look up list store for source parent " ++ show srcPar ]
+            Just srcStore ->
+              case Map.lookup dstPar parStoreFromUniq of
+                Nothing ->
+                  putStrLn $ unlines
+                    [ "internal error in 'applyDiffToListModel' MoveLayer"
+                    , "failed to look up list store for destination parent " ++ show dstPar ]
+                Just dstStore ->
+                  case doOrUndo of
+                    Do -> do
+                      mbItem <- GIO.listModelGetItem srcStore srcIx
+                      case mbItem of
+                        Nothing ->
+                          putStrLn $ unlines
+                            [ "internal error in 'applyDiffToListModel' Do MoveLayer"
+                            , "failed to get item at index " ++ show srcIx ]
+                        Just item -> do
+                          GIO.listStoreRemove srcStore srcIx
+                          GIO.listStoreInsert dstStore dstIx item
+                    Undo -> do
+                      mbItem <- GIO.listModelGetItem dstStore dstIx
+                      case mbItem of
+                        Nothing ->
+                          putStrLn $ unlines
+                            [ "internal error in 'applyDiffToListModel' Undo MoveLayer"
+                            , "failed to get item at index " ++ show dstIx ]
+                        Just item -> do
+                          GIO.listStoreRemove dstStore dstIx
+                          GIO.listStoreInsert srcStore srcIx item
+        NewLayer { newPosition = WithinParent dstPar dstIx, newUnique, newIsGroup } ->
+          case Map.lookup dstPar parStoreFromUniq of
+            Nothing ->
+              putStrLn $ unlines
+                [ "internal error in 'applyDiffToListModel' NewLayer"
+                , "failed to look up list store for parent " ++ show dstPar ]
+            Just dstStore ->
+              case doOrUndo of
+                Do -> do
+                  item <- GI.new LayerItem []
+                  GI.gobjectSetPrivateData item ( Just $ if newIsGroup then GroupLayer newUnique else StrokeLayer newUnique )
+                  GIO.listStoreInsert dstStore dstIx item
+                Undo ->
+                  GIO.listStoreRemove dstStore dstIx
+        DeleteLayers _delPts delLayers ->
+          Map.foldMapWithKey deleteLayersInParent delLayers
+            where
+              deleteLayersInParent _ [] = return ()
+              deleteLayersInParent srcPar (l:ls) =
+                case Map.lookup srcPar parStoreFromUniq of
+                  Nothing ->
+                    putStrLn $ unlines
+                      [ "internal error in 'applyDiffToListModel' DeleteLayers"
+                      , "failed to look up list store for parent " ++ show srcPar ]
+                  Just srcStore ->
+                    let sortedLays = NE.sortOn delPosition (l NE.:| ls)
+                    in
+                      if sequentialOn delPosition sortedLays
+                      then do
+                        (remLays, addLays) <-
+                          case doOrUndo of
+                            Do -> return ( fromIntegral ( length sortedLays ) , [] )
+                            Undo -> do
+                              newLays <- for sortedLays $ \ ( DeleteLayer { delUnique, delIsGroup } ) -> do
+                                item <- GI.new LayerItem []
+                                GI.gobjectSetPrivateData item
+                                  ( Just $ if delIsGroup then GroupLayer delUnique else StrokeLayer delUnique )
+                                GObject.toObject item
+                              return ( 0, NE.toList newLays )
+                        GIO.listStoreSplice srcStore ( delPosition $ NE.head sortedLays ) remLays addLays
+                      else case doOrUndo of
+                        Do ->
+                          -- Delete later items first, otherwise indexing is wrong.
+                          for_ ( NE.reverse sortedLays ) $ \ ( DeleteLayer { delPosition = srcIx } ) ->
+                            GIO.listStoreRemove srcStore srcIx
+                        Undo ->
+                          -- Insert earlier items first, otherwise indexing is wrong.
+                          for_ sortedLays $ \ ( DeleteLayer { delUnique, delIsGroup, delPosition = srcIx } ) -> do
+                            item <- GI.new LayerItem []
+                            GI.gobjectSetPrivateData item
+                              ( Just $ if delIsGroup then GroupLayer delUnique else StrokeLayer delUnique )
+                            GIO.listStoreInsert srcStore srcIx item
+        StrokeSetBrush { changedBrushStroke = WithinParent changedPar changedIx } ->
+          case Map.lookup changedPar parStoreFromUniq of
+            Nothing ->
+              putStrLn $ unlines
+                [ "internal error in 'applyDiffToListModel' StrokeSetBrush"
+                , "failed to look up list store for parent " ++ show changedPar ]
+            Just changedStrokeStore ->
+              GIO.listModelItemsChanged changedStrokeStore changedIx 0 0
+
+sequentialOn :: forall a i. ( Num i, Ord i ) => ( a -> i ) -> NE.NonEmpty a -> Bool
+sequentialOn f ( a NE.:| as ) = go ( f a ) as
+  where
+    go :: i -> [ a ] -> Bool
+    go _ [] = True
+    go i (b:bs)
+      | let j = f b
+      , j == i + 1
+      = go j bs
+      | otherwise
+      = False
 
 -- | Update the 'StrokeHierarchy' after a drag-and-drop operation,
 -- moving one layer or group around.
@@ -1251,13 +1363,22 @@ moveLayerUpdate src@( srcPar, srcUniq ) dst@( dstPar, _ ) hierarchy =
 -- was found within its parent.
 --
 -- NB: does not delete the layer itself.
-removeLayerFromParent :: StrokeHierarchy
+removeLayerFromParent :: HasCallStack
+                      => StrokeHierarchy
                       -> ( Parent Unique, Unique )
                       -> ( StrokeHierarchy, Word32 )
 removeLayerFromParent hierarchy ( parent, u ) =
   let oldPar_cs = lookupChildren parent hierarchy
       newChildren = filter ( /= u ) oldPar_cs
-      oldChildPos = fromIntegral $ fromJust $ elemIndex u oldPar_cs
+      oldChildPos = case elemIndex u oldPar_cs of
+        Nothing -> error $ unlines
+                     [ "internal error in 'removeLayerFromParent': could not find index within parent"
+                     , "parent: " ++ show parent
+                     , "child: " ++ show u
+                     , "children of parent: " ++ show oldPar_cs
+                     , "hierarchy: " ++ show hierarchy
+                     ]
+        Just i -> fromIntegral i
   in ( insertGroup parent newChildren hierarchy, oldChildPos )
 
 -- | Add a layer to a parent in the 'StrokeHierarchy', returning the updated

src/metabrushes/MetaBrush/Action.hs

@@ -42,6 +42,8 @@ import Data.Act
   ( Act((•)), Torsor((-->)) )
 
 -- containers
+import Data.Map.Strict
+  ( Map )
 import qualified Data.Map.Strict as Map
 import Data.Sequence
   ( Seq )
@@ -99,6 +101,7 @@ import MetaBrush.Records
 import MetaBrush.Stroke
 import MetaBrush.Unique
   ( Unique )
+import MetaBrush.Layer (Parent, WithinParent (..))
 
 --------------------------------------------------------------------------------
 -- Subdivision.
@@ -127,11 +130,11 @@ subdivide c doc@( Document { documentMetadata, documentContent }) =
     stripData :: Curve Open crvData ( PointData ptData ) -> Curve Open () ()
     stripData = bimapCurve ( \ _ ->  () ) ( \ _ _ -> () )
 
-    subdivideStroke :: Unique -> Stroke -> StrokeMetadata
+    subdivideStroke :: WithinParent Unique -> Stroke -> StrokeMetadata
                     -> State
                           ( Maybe Subdivision )
                           UpdateStroke
-    subdivideStroke u stroke0@( Stroke { strokeSpline = strokeSpline :: StrokeSpline clo brushParams } ) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
+    subdivideStroke ( WithinParent _ u ) stroke0@( Stroke { strokeSpline = strokeSpline :: StrokeSpline clo brushParams } ) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
       mbPrevSubdivision <- State.get
       let ( curves', subdivs ) =
               Writer.runWriter $
@@ -264,8 +267,8 @@ selectAt selMode c doc@( Document { documentContent, documentMetadata } ) =
   where
     Zoom { zoomFactor } = documentZoom documentMetadata
 
-    computeSelected :: Unique -> Stroke -> StrokeMetadata -> Except ( Unique, PointIndex ) UpdateStroke
-    computeSelected strokeUnique ( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible } ) = do
+    computeSelected :: WithinParent Unique -> Stroke -> StrokeMetadata -> Except ( Unique, PointIndex ) UpdateStroke
+    computeSelected ( WithinParent _ strokeUnique ) ( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible } ) = do
       when ( strokeVisible ) $
         Except.withExcept ( strokeUnique , ) $
           bifoldSpline
@@ -314,8 +317,8 @@ dragMoveSelect c ( Document { documentContent, documentMetadata } ) =
     inSelectionRange p =
       squaredNorm ( c --> p :: T ( ℝ 2 ) ) * zoomFactor ^ ( 2 :: Int ) < 16
 
-    dragSelect :: Unique -> Stroke -> StrokeMetadata -> Except DragMoveSelect UpdateStroke
-    dragSelect strokeUnique ( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
+    dragSelect :: WithinParent Unique -> Stroke -> StrokeMetadata -> Except DragMoveSelect UpdateStroke
+    dragSelect ( WithinParent _ strokeUnique ) ( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
       when ( strokeVisible && not strokeLocked ) $
         ibifoldSpline
           ( dragSelectSplineCurve strokeUnique ( splineStart strokeSpline ) )
@@ -449,8 +452,8 @@ selectRectangle selMode ( ℝ2 x0 y0 ) ( ℝ2 x1 y1 ) doc@( Document { documentC
     ( xMin, xMax ) = if x0 <= x1 then ( x0, x1 ) else ( x1, x0 )
     ( yMin, yMax ) = if y0 <= y1 then ( y0, y1 ) else ( y1, y0 )
 
-    selectRect :: Unique -> Stroke -> StrokeMetadata -> Writer StrokePoints UpdateStroke
-    selectRect strokeUnique ( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible } ) = do
+    selectRect :: WithinParent Unique -> Stroke -> StrokeMetadata -> Writer StrokePoints UpdateStroke
+    selectRect ( WithinParent _ strokeUnique ) ( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible } ) = do
       when strokeVisible $
         Writer.mapWriter ( second $ \ is -> StrokePoints ( Map.singleton strokeUnique is ) ) $
           bifoldSpline
@@ -507,8 +510,8 @@ translateSelection t doc@( Document { documentContent, documentMetadata } ) =
     selPts :: StrokePoints
     selPts = selectedPoints documentMetadata
 
-    updateStroke :: Unique -> Stroke -> StrokeMetadata -> Writer StrokePoints UpdateStroke
-    updateStroke u stroke@( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
+    updateStroke :: WithinParent Unique -> Stroke -> StrokeMetadata -> Writer StrokePoints UpdateStroke
+    updateStroke ( WithinParent _ u ) stroke@( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
       let strokeSelPts = fromMaybe Set.empty $ Map.lookup u ( strokePoints selPts )
           firstPointSel = FirstPoint `Set.member` strokeSelPts
           ( spline', ( modPts, _ ) ) =
@@ -600,7 +603,7 @@ translateSelection t doc@( Document { documentContent, documentMetadata } ) =
 --
 -- Returns the updated document, together with info about how many points
 -- and strokes were deleted.
-deleteSelected :: Document -> Maybe ( Document, StrokePoints, Set Unique )
+deleteSelected :: Document -> Maybe ( Document, StrokePoints, Map Unique ( Parent Unique ) )
 deleteSelected doc@( Document { documentContent, documentMetadata } ) =
   let
     ( newStrokes, ( delPts, delStrokes ) ) =
@@ -620,8 +623,8 @@ deleteSelected doc@( Document { documentContent, documentMetadata } ) =
               )
   where
 
-    updateStroke :: Unique -> Stroke -> StrokeMetadata -> Writer ( StrokePoints, Set Unique ) UpdateStroke
-    updateStroke u stroke@( Stroke { strokeSpline = oldSpline :: StrokeSpline clo brushParams } ) ( StrokeMetadata { strokeVisible, strokeLocked } )
+    updateStroke :: WithinParent Unique -> Stroke -> StrokeMetadata -> Writer ( StrokePoints, Map Unique ( Parent Unique ) ) UpdateStroke
+    updateStroke ( WithinParent par u ) stroke@( Stroke { strokeSpline = oldSpline :: StrokeSpline clo brushParams } ) ( StrokeMetadata { strokeVisible, strokeLocked } )
       | not strokeVisible || strokeLocked
       = return PreserveStroke
       | otherwise
@@ -637,10 +640,10 @@ deleteSelected doc@( Document { documentContent, documentMetadata } ) =
             return PreserveStroke
            else case mbSpline of
               Nothing -> do
-                Writer.tell ( StrokePoints $ Map.singleton u delPts, Set.singleton u )
+                Writer.tell ( StrokePoints $ Map.singleton u delPts, Map.singleton u par )
                 return DeleteStroke
               Just spline' -> do
-                Writer.tell ( StrokePoints $ Map.singleton u delPts, Set.empty )
+                Writer.tell ( StrokePoints $ Map.singleton u delPts, Map.empty )
                 return $ UpdateStrokeTo $ stroke { strokeSpline = spline' }
 
       where
@@ -776,8 +779,8 @@ dragUpdate _  p ( ClickedOnCurve { dragStrokeUnique, dragCurveIndex, dragCurvePa
               )
   where
 
-    updateStroke :: Unique -> Stroke -> StrokeMetadata -> Writer StrokePoints UpdateStroke
-    updateStroke u stroke@( Stroke { strokeSpline = oldSpline :: StrokeSpline clo pointParams } ) ( StrokeMetadata { strokeVisible, strokeLocked } )
+    updateStroke :: WithinParent Unique -> Stroke -> StrokeMetadata -> Writer StrokePoints UpdateStroke
+    updateStroke ( WithinParent _ u ) stroke@( Stroke { strokeSpline = oldSpline :: StrokeSpline clo pointParams } ) ( StrokeMetadata { strokeVisible, strokeLocked } )
       | not strokeVisible || strokeLocked || u /= dragStrokeUnique
       = return PreserveStroke
       | otherwise
@@ -923,8 +926,8 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { documentCont
 
     zoom = documentZoom $ documentMetadata
 
-    updateStroke :: Unique -> Stroke -> StrokeMetadata -> State ( Maybe BrushWidgetActionState, Bool ) UpdateStroke
-    updateStroke u
+    updateStroke :: WithinParent Unique -> Stroke -> StrokeMetadata -> State ( Maybe BrushWidgetActionState, Bool ) UpdateStroke
+    updateStroke ( WithinParent _ u )
       ( Stroke { strokeBrush, strokeSpline = oldSpline :: StrokeSpline clo ( Record pointFields ) } )
       ( StrokeMetadata { strokeVisible, strokeLocked } )
       | strokeVisible

src/metabrushes/MetaBrush/Document/Diff.hs

@@ -1,13 +1,17 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+
 module MetaBrush.Document.Diff where
 
 -- base
 import qualified Data.List.NonEmpty as NE
+import Data.Word
+  ( Word32 )
 import GHC.Generics
   ( Generic )
 
 -- containers
-import Data.Set
-  ( Set )
+import Data.Map.Strict
+  ( Map )
 
 -- deepseq
 import Control.DeepSeq
@@ -63,15 +67,10 @@ data HierarchyDiff
       , newIsGroup  :: !Bool
       , newPosition :: !ChildLayerPosition
       }
-  | DeleteLayer
-      { delUnique   :: !Unique
-      , delIsGroup  :: !Bool
-      , delPosition :: !ChildLayerPosition
-      }
-  | DeletePoints
-      { deletedPoints  :: !StrokePoints
-      , deletedStrokes :: !( Set Unique )
-      }
+  | DeleteLayers
+    { deletedPoints :: !StrokePoints
+    , deletedLayers :: !( Map ( Parent Unique ) [ DeleteLayer ] )
+    }
   | MoveLayer
       { moveUnique :: !Unique
       , srcPos :: !ChildLayerPosition
@@ -84,6 +83,15 @@ data HierarchyDiff
   deriving stock ( Show, Generic )
   deriving anyclass NFData
 
+data DeleteLayer
+  = DeleteLayer
+      { delUnique   :: !Unique
+      , delIsGroup  :: !Bool
+      , delPosition :: !Word32
+      }
+  deriving stock ( Show, Generic )
+  deriving anyclass NFData
+
 -- | A subdivision of a single stroke.
 data Subdivision
   = Subdivision
@@ -123,6 +131,8 @@ data ContentDiff
       }
   | CloseStroke
       { closedStroke :: !Unique }
+  | DeletePoints
+      { deletedPoints :: !StrokePoints }
   | ContinueStroke
       { continuedStroke :: !Unique
       , newSegment :: !( Spline Open () ( PointData () ) )

src/metabrushes/MetaBrush/Draw.hs

@@ -177,8 +177,8 @@ getOrCreateDrawAnchor uniqueSupply mbBrush c doc@( Document { documentContent =
   where
     zoom = documentZoom documentMetadata
 
-    findAnchor :: Unique -> Stroke -> StrokeMetadata -> Except DrawAnchor UpdateStroke
-    findAnchor strokeUnique ( Stroke { strokeSpline }) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
+    findAnchor :: WithinParent Unique -> Stroke -> StrokeMetadata -> Except DrawAnchor UpdateStroke
+    findAnchor ( WithinParent _ strokeUnique ) ( Stroke { strokeSpline }) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
       when ( strokeVisible && not strokeLocked ) $
         findAnchorSpline strokeSpline
       return PreserveStroke
@@ -243,8 +243,8 @@ addToAnchor anchor newSpline doc@( Document { documentMetadata, documentContent
   in doc { documentContent = oldContent { strokeHierarchy = strokes' } }
   where
 
-    updateStroke :: forall s. Unique -> Stroke -> ST s UpdateStroke
-    updateStroke strokeUnique stroke@( Stroke { strokeSpline = ( oldSpline :: StrokeSpline clo brushParams ) })
+    updateStroke :: forall s. WithinParent Unique -> Stroke -> ST s UpdateStroke
+    updateStroke ( WithinParent _ strokeUnique ) stroke@( Stroke { strokeSpline = ( oldSpline :: StrokeSpline clo brushParams ) })
       | strokeUnique == anchorStroke anchor
       , SOpen <- ssplineType @clo
       , let prevSpline0 = coCache @RealWorld @s oldSpline

src/metabrushes/MetaBrush/Layer.hs

@@ -1,12 +1,11 @@
 module MetaBrush.Layer where
 
 -- base
-import Data.Maybe
-  ( fromJust )
 import Data.Word
   ( Word32 )
 import GHC.Generics
   ( Generically(..), Generic )
+import GHC.Stack
 
 -- containers
 import Data.Map.Strict
@@ -24,6 +23,8 @@ import Data.Text
   ( Text )
 
 -- MetaBrush
+import Debug.Utils
+  ( trace )
 import MetaBrush.Unique
   ( Unique )
 
@@ -89,8 +90,15 @@ emptyHierarchy =
     , content  = Map.empty
     }
 
-lookupChildren :: Parent Unique -> Hierarchy a -> [ Unique ]
-lookupChildren p h = fromJust $ lookupChildren_maybe p h
+lookupChildren :: HasCallStack => Parent Unique -> Hierarchy a -> [ Unique ]
+lookupChildren p h = case lookupChildren_maybe p h of
+  Nothing ->
+    trace ( unlines [ "internal error in 'lookupChildren'"
+                    , "no data for parent " ++ show p
+                    , ""
+                    , "call stack: " ++ prettyCallStack callStack ]
+                    ) []
+  Just cs -> cs
 
 lookupChildren_maybe :: Parent Unique -> Hierarchy a -> Maybe [ Unique ]
 lookupChildren_maybe Root ( Hierarchy { topLevel } ) = Just topLevel

src/metabrushes/MetaBrush/Stroke.hs

@@ -14,10 +14,11 @@ import Data.Foldable
   ( foldr' )
 import Data.Functor.Identity
   ( Identity(..) )
+import Data.Maybe
+  ( mapMaybe )
 import GHC.Generics
   ( Generic, Generic1 )
 import GHC.Stack
-  ( HasCallStack )
 import GHC.TypeLits
   ( Symbol )
 import Unsafe.Coerce
@@ -75,17 +76,17 @@ import Math.Module
   )
 import Math.Linear
   ( ℝ(..), T(..) )
+import Debug.Utils
+  ( trace )
 
 -- MetaBrush
 import MetaBrush.Brush
   ( NamedBrush, PointFields )
 import MetaBrush.Layer
-    ( Hierarchy(..), LayerMetadata(..), emptyHierarchy )
+    ( Hierarchy(..), LayerMetadata(..), emptyHierarchy, WithinParent (..), Parent (..) )
 import MetaBrush.Records
 import MetaBrush.Unique
   ( Unique, UniqueSupply, freshUnique )
-import MetaBrush.Util
-  ( (!) )
 
 --------------------------------------------------------------------------------
 
@@ -274,44 +275,56 @@ forStrokeHierarchy
   .  ( HasCallStack, Applicative f )
   => LayerMetadata
   -> StrokeHierarchy
-  -> ( Unique -> Stroke -> StrokeMetadata -> f UpdateStroke )
+  -> ( WithinParent Unique -> Stroke -> StrokeMetadata -> f UpdateStroke )
   -> f StrokeHierarchy
 forStrokeHierarchy
   ( LayerMetadata { layerNames, invisibleLayers, lockedLayers } ) hierarchy0 f =
-    foldr' ( g Nothing ( True, False ) ) ( pure hierarchy0 ) ( topLevel hierarchy0 )
+    foldr' ( g Root ( True, False ) ) ( pure hierarchy0 ) ( topLevel hierarchy0 )
   where
 
-    insertMaybe :: Maybe Unique -> Unique -> StrokeHierarchy -> UpdateStroke -> StrokeHierarchy
+    insertMaybe :: Parent Unique -> Unique -> StrokeHierarchy -> UpdateStroke -> StrokeHierarchy
     insertMaybe mbPar u old@( Hierarchy oldTl oldGps oldStrokes ) = \case
       PreserveStroke   -> old
       UpdateStrokeTo s -> Hierarchy oldTl oldGps ( Map.insert u s oldStrokes )
       DeleteStroke     ->
         let newStrokes = Map.delete u oldStrokes
          in case mbPar of
-              Nothing ->
+              Root ->
                 Hierarchy ( filter ( /= u ) oldTl ) oldGps newStrokes
-              Just par ->
+              Parent par ->
                 Hierarchy oldTl ( Map.adjust ( filter ( /= u ) ) par oldGps ) newStrokes
 
 
-    g :: Maybe Unique -> ( Bool, Bool ) -> Unique -> f StrokeHierarchy -> f StrokeHierarchy
+    g :: Parent Unique -> ( Bool, Bool ) -> Unique -> f StrokeHierarchy -> f StrokeHierarchy
     g par ( vis, lock ) u acc =
       let vis'  = vis && not ( u `Set.member` invisibleLayers )
           lock' = lock || u `Set.member` lockedLayers
       in
         case Map.lookup u ( groups hierarchy0 ) of
           Nothing ->
-            let
-              meta =
-                StrokeMetadata
-                  { strokeName    = layerNames ! u
-                  , strokeVisible = vis'
-                  , strokeLocked  = lock'
-                  }
-            in
-              insertMaybe par u <$> acc <*> f u ( content hierarchy0 ! u ) meta
+            case ( Map.lookup u layerNames, Map.lookup u ( content hierarchy0 ) ) of
+              ( Just strokeName, Just oldStroke ) ->
+                let
+                  meta =
+                    StrokeMetadata
+                      { strokeName
+                      , strokeVisible = vis'
+                      , strokeLocked  = lock'
+                      }
+                in
+                  insertMaybe par u <$> acc <*> f ( WithinParent par u ) oldStroke meta
+              _ ->
+                trace
+                  ( unlines
+                    [ "internal error in 'forStrokeHierarchy'"
+                    , "failed to look up stroke with unique " ++ show u
+                    , ""
+                    , "call stack: " ++ prettyCallStack callStack
+                    ]
+                  ) acc
+
           Just ds ->
-            foldr' ( g ( Just u ) ( vis', lock' ) ) acc ds
+            foldr' ( g ( Parent u ) ( vis', lock' ) ) acc ds
 
 --------------------------------------------------------------------------------
 
@@ -338,29 +351,48 @@ data Layer
       }
   deriving stock Show
 
-strokeHierarchyLayers :: LayerMetadata -> StrokeHierarchy -> Layers
+strokeHierarchyLayers :: HasCallStack => LayerMetadata -> StrokeHierarchy -> Layers
 strokeHierarchyLayers
   ( LayerMetadata { layerNames, invisibleLayers, lockedLayers } )
-  ( Hierarchy topLevel hierarchy content ) = map go topLevel
+  ( Hierarchy topLevel hierarchy content ) = mapMaybe go topLevel
     where
-      go :: Unique -> Layer
+      go :: Unique -> Maybe Layer
       go layerUnique =
         let
-          layerName    = layerNames ! layerUnique
           layerVisible = not $ layerUnique `Set.member` invisibleLayers
           layerLocked  = layerUnique `Set.member` lockedLayers
         in
           case Map.lookup layerUnique hierarchy of
-            Nothing ->
-              StrokeLayer
-                { layerName, layerVisible, layerLocked
-                , layerStroke = content ! layerUnique
-                }
-            Just cs ->
-              GroupLayer
-                { layerName, layerVisible, layerLocked
-                , groupChildren = map go cs
-                }
+            Nothing
+              | Just layerName   <- Map.lookup layerUnique layerNames
+              , Just layerStroke <- Map.lookup layerUnique content
+              ->
+              Just $
+                StrokeLayer
+                  { layerName, layerVisible, layerLocked, layerStroke }
+              | otherwise
+              -> trace
+                   ( unlines [ "internal error in 'strokeHierarchyLayers"
+                             , "could not retrieve data for layer with unique: " ++ show layerUnique
+                             , ""
+                             , "call stack: " ++ prettyCallStack callStack
+                             ]
+                   ) Nothing
+            Just cs
+              | Just layerName <- Map.lookup layerUnique layerNames
+              ->  Just $
+                    GroupLayer
+                      { layerName, layerVisible, layerLocked
+                      , groupChildren = mapMaybe go cs
+                      }
+              | otherwise
+              -> trace
+                   ( unlines [ "internal error in 'strokeHierarchyLayers"
+                             , "could not retrieve data for group with unique: " ++ show layerUnique
+                             , ""
+                             , "call stack: " ++ prettyCallStack callStack
+                             ]
+                   ) Nothing
 
 {-# INLINEABLE layersStrokeHierarchy #-}
 layersStrokeHierarchy :: forall m. MonadIO m => Layers -> ReaderT UniqueSupply m ( LayerMetadata, StrokeHierarchy )

src/metabrushes/MetaBrush/Util.hs

@@ -1,25 +1,8 @@
 module MetaBrush.Util
-  ( Exists(..)
-  , (!)
-  )
+  ( Exists(..) )
   where
 
--- base
-import GHC.Stack
-  ( HasCallStack )
-
--- containers
-import Data.Map.Strict
-  ( Map )
-import qualified Data.Map.Strict as Map
-
 --------------------------------------------------------------------------------
 
 data Exists c where
   Exists :: c a => a -> Exists c
-
-infixl 9 !
-(!) :: ( Show k, Ord k, HasCallStack ) => Map k a -> k -> a
-m ! k = case Map.lookup k m of
-  Nothing -> error $ "MetaBrush internal error: key not in map: " ++ show k
-  Just a -> a