WIP on brush repo (does not compile)

MetaBrush.cabal

@@ -241,6 +241,7 @@ executable MetaBrush
       , MetaBrush.Render.Document
       , MetaBrush.Render.Rulers
       , MetaBrush.Time
+      , MetaBrush.UI.BrushList
       , MetaBrush.UI.Coordinates
       , MetaBrush.UI.FileBar
       , MetaBrush.UI.InfoBar

src/app/MetaBrush/UI/StrokeTreeView.hs

@@ -53,7 +53,7 @@ import qualified Data.GI.Base.Overloading as GI
 
 -- lens
 import Control.Lens
-  ( over )
+  ( ix, over )
 
 -- stm
 import qualified Control.Concurrent.STM.TVar as STM
@@ -102,6 +102,17 @@ instance GI.DerivedGObject LayerItem where
   objectInstanceInit _ _ = return Nothing
   objectInterfaces = [ ]
 
+--------------------------------------------------------------------------------
+-- Drag and drop data --
+------------------------
+
+-- | Data passed in a drag-and-drop operation associated with the drag source.
+data DragSourceData
+  = DragBrush     { draggedBrushName :: !Text }
+  | DragLayerItem { draggedLayerItem :: !ChildLayer }
+  deriving stock ( Show, Eq )
+
+
 --------------------------------------------------------------------------------
 -- GTK TreeListModel --
 -----------------------
@@ -480,10 +491,11 @@ newLayerView uiElts@( UIElements { panelsBar = PanelsBar { layersScrolledWindow
             GTK.singleSelectionSetSelected selModel rowPos
 
           let dnd_sourceItem =
-                WithinParent
+                DragLayerItem $
-                  { parent = fmap snd srcPar
+                  WithinParent
-                  , item = srcUniq
+                    { parent = fmap snd srcPar
-                  }
+                    , item = srcUniq
+                    }
 
           val <- GDK.contentProviderNewForValue =<< GIO.toGValue ( GI.HValue dnd_sourceItem )
           GTK.widgetAddCssClass layersScrolledWindow "dragging-item"
@@ -532,147 +544,162 @@ newLayerView uiElts@( UIElements { panelsBar = PanelsBar { layersScrolledWindow
           --  LayerID {} -> return True
         void $ GTK.onDropTargetDrop dropTarget $ \ val _x y -> do
           dropTargetCleanup
-          dropTgtUniq <- layerUnique <$> getLayerData listItem
+          dropTgt <- getLayerData listItem
 
-          GI.HValue dragSrc@( WithinParent { item = dragSrcUniq }) <-
+          GI.HValue dnd_data <- GIO.fromGValue @( GI.HValue DragSourceData ) val
-            GIO.fromGValue @( GI.HValue ChildLayer ) val
 
           mbTreeListRow <- traverse ( GTK.unsafeCastTo GTK.TreeListRow ) =<< GTK.listItemGetItem listItem
           treeListRow <- case mbTreeListRow of
               Nothing -> error "newLayerView ListItem onSetup: no TreeListRow"
               Just r -> return r
-
-          dstFlatIndex <- GTK.treeListRowGetPosition treeListRow
-          h <- GTK.widgetGetHeight expander
-          let droppedAbove = y < 0.5 * fromIntegral h
-          expanded <- GTK.treeListRowGetExpanded treeListRow
-
           dstPar <- getParent treeListRow
-          isDescendant <- isDescendantOf dragSrcUniq listItem
 
-          let mbDropIntoGroup
+          case dnd_data of
-                | expanded
+            DragBrush brushName -> do
-                , not droppedAbove
+              case dropTgt of
-                , not isDescendant
+                GroupLayer {} ->
-                = Just treeListRow
+                  return False
-                | otherwise
+                StrokeLayer tgtStrokeUnique -> do
-                = Nothing
+                  updateLayerHierarchy vars $
-              mbDropOutsideGroup
+                    DoLayerChange $
-                | dragSrcUniq == dropTgtUniq
+                      SetBrush
-                , Parent par <- dstPar
+                        { setBrushStroke =  WithinParent ( fmap snd dstPar ) tgtStrokeUnique
-                , not droppedAbove
+                        , setBrushName   = brushName
-                = Just par
-                | otherwise
-                = Nothing
-
-          if isDescendant && isNothing mbDropOutsideGroup
-          then do
-            return False
-          else do
-            -- Compute the destination parent.
-            -- Usually, the destination parent is the parent of the drop target.
-            -- BUT:
-            --  1. when dropping an item into the first position of an
-            --     expanded group, the destination parent is the drop target itself,
-            --     not the parent of the drop target.
-            --  2. when an item is at the bottom of a group, dropping it on its
-            --     lower half moves the item out of the group, so the
-            --     destination parent is the grand-parent of the drop target.
-            ( dropDst, newPosInTree ) <-
-              if
-                -- (1)
-                | Just dstParRow <- mbDropIntoGroup
-                -> do
-                    dstParFlatIndex <- GTK.treeListRowGetPosition dstParRow
-                    return $
-                      ( MoveToTopOfGroup dropTgtUniq
-                      , dstParFlatIndex + 1
-                      )
-                -- (2)
-                | Just ( dstParRow, dstParUniq ) <- mbDropOutsideGroup
-                -> do
-                    grandPar <- getParent dstParRow
-                    return $
-                      ( MoveItemOutsideGroupIfLastItemInGroup
-                          { itemUnique        = dropTgtUniq
-                          , parentUnique      = dstParUniq
-                          , grandParentUnique = fmap snd grandPar
-                          , itemExpanded      = expanded
-                          }
-                      , dstFlatIndex + 1
-                      )
-                | otherwise
-                -> do
-                  return $
-                    ( MoveAboveOrBelow
-                        { moveDstItem =
-                            WithinParent
-                              { parent = fmap snd dstPar
-                              , item = dropTgtUniq
-                              }
-                        , moveAbove = droppedAbove
                         }
-                    , if droppedAbove then dstFlatIndex else dstFlatIndex + 1
+                  return True
-                    )
 
-            -- Compute the position that the item we are moving will have
+            DragLayerItem dragSrc@( WithinParent { item = dragSrcUniq }) -> do
-            -- at the end of the move.
+              let dropTgtUniq = layerUnique dropTgt
-            --
+              dstFlatIndex <- GTK.treeListRowGetPosition treeListRow
-            -- First, we compute whether we moved up or down.
+              h <- GTK.widgetGetHeight expander
-            -- NB: we need to compute the source item position now (using 'treeListRowGetPosition'),
+              let droppedAbove = y < 0.5 * fromIntegral h
-            -- at the end of the drag-and-drop operation, because TreeExpander nodes
+              expanded <- GTK.treeListRowGetExpanded treeListRow
-            -- might have expanded/collapsed in the meantime.
-            mbSelModel <- GTK.listViewGetModel listView
-            case mbSelModel of
-              Nothing -> return False
-              Just selModel0 -> do
-                selModel <- GTK.unsafeCastTo GTK.SingleSelection selModel0
-                layersListModel
-                  <- GTK.unsafeCastTo GTK.TreeListModel =<< fmap fromJust ( GTK.singleSelectionGetModel selModel )
 
-                mbSelItem <- GTK.singleSelectionGetSelectedItem selModel
+              isDescendant <- isDescendantOf dragSrcUniq listItem
-                mbSelIx <- for mbSelItem $ \ selItem -> do
-                  selRow <- GTK.unsafeCastTo GTK.TreeListRow selItem
-                  GTK.treeListRowGetPosition selRow
 
-                -- Now compute the final destination position.
+              let mbDropIntoGroup
-                mbDstPosAfterShift <-
+                    | expanded
-                  case mbSelIx of
+                    , not droppedAbove
-                    Nothing ->
+                    , not isDescendant
-                      return Nothing
+                    = Just treeListRow
-                    Just selIx
+                    | otherwise
-                      -- If we moved up, simply use the destination position.
+                    = Nothing
-                      | selIx >= newPosInTree
+                  mbDropOutsideGroup
-                      -> return $ Just newPosInTree
+                    | dragSrcUniq == dropTgtUniq
-                      | otherwise
+                    , Parent par <- dstPar
-                      -> do
+                    , not droppedAbove
-                      -- If we moved down, we need to substract the number of items
+                    = Just par
-                      -- moved. Note that this depends on which TreeExpander nodes
+                    | otherwise
-                      -- are expanded.
+                    = Nothing
-                      mbSelRow <- GTK.treeListModelGetRow layersListModel selIx
-                      case mbSelRow of
-                        Nothing -> return Nothing
-                        Just selRow0 -> do
-                          selRow <- GTK.unsafeCastTo GTK.TreeListRow selRow0
-                          nbDescendants <- getNbExpandedDescendants layersListModel selRow
-                          return $
-                            if newPosInTree < nbDescendants
-                            then Nothing
-                            else Just $ newPosInTree - nbDescendants
 
-                updateLayerHierarchy vars $
+              if isDescendant && isNothing mbDropOutsideGroup
-                  DoLayerChange $
+              then do
-                    Move
+                return False
-                      { moveSrc = dragSrc
+              else do
-                      , moveDst = dropDst
+                -- Compute the destination parent.
-                      }
+                -- Usually, the destination parent is the parent of the drop target.
+                -- BUT:
+                --  1. when dropping an item into the first position of an
+                --     expanded group, the destination parent is the drop target itself,
+                --     not the parent of the drop target.
+                --  2. when an item is at the bottom of a group, dropping it on its
+                --     lower half moves the item out of the group, so the
+                --     destination parent is the grand-parent of the drop target.
+                ( dropDst, newPosInTree ) <-
+                  if
+                    -- (1)
+                    | Just dstParRow <- mbDropIntoGroup
+                    -> do
+                        dstParFlatIndex <- GTK.treeListRowGetPosition dstParRow
+                        return $
+                          ( MoveToTopOfGroup dropTgtUniq
+                          , dstParFlatIndex + 1
+                          )
+                    -- (2)
+                    | Just ( dstParRow, dstParUniq ) <- mbDropOutsideGroup
+                    -> do
+                        grandPar <- getParent dstParRow
+                        return $
+                          ( MoveItemOutsideGroupIfLastItemInGroup
+                              { itemUnique        = dropTgtUniq
+                              , parentUnique      = dstParUniq
+                              , grandParentUnique = fmap snd grandPar
+                              , itemExpanded      = expanded
+                              }
+                          , dstFlatIndex + 1
+                          )
+                    | otherwise
+                    -> do
+                      return $
+                        ( MoveAboveOrBelow
+                            { moveDstItem =
+                                WithinParent
+                                  { parent = fmap snd dstPar
+                                  , item = dropTgtUniq
+                                  }
+                            , moveAbove = droppedAbove
+                            }
+                        , if droppedAbove then dstFlatIndex else dstFlatIndex + 1
+                        )
 
-                -- After moving, update the selected item to be the moved item.
+                -- Compute the position that the item we are moving will have
-                case mbDstPosAfterShift of
+                -- at the end of the move.
-                  Nothing -> return ()
+                --
-                  Just dstPos ->
+                -- First, we compute whether we moved up or down.
-                    GTK.singleSelectionSetSelected selModel dstPos
+                -- NB: we need to compute the source item position now (using 'treeListRowGetPosition'),
-                return True
+                -- at the end of the drag-and-drop operation, because TreeExpander nodes
+                -- might have expanded/collapsed in the meantime.
+                mbSelModel <- GTK.listViewGetModel listView
+                case mbSelModel of
+                  Nothing -> return False
+                  Just selModel0 -> do
+                    selModel <- GTK.unsafeCastTo GTK.SingleSelection selModel0
+                    layersListModel
+                      <- GTK.unsafeCastTo GTK.TreeListModel =<< fmap fromJust ( GTK.singleSelectionGetModel selModel )
+
+                    mbSelItem <- GTK.singleSelectionGetSelectedItem selModel
+                    mbSelIx <- for mbSelItem $ \ selItem -> do
+                      selRow <- GTK.unsafeCastTo GTK.TreeListRow selItem
+                      GTK.treeListRowGetPosition selRow
+
+                    -- Now compute the final destination position.
+                    mbDstPosAfterShift <-
+                      case mbSelIx of
+                        Nothing ->
+                          return Nothing
+                        Just selIx
+                          -- If we moved up, simply use the destination position.
+                          | selIx >= newPosInTree
+                          -> return $ Just newPosInTree
+                          | otherwise
+                          -> do
+                          -- If we moved down, we need to substract the number of items
+                          -- moved. Note that this depends on which TreeExpander nodes
+                          -- are expanded.
+                          mbSelRow <- GTK.treeListModelGetRow layersListModel selIx
+                          case mbSelRow of
+                            Nothing -> return Nothing
+                            Just selRow0 -> do
+                              selRow <- GTK.unsafeCastTo GTK.TreeListRow selRow0
+                              nbDescendants <- getNbExpandedDescendants layersListModel selRow
+                              return $
+                                if newPosInTree < nbDescendants
+                                then Nothing
+                                else Just $ newPosInTree - nbDescendants
+
+                    updateLayerHierarchy vars $
+                      DoLayerChange $
+                        Move
+                          { moveSrc = dragSrc
+                          , moveDst = dropDst
+                          }
+
+                    -- After moving, update the selected item to be the moved item.
+                    case mbDstPosAfterShift of
+                      Nothing -> return ()
+                      Just dstPos ->
+                        GTK.singleSelectionSetSelected selModel dstPos
+                    return True
 
         void $ GTK.onDropTargetEnter dropTarget $ \ _x y -> do
           GTK.widgetAddCssClass expander "drag-over"
@@ -880,6 +907,10 @@ data LayerChange
   | Delete
       { deleteItem :: !ChildLayer
       }
+  | SetBrush
+      { setBrushStroke :: !ChildLayer
+      , setBrushName   :: !Text
+      }
 
 -- | Destination of a move operation.
 data MoveDst
@@ -1092,6 +1123,25 @@ applyChangeToLayerHierarchy change hierarchy =
               , delIsGroup  = isJust mbHadChildren
               }
         )
+    SetBrush { setBrushStroke = WithinParent parUniq strokeUnique, setBrushName } ->
+      let
+        ( hierarchy', strokeIx ) =
+          over ( field' @"documentContent"
+               . field' @"strokeHierarchy"
+               . field' @"content"
+               )
+            ( setStrokeBrush brushName )
+            doc
+
+      in
+        ( hierarchy'
+        , Map.empty
+        , Just $
+            StrokeSetBrush
+              { changedBrushStroke = WithinParent parUniq strokeIx
+              , newBrushName = setBrushName
+              }
+        )
 
 -- | Apply a change to the 'ListModel' underlying the UI
 -- representation of the layer hierarchy.
@@ -1148,6 +1198,9 @@ applyDiffToListModel parStoreTVar docUnique ( doOrUndo, diff ) = do
     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
 
 -- | Update the 'StrokeHierarchy' after a drag-and-drop operation,
 -- moving one layer or group around.

src/metabrushes/MetaBrush/Document/Diff.hs

@@ -13,6 +13,10 @@ import Data.Set
 import Control.DeepSeq
   ( NFData(..) )
 
+-- text
+import Data.Text
+  ( Text )
+
 -- brush-strokes
 import Math.Bezier.Spline
 import Math.Linear
@@ -73,6 +77,10 @@ data HierarchyDiff
       , srcPos :: !ChildLayerPosition
       , dstPos :: !ChildLayerPosition
       }
+  | StrokeSetBrush
+      { changedBrushStroke :: !ChildLayerPosition
+      , newBrushName       :: !Text
+      }
   deriving stock ( Show, Generic )
   deriving anyclass NFData