Main.hs

{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE RecursiveDo #-}

module Main where

-- base
import Control.Monad
  ( unless, void, when )
import Data.Foldable
  ( for_, traverse_ )
import Data.List
  ( elemIndex )
import Data.Maybe
  ( catMaybes, fromMaybe, fromJust, isNothing )
import Data.Traversable
  ( for )
import Data.Word
  ( Word32, Word64 )
import GHC.Stack
  ( HasCallStack )
import System.Environment
  ( setEnv )
import System.Exit
  ( ExitCode(..), exitWith, exitSuccess )

-- containers
import Data.Map.Strict
  ( Map )
import qualified Data.Map.Strict as Map
import Data.Set
  ( Set )
import qualified Data.Set as Set
import Data.Sequence
  ( Seq )
import qualified Data.Sequence as Seq

-- directory
import qualified System.Directory as Directory
  ( canonicalizePath )

-- haskell-gi-base
import qualified Data.GI.Base as GI
import qualified Data.GI.Base.GObject as GI
import qualified Data.GI.Base.GType as GI
import qualified Data.GI.Base.GValue as GI
import qualified Data.GI.Base.Overloading as GI

-- gi-gdk
import qualified GI.Gdk as GDK

-- gi-gio
import qualified GI.Gio as GIO

-- gi-gobject
import qualified GI.GObject as GObject

-- gi-gtk
import qualified GI.Gtk as GTK

-- stm
import qualified Control.Concurrent.STM.TVar as STM
import qualified Control.Concurrent.STM.TMVar as STM
import qualified Control.Monad.STM as STM

-- text
import Data.Text
  ( Text )
import qualified Data.Text as Text

-- gtk-layers
import qualified Paths_gtk_layers as Cabal
  ( getDataFileName )

--------------------------------------------------------------------------------
-- Main application --
----------------------

main :: IO ()
main = do
  -- Some useful environment variables:
  --
  setEnv "GDK_SCALE"    "2"                   -- scale the UI up by a factor
  --setEnv "GSK_RENDERER" "ngl"               -- choose rendering backend
  --setEnv "GTK_DEBUG"    "actions,layout"    -- GTK debug info
  --setEnv "GDK_DEBUG"    "events,opengl,dnd" -- GDK debug info
  --setEnv "GSK_DEBUG"    "full-redraw"       -- force redraws
  application <- GTK.applicationNew ( Just "com.layers" ) [ ]
  GIO.applicationRegister application ( Nothing @GIO.Cancellable )
  void $ GIO.onApplicationActivate application ( runApplication application )
  exitCode <- GIO.applicationRun application Nothing
  GObject.objectUnref application
  case exitCode of
    0 -> exitSuccess
    _ -> exitWith ( ExitFailure $ fromIntegral exitCode )

-- | UI elements that might need to be dynamically edited.
data UIElements
  = UIElements
  { layersContainer        :: !GTK.ScrolledWindow
      -- ^ Container for the layer hierarchy display.
  , layersListModel        :: !GTK.TreeListModel
      -- ^ The underlying 'GTK.TreeListModel' of the layer hierarchy.
  , layersDebugLabel       :: !GTK.Label
     -- ^ Label that displays the layer hierarchy textually.
  , undoButton, redoButton :: !GTK.Button

  }

-- | Global state of the application.
data Variables
  = Variables
  { uniqueTVar  :: !( STM.TVar Unique )
     -- ^ 'STM.TVar' used as an unique supply.
  , historyTVar :: !( STM.TVar History )
     -- ^ The application state, enabling undo/redo.

    -- | This TVar allows us to look up which 'GIO.ListStore' is used
    -- for the children of a given parent.
    --
    -- This allows us to know, given a parent and a child index,
    -- how to insert/delete from the 'GTK.TreeListModel'.
  , parStoreFromUniqTVar :: !( STM.TVar ( 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 () )
  }

runApplication :: GTK.Application -> IO ()
runApplication application = do

  window <- GTK.applicationWindowNew application
  GTK.setWindowTitle window "Layers"
  GTK.windowSetDefaultSize window 640 480

  display     <- GTK.rootGetDisplay window
  cssProvider <- GTK.cssProviderNew
  themePath   <- Directory.canonicalizePath =<< Cabal.getDataFileName "theme.css"
  GTK.cssProviderLoadFromPath cssProvider themePath
  GTK.styleContextAddProviderForDisplay display cssProvider 1000
  GTK.widgetAddCssClass window "gtk-layers"

  uniqueTVar  <- STM.newTVarIO @Unique  testInitialUnique
  historyTVar <- STM.newTVarIO @History testInitialHistory
  parStoreFromUniqTVar <- STM.newTVarIO Map.empty
  listModelUpToDateTMVar <- STM.newTMVarIO ()
  let variables = Variables { uniqueTVar, historyTVar, parStoreFromUniqTVar, listModelUpToDateTMVar }

  contentPane <- GTK.panedNew GTK.OrientationHorizontal
  -- Set the paned handle to "wide", otherwise the handle can eat input around it.
  GTK.panedSetWideHandle contentPane True
  layersScrolledWindow <- GTK.scrolledWindowNew
  GTK.scrolledWindowSetPolicy layersScrolledWindow GTK.PolicyTypeNever GTK.PolicyTypeAutomatic

  leftBox <- GTK.boxNew GTK.OrientationVertical 10
  buttonsBox <- GTK.boxNew GTK.OrientationHorizontal 10
  GTK.widgetSetValign buttonsBox GTK.AlignEnd
  GTK.widgetSetHalign buttonsBox GTK.AlignCenter
  GTK.widgetSetMarginBottom leftBox 10

  layersDebugLabel <- GTK.labelNew ( Just $ uncurry prettyLayers $ present testInitialHistory )
  GTK.widgetSetVexpand layersDebugLabel True
  GTK.boxAppend leftBox layersDebugLabel
  GTK.boxAppend leftBox buttonsBox

  GTK.panedSetStartChild contentPane ( Just leftBox )
  GTK.panedSetEndChild   contentPane ( Just layersScrolledWindow )

  newLayerButton    <- GTK.buttonNewWithLabel "New layer"
  newGroupButton    <- GTK.buttonNewWithLabel "New group"
  deleteLayerButton <- GTK.buttonNewWithLabel "Delete"
  undoButton        <- GTK.buttonNewWithLabel "Undo"
  redoButton        <- GTK.buttonNewWithLabel "Redo"

  traverse_ ( GTK.boxAppend buttonsBox )
    [ newLayerButton, newGroupButton, deleteLayerButton, undoButton, redoButton ]

  -- Undo/redo buttons should only be active when there is something to undo/redo.
  traverse_ ( \ button -> GTK.widgetSetSensitive button False )
    [ undoButton, redoButton ]

  layersListModel <- newLayersListModel variables

  let uiElts =
        UIElements
          { layersContainer = layersScrolledWindow
          , layersListModel
          , layersDebugLabel
          , undoButton, redoButton
          }

  layersView <- newLayerView uiElts variables
  GTK.listViewSetShowSeparators layersView False

  GTK.scrolledWindowSetChild layersScrolledWindow ( Just layersView )

  void $ GTK.onButtonClicked newLayerButton $ do
    u <- getUnique uniqueTVar
    mbSelectedItem <- getSelectedItem layersView
    let change = NewItem { newUnique = u, newIsGroup = False, newSelected = mbSelectedItem }
    updateLayerHierarchy uiElts variables ( DoChange change )
  void $ GTK.onButtonClicked newGroupButton $ do
    u <- getUnique uniqueTVar
    mbSelectedItem <- getSelectedItem layersView
    let change = NewItem { newUnique = u, newIsGroup = True, newSelected = mbSelectedItem }
    updateLayerHierarchy uiElts variables ( DoChange change )
  void $ GTK.onButtonClicked deleteLayerButton $ do
    mbSelectedItem <- getSelectedItem layersView
    case mbSelectedItem of
      Nothing ->
        -- The SingleSelection SelectionModel defaults to autoselect=true,
        -- so there should always be an item selected.
        return ()
      Just selItem -> do
        let change = Delete { deleteItem = selItem }
        updateLayerHierarchy uiElts variables ( DoChange change )
  void $ GTK.onButtonClicked undoButton $ do
    updateLayerHierarchy uiElts variables UndoChange
  void $ GTK.onButtonClicked redoButton $ do
    updateLayerHierarchy uiElts variables RedoChange

  GTK.windowSetChild window ( Just contentPane )
  GTK.widgetSetVisible layersView True
  GTK.widgetSetVisible window True

  void $ GTK.onApplicationQueryEnd application $
    GTK.applicationRemoveWindow application window

--------------------------------------------------------------------------------
-- Application and UI state --
------------------------------

--------------
-- App data --
--------------

-- | A unique identifier; can be used for any kind of object.
newtype Unique = Unique { unique :: Word64 }
  deriving newtype ( Eq, Ord, Enum )
instance Show Unique where { show ( Unique i ) = "%" ++ show i }

-- | Get the next 'Unique', incrementing the counter by one.
getUnique :: STM.TVar Unique -> IO Unique
getUnique uniqueTVar =
  STM.atomically $
    STM.stateTVar uniqueTVar ( \ old -> ( old, succ old ) )

-- | The layer hierarchy.
--
-- This representation allows easy modifications, e.g. to move an item around
-- one simply needs to edit the map in two places, removing the item from its
-- old parent and adding it to its new parent.
--
-- This representation is chosen over a recursive data structure such as:
--
-- > type LayerHierarchy = [ Layer ]
-- > data Layer = Layer { .. } | Group { .., groupChildren :: LayerHierarchy }
--
-- as such a representation is more difficult to edit (in particular when
-- deeply nested items are involved).
type LayerHierarchy = Map ( Parent Unique ) ( Maybe [ Unique ] )
  -- TODO: use IntMap

-- | The application state, with history for undo/redo.
data History
  = History
  { past    :: !( Seq ( Content, Diff ) )
  , present :: !( Content, Metadata )
  , future  :: ![ ( Diff, Content ) ]
  }

-- | Main application content, subject to undo/redo.
data Content =
  Content
    { layerHierarchy :: !LayerHierarchy
    -- layerData :: !( Map Unique SomeData )
    }
  deriving stock Show

-- | Auxilary metadata about the application, not subject to undo/redo.
data Metadata =
  Metadata
    { names :: !( Map Unique Text )
    , invisibles :: !( Set Unique )
    }

-- | A parent of an item.
data Parent a
  -- | The item is at the top level.
  = Root
  -- | The item has this parent.
  | Parent !a
  deriving stock ( Show, Eq, Ord, Functor )

-----------------
-- GTK UI data --
-----------------

-- | Look up the name and visibility of a layer from the metadata.
layerNameAndVisible :: Metadata -> Unique -> ( Text, Bool )
layerNameAndVisible ( Metadata { names, invisibles } ) unique =
  ( names Map.! unique, unique `notElem` invisibles )

-- | Display the layer hierarchy (for debugging purposes).
prettyLayers :: Content -> Metadata -> Text
prettyLayers ( Content { layerHierarchy } ) meta =
  Text.intercalate "\n" $
    concatMap go ( fromMaybe [] $ layerHierarchy Map.! Root )
    where
      go :: Unique -> [ Text ]
      go i =
        let ( name, visible ) = layerNameAndVisible meta i
        in
          case layerHierarchy Map.! Parent i of
            Nothing ->
              [ "- Layer { layerName = \"" <> name <> "\", layerVisible = " <> Text.pack ( show visible ) <> " } " ]
            Just cs ->
              [ "- Group { layerName = \"" <> name <> "\", layerVisible = " <> Text.pack ( show visible ) <> " }" ]
              ++ concatMap ( map ( "  " <> ) . go ) cs

-- | Custom GTK object used to hold layer data.
--
-- These are the items that will get stored in the ListModel used by GTK
-- to store the layer hierarchy data.
newtype LayerItem = LayerItem ( GTK.ManagedPtr LayerItem )

instance GI.TypedObject LayerItem  where
  glibType = GI.registerGType LayerItem

instance GI.GObject LayerItem

instance GI.HasParentTypes LayerItem
type instance GI.ParentTypes LayerItem = '[ GObject.Object ]


-- | Data associated to a 'LayerItem', for use in the GTK UI state.
data LayerID
  = GroupID { layerUnique :: !Unique }
  | LayerID { layerUnique :: !Unique }
  deriving stock ( Eq, Show )

instance GI.DerivedGObject LayerItem where
  type GObjectParentType  LayerItem = GObject.Object
  type GObjectPrivateData LayerItem = Maybe LayerID
  objectTypeName = "gtk-layers-LayerItem"
  objectClassInit _ = return ()
  objectInstanceInit _ _ = return Nothing
  objectInterfaces = [ ]

--------------------------------------------------------------------------------
-- GTK TreeListModel --
-----------------------

-- | Create a new 'GTK.TreeListModel' from the given set of layers.
newLayersListModel :: Variables -> IO GTK.TreeListModel
newLayersListModel ( Variables { .. } ) = do
  itemType <- GI.glibType @LayerItem
  store <- GIO.listStoreNew itemType
  STM.atomically $
    STM.modifyTVar' parStoreFromUniqTVar ( Map.insert Root store )

  ( Content { layerHierarchy }, _ ) <- present <$> STM.readTVarIO historyTVar
  let topLayers = fromMaybe [] $ layerHierarchy Map.! Root
  for_ topLayers $ \ layerUniq -> do
    let mbChildren = layerHierarchy Map.! Parent layerUniq
        layer = case mbChildren of
          Nothing -> LayerID { layerUnique = layerUniq }
          Just {} -> GroupID { layerUnique = layerUniq }
    item <- GI.unsafeCastTo LayerItem =<< GI.new LayerItem []
    GI.gobjectSetPrivateData item ( Just layer )
    GIO.listStoreAppend store item

  rootModel <- GIO.toListModel store
  let passthrough = False -- Must not use passthrough to use TreeExpander widgets.
      autoExpand  = True  -- Autoexpand on creation; we later set this to False.

  -- Pass a copy of the (reference to the) root GIO.ListStore to the
  -- 'treeListModelNew' function to ensure we retain ownership of it.
  model <- GI.withManagedPtr rootModel $ \ rmPtr ->
           GI.withNewObject rmPtr $ \ rmCopy ->
             GTK.treeListModelNew rmCopy passthrough autoExpand createChildModel

  -- After the initial model has been created, we set "autoexpand" to False,
  -- so that if we move a non-expanded group, it doesn't get automatically
  -- expanded after it is moved.
  GTK.treeListModelSetAutoexpand model False

  return model

    where
      createChildModel :: GObject.Object -> IO ( Maybe GIO.ListModel )
      createChildModel parent = do
        dat <- getLayerData =<< GTK.unsafeCastTo LayerItem parent
        case dat of
          LayerID  {} -> return Nothing
          GroupID { layerUnique = groupUnique } -> do
            ( Content { layerHierarchy }, _ ) <- present <$> STM.readTVarIO historyTVar
            let children = fromMaybe [] $ layerHierarchy Map.! Parent groupUnique

            -- Try to re-use an existing list store, if there is one.
            mbOldChildStore <-
              STM.atomically $ do
                mbOldStore <-
                  Map.lookup ( Parent groupUnique ) <$> STM.readTVar parStoreFromUniqTVar
                when ( isNothing mbOldStore ) $
                  -- Take a lock to avoid creating multiple child stores
                  -- for the same group.
                  STM.takeTMVar listModelUpToDateTMVar
                return mbOldStore

            newChildStore <-
              case mbOldChildStore of
                Just oldStore -> do
                  return oldStore
                Nothing -> do
                  -- Otherwise, create a new child ListModel.
                  -- NB: create a simple GIO.ListStore, not a nested GTK.TreeListModel,
                  -- as that would cause e.g. grand-children models to be created twice.
                  itemType <- GI.glibType @LayerItem
                  childStore <- GIO.listStoreNew itemType

                  for_ children $ \ childUniq -> do
                    let mbChildChildren = layerHierarchy Map.! Parent childUniq
                        childLayer = case mbChildChildren of
                          Nothing -> LayerID { layerUnique = childUniq }
                          Just {} -> GroupID { layerUnique = childUniq }
                    item <- GI.unsafeCastTo LayerItem =<< GI.new LayerItem []
                    GI.gobjectSetPrivateData item ( Just childLayer )
                    GIO.listStoreAppend childStore item

                  -- Store the child store in our mapping from parent unique to
                  -- ListStore, so that we know where to insert children.
                  STM.atomically $ do
                    STM.modifyTVar parStoreFromUniqTVar
                      ( Map.insert ( Parent groupUnique ) childStore )
                    STM.putTMVar listModelUpToDateTMVar ()

                  return childStore

            -- Pass a copy of the (reference to the) child store
            -- to ensure we retain ownership of it.
            childModelCopy <- GI.withManagedPtr newChildStore $ \ childStorePtr ->
                              GI.withNewObject childStorePtr $ \ childStoreCopy ->
                              GIO.toListModel childStoreCopy

            return $ Just childModelCopy

-- | Gets the 'LayerItem' for a row in a 'GTK.TreeListModel'
-- with @passthrough = False@.
treeListItemLayerItem :: GTK.ListItem -> IO LayerItem
treeListItemLayerItem listItem = do
  mbListRow <- GTK.listItemGetItem listItem
  case mbListRow of
    Nothing -> error "treeListItemLayerItem: ListItem has no item"
    Just listRow ->
      treeListRowLayerItem =<< GTK.unsafeCastTo GTK.TreeListRow listRow

-- | Retrieve the 'LayerItem' underlying a 'GTK.TreeListRow'.
treeListRowLayerItem :: GTK.TreeListRow -> IO LayerItem
treeListRowLayerItem listRow = do
  mbListRowItem <- GTK.treeListRowGetItem listRow
  case mbListRowItem of
    Nothing   -> error "treeListRowLayerItem: TreeListRow has no item"
    Just item -> GTK.unsafeCastTo LayerItem item
      -- NB: if you made the mistake of passing a 'createChildModel' function
      -- which recursively creates a TreeListModel, you would have to recurse
      -- into the row using 'treeListRowGetItem' to eventually get at the
      -- underlying data.

-- | Class for objects which wrap a 'LayerItem'.
class HasLayerData a where
  -- | Get the layer data associated to a 'LayerItem' or object
  -- containing a 'LayerItem'.
  getLayerData :: HasCallStack => a -> IO LayerID
instance HasLayerData LayerItem where

  getLayerData item = do
    mbDat <- GI.gobjectGetPrivateData item
    case mbDat of
      Nothing -> error "getLayerData: no private data"
      Just dat -> return dat
instance HasLayerData GTK.TreeListRow where
  getLayerData row = do
    parLayerItem <- treeListRowLayerItem row
    getLayerData parLayerItem
instance HasLayerData GTK.ListItem where
  getLayerData listItem = do
    layerItem <- treeListItemLayerItem listItem
    getLayerData layerItem

-----------------------
-- GTK layer widgets --
-----------------------

-- | The generic widget used to display a list item.
--
-- Structure:
--
--  - ListItem
--    - TreeExpander
--      - ContentBox
--        - CheckButton
--        - Label
data LayerViewWidget =
  LayerViewWidget
    { layerViewContentBox  :: GTK.Box
    , layerViewCheckButton :: GTK.CheckButton
    , layerViewLabel       :: GTK.EditableLabel
    }

newLayerViewWidget :: IO GTK.TreeExpander
newLayerViewWidget = do

  expander <- GTK.treeExpanderNew

  GTK.treeExpanderSetIndentForIcon  expander True
  GTK.treeExpanderSetIndentForDepth expander True
  GTK.treeExpanderSetHideExpander   expander False

  contentBox <- GTK.boxNew GTK.OrientationHorizontal 20
  GTK.treeExpanderSetChild expander ( Just contentBox )

  checkBox <- GTK.checkButtonNew
  GTK.boxAppend contentBox checkBox
  itemLabel <- editableLabelNew
  GTK.boxAppend contentBox itemLabel

  return expander

-- | Create a new editable label, but remove any 'DragSource' or 'DropTarget'
-- controllers attached to it, as we don't want the label to participate in
-- drag-and-drop operations, especially because having it participate in
-- drag-and-drop operations triggers segfaults due to a GTK bug.
editableLabelNew :: IO GTK.EditableLabel
editableLabelNew = do
  label <- GTK.editableLabelNew " "
  widget <- GTK.toWidget label
  removeControllers widget
  return label

  where
    removeControllers widget = do
      controllers <- GTK.widgetObserveControllers widget
      nbControllers <- GIO.listModelGetNItems controllers
      unless ( nbControllers == 0 ) $
        for_ [ 0 .. nbControllers - 1 ] $ \ i -> do
          mbController <- GIO.listModelGetItem controllers i
          for_ mbController $ \ controller -> do
            mbDrag <- GTK.castTo GTK.DragSource controller
            mbDrop <- GTK.castTo GTK.DropTarget controller
            for_ mbDrag $ GTK.widgetRemoveController widget
            for_ mbDrop $ GTK.widgetRemoveController widget
      mbChild <- GTK.widgetGetFirstChild widget
      case mbChild of
        Nothing -> return ()
        Just c -> do
          removeControllers c
          removeControllersSiblings c
    removeControllersSiblings c = do
      mbNext <- GTK.widgetGetNextSibling c
      case mbNext of
        Nothing -> return ()
        Just next -> do
          removeControllers next
          removeControllersSiblings next

-- | Get the widget hierarchy for a list item, so that we can modify
-- the wdigets to display the appropriate content.
getLayerViewWidget :: GTK.TreeExpander -> IO LayerViewWidget
getLayerViewWidget expander = do
  mbContentBox <- GTK.treeExpanderGetChild expander
  case mbContentBox of
    Nothing -> error "getLayerViewWidget: expected ListItem->Expander->Box"
    Just contentBox0 -> do
      contentBox <- GTK.unsafeCastTo GTK.Box contentBox0
      mbCheckButton <- traverse ( GTK.unsafeCastTo GTK.CheckButton ) =<< GTK.widgetGetFirstChild contentBox
      case mbCheckButton of
        Nothing -> error "getLayerViewWidget: expected ListItem->Expander->Box->CheckButton"
        Just checkButton -> do
          mbLayerLabel <- traverse ( GTK.unsafeCastTo GTK.EditableLabel ) =<< GTK.widgetGetNextSibling checkButton
          case mbLayerLabel of
            Nothing -> error "getLayerViewWidget: expected ListItem->Expander->Box->{CheckButton,LayerLabel}"
            Just layerLabel ->
              return $
                LayerViewWidget
                  { layerViewContentBox = contentBox
                  , layerViewCheckButton = checkButton
                  , layerViewLabel = layerLabel
                  }

------------------
-- GTK ListView --
------------------

-- | Create a new 'GTK.ListView' that displays 'LayerItem's.
newLayerView :: UIElements -> Variables -> IO GTK.ListView
newLayerView
  uiElts@( UIElements { layersListModel, layersContainer, layersDebugLabel } )
  variables@( Variables { .. } ) = mdo

  layersListFactory <- GTK.signalListItemFactoryNew

  -- Connect to "setup" signal to create generic widgets for viewing the tree.
  --
  -- We attach a collection of signals to each widget,
  -- to handle e.g. drag-and-drop operations.
  --
  -- We attach the signals in the "setup" phase, because we don't want
  -- to have to keep attaching/removing event controllers to the widgets
  -- (in the "bind" and "unbind" stages).
  --
  -- However, in the "setup" phase, we don't yet know which underlying ListModel
  -- item we are displaying (this is only set on "bind").
  -- So: how can we set signal handlers in the "setup" phase? The answer is that
  -- each signal handler will read the private data associated to the widget;
  -- this data gets set when binding the widget to its ListModel item.
  _ <- GTK.onSignalListItemFactorySetup layersListFactory $ \ listItem0 -> do

        listItem <- GTK.unsafeCastTo GTK.ListItem listItem0
        GTK.listItemSetFocusable listItem False

        expander <- newLayerViewWidget
        GTK.listItemSetChild listItem ( Just expander )
        GTK.widgetAddCssClass expander "layer-item"

        LayerViewWidget
          { layerViewLabel = label
          , layerViewCheckButton = visibleButton }
            <- getLayerViewWidget expander

        ----------------------------
        -- Visibility CheckButton --
        ----------------------------

        void $ GTK.onCheckButtonToggled visibleButton $ do
          uniq <- layerUnique <$> getLayerData listItem
          visible <- GTK.checkButtonGetActive ?self
          ( newContent, newMetadata ) <- STM.atomically $ do
            hist@History { present = ( content, meta@( Metadata { invisibles } ) ) } <- STM.readTVar historyTVar
            let invisibles'
                  | visible
                  = Set.delete uniq invisibles
                  | otherwise
                  = Set.insert uniq invisibles
                meta' = meta { invisibles = invisibles' }
                hist' = hist { present = ( content, meta' ) }
            STM.writeTVar historyTVar hist'
            return ( content, meta' )
          let newDebugText = prettyLayers newContent newMetadata
          GTK.labelSetText layersDebugLabel newDebugText

        -------------------
        -- EditableLabel --
        -------------------

        -- Connect a signal for editing the layer name.
        --
        -- NB: we don't use the 'onEditableChanged' signal, as that updates
        -- after every key stroke.
        void $ GI.after label ( GI.PropertyNotify #hasFocus ) $ \ _ -> do
          newText <- GTK.editableGetText label
          dat <- getLayerData listItem
          History { present = ( newContent, newMetadata ) } <- STM.atomically $ do
            hist@History { present = ( layers, meta@( Metadata { names } ) ) } <- STM.readTVar historyTVar
            let names' = case dat of { LayerID { layerUnique = u } -> Map.insert u newText names
                                     ; GroupID { layerUnique = u } -> Map.insert u newText names }
                meta' = meta { names = names' }
                hist' = hist { present = ( layers, meta' ) }
            STM.writeTVar historyTVar hist'
            return hist'
          let newDebugText = prettyLayers newContent newMetadata
          GTK.labelSetText layersDebugLabel newDebugText

        ----------------
        -- DragSource --
        ----------------

        -- Connect signals for starting a drag from this widget.
        dragSource <- GTK.dragSourceNew
        GTK.dragSourceSetActions dragSource [ GDK.DragActionCopy ]

        void $ GTK.onDragSourcePrepare dragSource $ \ _x _y -> do
          srcUniq <- layerUnique <$> getLayerData listItem

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

          rowPos <- GTK.treeListRowGetPosition treeListRow
          GTK.singleSelectionSetSelected selectionModel rowPos

          let dnd_sourceItem =
                WithinParent
                  { parent = fmap snd srcPar
                  , item = srcUniq
                  }

          val <- GDK.contentProviderNewForValue =<< GIO.toGValue ( GI.HValue dnd_sourceItem )
          GTK.widgetAddCssClass layersContainer "dragging-item"
          return $ Just val
        void $ GTK.onDragSourceDragBegin dragSource $ \ _drag -> do

{- To set a cursor icon for the drag, write the x/y coordinates in the
   'prepare' signal handler to an IORef, and then use the following:
          ( x, y ) <- readIORef dragPosRef
          paintable <- GTK.widgetPaintableNew ( Just expander )
          GTK.dragSourceSetIcon ?self ( Just paintable ) ( round x ) ( round y )
-}
          noPaintable <- GDK.paintableNewEmpty 0 0
          GTK.dragSourceSetIcon ?self ( Just noPaintable ) 0 0
          GTK.widgetAddCssClass expander "dragged"
          -- TODO: add "dragged" class for all descendants as well.
        void $ GTK.onDragSourceDragCancel dragSource $ \ _drag _reason -> do
          GTK.widgetRemoveCssClass layersContainer "dragging-item"
          GTK.widgetRemoveCssClass expander "dragged"
          return True
              -- ^^^^ Important. Setting this to 'False' stops GDK
              -- from properly clearing the drag cursor.
        void $ GTK.onDragSourceDragEnd dragSource $ \ _drag _deleteData -> do
          GTK.widgetRemoveCssClass layersContainer "dragging-item"
          GTK.widgetRemoveCssClass expander "dragged"

        ----------------
        -- DropTarget --
        ----------------

        -- Connect signals for receiving a drop on this widget.
        dropTarget <- GTK.dropTargetNew GI.gtypeHValue [ GDK.DragActionCopy ]

        let dropTargetCleanup = do
              GTK.widgetRemoveCssClass expander "drag-over"
              GTK.widgetRemoveCssClass expander "drag-top"
              GTK.widgetRemoveCssClass expander "drag-bot"
              mbNextItem <- getNextItem_maybe expander
              for_ mbNextItem $ \ nextItem -> do
                GTK.widgetRemoveCssClass nextItem "drag-top"
        void $ GTK.onDropTargetAccept dropTarget $ \ _drop -> do
          return True
          --dat <- getLayerData listItem
          --case dat of
          --  GroupID {} -> return True
          --  LayerID {} -> return True
        void $ GTK.onDropTargetDrop dropTarget $ \ val _x y -> do
          dropTargetCleanup
          dropTgtUniq <- layerUnique <$> getLayerData listItem

          GI.HValue dragSrc@( WithinParent { item = dragSrcUniq }) <-
            GIO.fromGValue @( GI.HValue UniqueWithParent ) 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
                | expanded
                , not droppedAbove
                , not isDescendant
                = Just treeListRow
                | otherwise
                = Nothing
              mbDropOutsideGroup
                | dragSrcUniq == dropTgtUniq
                , Parent par <- dstPar
                , not droppedAbove
                = 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
                    )

            -- Compute the position that the item we are moving will have
            -- at the end of the move.
            --
            -- First, we compute whether we moved up or down.
            -- NB: we need to compute the source item position now (using 'treeListRowGetPosition'),
            -- at the end of the drag-and-drop operation, because TreeExpander nodes
            -- might have expanded/collapsed in the meantime.
            mbSelItem <- GTK.singleSelectionGetSelectedItem selectionModel
            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 uiElts variables $
              DoChange $
                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 selectionModel dstPos
            return True

        void $ GTK.onDropTargetEnter dropTarget $ \ _x y -> do
          GTK.widgetAddCssClass expander "drag-over"
          h <- GTK.widgetGetHeight expander
          if y < 0.5 * fromIntegral h
          then do
            GTK.widgetAddCssClass expander "drag-top"
          else do
            GTK.widgetAddCssClass expander "drag-bot"
            mbNextItem <- getNextItem_maybe expander
            for_ mbNextItem $ \ nextItem -> do
              GTK.widgetAddCssClass nextItem "drag-top"
          return [ GDK.DragActionCopy ]
        void $ GTK.onDropTargetMotion dropTarget $ \ _x y -> do
          h <- GTK.widgetGetHeight expander
          if y < 0.5 * fromIntegral h
          then do
            GTK.widgetRemoveCssClass expander "drag-bot"
            GTK.widgetAddCssClass expander "drag-top"
            mbNextItem <- getNextItem_maybe expander
            for_ mbNextItem $ \ nextItem -> do
              GTK.widgetRemoveCssClass nextItem "drag-top"
          else do
            GTK.widgetRemoveCssClass expander "drag-top"
            GTK.widgetAddCssClass expander "drag-bot"
            mbNextItem <- getNextItem_maybe expander
            for_ mbNextItem $ \ nextItem -> do
              GTK.widgetAddCssClass nextItem "drag-top"
          return [ GDK.DragActionCopy ]
        void $ GTK.onDropTargetLeave dropTarget $ do
          dropTargetCleanup

        GTK.widgetAddController expander dragSource
        GTK.widgetAddController expander dropTarget

  -- Connect to "bind" signal to modify the generic widget to display the data for this list item.
  _ <- GTK.onSignalListItemFactoryBind layersListFactory $ \ listItem0 -> do

        listItem <- GTK.unsafeCastTo GTK.ListItem listItem0
        mbExpander <- GTK.listItemGetChild listItem
        expander <-
          case mbExpander of
            Nothing -> error "layerView onBind: list item has no child"
            Just expander0 -> GTK.unsafeCastTo GTK.TreeExpander expander0

        LayerViewWidget
          { layerViewCheckButton = checkButton
          , layerViewLabel       = layerLabel
          } <- getLayerViewWidget expander

        dat <- getLayerData listItem
        ( _content, meta ) <- present <$> STM.readTVarIO historyTVar

        -- All we do is set the name and visibility of this layer/group.

        let ( layerText, checkBoxStatusVisible ) =
              case dat of
                LayerID { layerUnique } ->
                  layerNameAndVisible meta layerUnique
                GroupID { layerUnique } ->
                  layerNameAndVisible meta layerUnique

        mbTreeListRow <- traverse ( GTK.unsafeCastTo GTK.TreeListRow ) =<< GTK.listItemGetItem listItem
        treeListRow <- case mbTreeListRow of
          Nothing -> error "newLayerView ListItem onBind: no TreeListRow"
          Just r -> return r
        GTK.treeExpanderSetListRow expander ( Just treeListRow )

        case dat of
          LayerID {} -> do
            GTK.widgetSetVisible checkButton True
            GTK.checkButtonSetActive checkButton checkBoxStatusVisible
          GroupID {} -> do
            GTK.widgetSetVisible checkButton True
            GTK.checkButtonSetActive checkButton checkBoxStatusVisible
        GTK.editableSetText layerLabel layerText

  -- Pass copies of (references to) the TreeListModel and SelectionModel,
  -- in order to retain ownership over them.
  selectionModel <- GI.withManagedPtr layersListModel $ \ lmPtr ->
                    GI.withNewObject lmPtr $ \ lmCopy ->
                    GTK.singleSelectionNew ( Just lmCopy )
  listView <- GI.withManagedPtr selectionModel $ \ smPtr ->
              GI.withNewObject smPtr $ \ smCopy ->
              GTK.listViewNew ( Just smCopy ) ( Just layersListFactory )
  return listView

-- | Get the next item in the flattened tree, if any.
-- Ignores any notion of parent/child.
--
-- This is used to style the "item below" the current drop target,
-- to account for the fact that the item below is rendered on top of the item
-- above it, which overdraws any shadow/glow extending downwards on the latter.
getNextItem_maybe :: GTK.TreeExpander -> IO ( Maybe ( GTK.TreeExpander ) )
getNextItem_maybe expander = do
  mbParent <- GTK.widgetGetParent expander
  case mbParent of
    Nothing -> error "nextItem: item has no parent"
    Just parent -> do
      mbNextItemParent <- GTK.widgetGetNextSibling parent
      case mbNextItemParent of
        Nothing -> return Nothing
        Just nextItemParent -> do
          mbNextItem <- GTK.widgetGetFirstChild nextItemParent
          case mbNextItem of
            Nothing -> error "nextItem: next item has no child"
            Just nextItem0 -> do
              nextItem <- GTK.unsafeCastTo GTK.TreeExpander nextItem0
              return $ Just nextItem

-- | Is this list item a descendant of the item with the given unique?
isDescendantOf :: Unique -- ^ are we a descendant of this?
               -> GTK.ListItem -- ^ item we are querying
               -> IO Bool
isDescendantOf u listItem = do
  mbListRow <- GTK.listItemGetItem listItem
  case mbListRow of
    Nothing -> error "isDescendantOf: ListItem has no item"
    Just listRow0 -> do
      listRow <- GTK.unsafeCastTo GTK.TreeListRow listRow0
      go listRow
  where
    go :: GTK.TreeListRow -> IO Bool
    go listRow = do
      u' <- layerUnique <$> getLayerData listRow
      if u' == u
      then return True
      else do
        mbPar <- GTK.treeListRowGetParent listRow
        case mbPar of
          Nothing -> return False
          Just par -> go par

-- | Get the number of expanded descendants of the given 'GTK.TreeListRow',
-- including the row itself.
getNbExpandedDescendants :: GTK.TreeListModel -> GTK.TreeListRow -> IO Word32
getNbExpandedDescendants layersListModel = fmap fst . go
  where
    go :: GTK.TreeListRow -> IO ( Word32, Word32 )
    go row0 = do
      pos0 <- GTK.treeListRowGetPosition row0
      expanded <- GTK.treeListRowGetExpanded row0
      if not expanded
      then do
        return ( 1, pos0 )
      else do
        ( nbChildItems, lastPosChecked ) <- goChildren ( row0, pos0 )
        return ( 1 + nbChildItems, lastPosChecked )
    goChildren :: ( GTK.TreeListRow, Word32 ) -> IO ( Word32, Word32 )
    goChildren ( row, lastPosChecked ) = do
      mbRow' <- GTK.treeListModelGetRow layersListModel ( lastPosChecked + 1 )
      case mbRow' of
        Nothing -> do
          return ( 0, lastPosChecked + 1 )
        Just nextRow0 -> do
          nextRow <- GTK.unsafeCastTo GTK.TreeListRow nextRow0
          mbNextParent <- GTK.treeListRowGetParent nextRow
          case mbNextParent of
            Just nextParent
              | nextParent == row
              -> do
                ( nbChildren, lastChecked ) <- go nextRow
                ( n, lastChecked' ) <- goChildren ( row, lastChecked )
                return ( nbChildren + n, lastChecked' )
            _ -> return ( 0, lastPosChecked )


-- | Retrieve the parent of the current 'GTK.TreeListRow', if any.
getParent :: GTK.TreeListRow -> IO ( Parent ( GTK.TreeListRow, Unique ) )
getParent treeListRow = do
  mbPar <- GTK.treeListRowGetParent treeListRow
  case mbPar of
    Nothing ->
      return Root
    Just p -> do
      parUniq <- layerUnique <$> getLayerData p
      return ( Parent ( p, parUniq ) )

-- | Get the 'Unique' of the selected item in the 'ListView', if any.
getSelectedItem :: GTK.ListView -> IO ( Maybe UniqueWithParent )
getSelectedItem layersView = do
  mbSelectionModel <- GTK.listViewGetModel layersView
  case mbSelectionModel of
    Nothing -> error "getSelectedItem: no SelectionModel"
    Just selModel0 -> do
      selModel <- GTK.unsafeCastTo GTK.SingleSelection selModel0
      mbRow <- GTK.singleSelectionGetSelectedItem selModel
      for mbRow $ \ row0 -> do
        row <- GTK.unsafeCastTo GTK.TreeListRow row0
        mbItem <- GTK.treeListRowGetItem row
        case mbItem of
          Nothing -> error "getSelectedItem: row has no item"
          Just item0 -> do
            layer     <- GTK.unsafeCastTo LayerItem item0
            layerData <- layerUnique <$> getLayerData layer
            parent <- getParent row
            return $
              WithinParent
                { parent = fmap snd parent
                , item = layerData
                }

--------------------------------------------------------------------------------
-- Updating the layer hierarchy --
----------------------------------

-- | Do or undo?
data Do = Do | Undo
  deriving stock ( Eq, Show )

-- | Do, undo or redo?
data DoChange = DoChange !Change | RedoChange | UndoChange

-- | An item within a parent.
data WithinParent a =
  WithinParent
    { parent :: !( Parent Unique )
    , item   :: !a
    }
  deriving stock Eq

-- | A child within a parent.
type UniqueWithParent = WithinParent Unique
-- | A child, with its index among the list of children of its parent.
type PositionInParent = WithinParent Word32

-- | Description of a change to the layer hierarchy.
data Change
  = Move
      { moveSrc :: !UniqueWithParent
      , moveDst :: !MoveDst
      }
  | NewItem
      { newUnique   :: !Unique
      , newIsGroup  :: !Bool
      , newSelected :: !( Maybe UniqueWithParent )
      }
  | Delete
      { deleteItem :: !UniqueWithParent
      }

-- | Destination of a move operation.
data MoveDst
  -- | Move an item into the top of a group.
  = MoveToTopOfGroup
    { dstParUnique :: !Unique
      -- ^ The group to drop into.
    }
  -- | Move an item outside and below its current parent,
  -- but only if it is the last item in its parent.
  | MoveItemOutsideGroupIfLastItemInGroup
    { itemUnique        :: !Unique
    , itemExpanded      :: !Bool
    , parentUnique      :: !Unique
    , grandParentUnique :: !( Parent Unique )
    }
  -- | Move an item above or below another item.
  | MoveAboveOrBelow
    { moveDstItem :: !UniqueWithParent
    , moveAbove :: !Bool
      -- ^ Whether to move above or below the destination.
    }

-- | Information needed to apply (or unapply) a 'Change' to the
-- 'GTK.TreeListModel' underlying the layer hierarchy.
data Diff
  = DiffMove
      { diffMoveSrc :: !PositionInParent
      , diffMoveDst :: !PositionInParent
      }
  | DiffNew
      { diffNewDst  :: !PositionInParent
      , diffNewData :: !LayerID
      }
  | DiffDelete
      { diffDelSrc  :: !PositionInParent
      , diffDelData :: !LayerID
      }

-- | Update the layer hierarchy, keeping both the application state and
-- the GTK ListModel in sync.
updateLayerHierarchy :: UIElements -> Variables -> DoChange -> IO ()
updateLayerHierarchy
  ( UIElements { .. } )
  ( Variables { historyTVar, parStoreFromUniqTVar, listModelUpToDateTMVar } )
  doOrUndo = do
    ( newHistory, mbDiff ) <- STM.atomically $ do

      -- Ensure the GTK ListModel is up to date before continuing
      -- (just a precaution).
      STM.takeTMVar listModelUpToDateTMVar

      history@( History
        { past
        , present = ( presentContent@Content { layerHierarchy = hierarchy }, meta@( Metadata { names } ) )
        , future
        } ) <- STM.readTVar historyTVar

      !( !history', mbDiff ) <- case doOrUndo of
        DoChange change -> do
          let !( !hierarchy', !newNames, mbDiff ) = applyChangeToLayerHierarchy change hierarchy
              !content' = presentContent { layerHierarchy = hierarchy' }
              !meta' = meta { names = newNames <> names }
              !( !history', mbDoOrUndo ) =
                case mbDiff of
                  Nothing ->
                    ( History
                        { past = past
                        , present = ( content', meta' )
                        , future = future
                        }
                    , Nothing )
                  Just diff ->
                    ( History
                        { past = past Seq.:|> ( presentContent, diff )
                        , present = ( content', meta' )
                        , future = []
                        }
                    , Just ( Do, diff ) )
          return ( history', mbDoOrUndo )
        UndoChange -> case past of
          past' Seq.:|> ( present', diff ) -> do
            let !history' =
                  History
                    { past = past'
                    , present = ( present', meta )
                    , future = ( diff, presentContent ) : future
                    }
            return ( history', Just ( Undo, diff ) )
          Seq.Empty ->
            return ( history, Nothing )
        RedoChange -> case future of
          ( diff, present' ) : future' -> do
            let history' =
                  History
                    { past = past Seq.:|> ( presentContent, diff )
                    , present = ( present', meta )
                    , future = future'
                    }
            return ( history', Just ( Do, diff ) )
          [] ->
            return ( history, Nothing )

      STM.writeTVar historyTVar history'
      return ( history', mbDiff )

    for_ mbDiff ( applyDiffToListModel parStoreFromUniqTVar )

    STM.atomically $
      STM.writeTMVar listModelUpToDateTMVar ()

    let newDebugText = uncurry prettyLayers $ present newHistory
        noFuture = null $ future newHistory
        noPast   = null $ past   newHistory

    GTK.widgetSetSensitive redoButton $ not noFuture
    GTK.widgetSetSensitive undoButton $ not noPast
    GTK.labelSetText layersDebugLabel newDebugText


-- | Apply a change to the application layer hierarchy.
--
-- The change to the GTK ListModel is done in 'applyDiffToListModel'.
applyChangeToLayerHierarchy :: Change -> LayerHierarchy -> ( LayerHierarchy, Map Unique Text, Maybe Diff )
applyChangeToLayerHierarchy change hierarchy =
  case change of
    Move
      { moveSrc = WithinParent srcParUniq srcUniq
      , moveDst } ->
      let mbDst =
            case moveDst of
              MoveAboveOrBelow
                { moveAbove
                , moveDstItem = WithinParent parUniq tgtUniq
                } ->
                  Just ( parUniq
                       , Just ( tgtUniq , moveAbove )
                       )
              MoveToTopOfGroup
                { dstParUnique } ->
                  Just ( Parent dstParUnique, Nothing )
              MoveItemOutsideGroupIfLastItemInGroup
                { itemUnique, itemExpanded
                , parentUnique, grandParentUnique
                }
                  | Just siblings <- hierarchy Map.! ( Parent parentUnique )
                  , last siblings == itemUnique
                  -- Only allow this for a group when the group is not expanded
                  -- or it has no children.
                  , let expandedGroupWithChildren
                          | itemExpanded
                          , Just cs <- hierarchy Map.! ( Parent itemUnique )
                          , not ( null cs )
                          = True
                          | otherwise
                          = False
                  , not expandedGroupWithChildren
                  -> Just ( grandParentUnique, Just ( parentUnique, False ) )
                  | otherwise
                  -> Nothing
      in case mbDst of
        Nothing ->
          ( hierarchy, Map.empty, Nothing )
        Just ( dstParUniq, mbDstUniq ) ->
          let
            !( !hierarchy', mbChildIxs ) =
              moveLayerUpdate
                ( srcParUniq, srcUniq )
                ( dstParUniq, mbDstUniq )
                hierarchy
          in ( hierarchy'
             , Map.empty
             , case mbChildIxs of
                Just ( srcChildIx, dstChildIx ) ->
                  Just $
                    DiffMove
                      ( WithinParent srcParUniq srcChildIx )
                      ( WithinParent dstParUniq dstChildIx )
                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
          !hierarchy'' = Map.insert ( Parent u ) ( if newIsGroup then Just [] else Nothing ) hierarchy'
      in
        ( hierarchy''
        , Map.singleton u ( if newIsGroup then "Group" else "Layer" )
        , Just $
            DiffNew
              { diffNewDst = WithinParent dstParUniq dstChildIx
              , diffNewData = if newIsGroup then GroupID u else LayerID u
              }
        )
    Delete { deleteItem = WithinParent parUniq delUniq } ->
      let !( !hierarchy', childIx ) = removeLayerFromParent hierarchy ( parUniq, delUniq )
          !( fromJust -> mbHadChildren, !hierarchy'' ) =
              Map.updateLookupWithKey ( \ _ _ -> Nothing )
                ( Parent delUniq )
                hierarchy'
      in
        ( hierarchy''
        , Map.empty
        , Just $
            DiffDelete
              { diffDelSrc  = WithinParent parUniq childIx
              , diffDelData =
                  case mbHadChildren of
                    Just {} -> GroupID delUniq
                    Nothing -> LayerID delUniq
              }
        )

-- | Apply a change to the 'ListModel' underlying the UI
-- representation of the layer hierarchy.
--
-- The change to the application 'LayerHierarchy' is done beforehand,
-- in 'applyChangeToLayerHierarchy'.
applyDiffToListModel :: STM.TVar ( Map ( Parent Unique ) GIO.ListStore )
                     -> ( Do, Diff )
                     -> IO ()
applyDiffToListModel parStoreFromUniqTVar ( doOrUndo, diff ) = do
  -- All modifications to the GTK.TreeListModel are done by editing
  -- an appropriate child GIO.ListModel.
  --
  -- We **do not** use the flattened indices returned by GTK.treeListRowGetPosition,
  -- as those are ephemeral (they change when tree expanders are expanded or collapsed).
  -- Instead, we keep track of a mapping
  --
  --   parent --> list store used to hold its children
  --
  -- and use that child list store to perform updates.
  parStoreFromUniq <- STM.readTVarIO parStoreFromUniqTVar
  case diff of
    DiffMove ( WithinParent srcPar srcIx ) ( WithinParent dstPar dstIx ) -> do
      let srcStore = parStoreFromUniq Map.! srcPar
          dstStore = parStoreFromUniq Map.! 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
    DiffNew { diffNewDst = WithinParent dstPar dstIx, diffNewData } -> do
      let dstStore = parStoreFromUniq Map.! dstPar
      case doOrUndo of
        Do -> do
          item <- GI.new LayerItem []
          GI.gobjectSetPrivateData item ( Just diffNewData )
          GIO.listStoreInsert dstStore dstIx item
        Undo ->
          GIO.listStoreRemove dstStore dstIx
    DiffDelete { diffDelSrc = WithinParent srcPar srcIx, diffDelData } -> do
      let srcStore = parStoreFromUniq Map.! srcPar
      case doOrUndo of
        Do -> GIO.listStoreRemove srcStore srcIx
        Undo -> do
          item <- GI.new LayerItem []
          GI.gobjectSetPrivateData item ( Just diffDelData )
          GIO.listStoreInsert srcStore srcIx item

-- | Update the 'LayerHierarchy' after a drag-and-drop operation,
-- moving one layer or group around.
--
-- This handles the application side logic.
-- The UI side is handled in 'dragAndDropListModelUpdate'.
--
-- Returns an updated 'LayerHierarchy', together with the relative indices
-- of the source and destination items within their respective parents.
-- This information is then used by GTK to update the underlying 'ListModel'.
moveLayerUpdate
  :: ( Parent Unique, Unique )
    -- ^ source
  -> ( Parent Unique, Maybe ( Unique, Bool ) )
    -- ^ destination
    --
    --  - @Nothing@: drop as first element of group
    --  - @Just (u, above)@ drop above/below u
  -> LayerHierarchy
    -- ^ hierarchy to update
  -> ( LayerHierarchy, Maybe ( Word32, Word32 ) )
moveLayerUpdate src@( srcPar, srcUniq ) dst@( dstPar, _ ) hierarchy =
  let
    -- Remove the child from its old parent.
    ( hierarchy' , oldChildPos ) = removeLayerFromParent hierarchy src
    -- Add the child to its new parent.
    ( hierarchy'', newChildPos ) = insertLayerIntoParent hierarchy' dst srcUniq
  in
    ( hierarchy''
      -- If the move is a no-op, then return 'Nothing' to avoid
      -- updating the 'GTK.TreeListModel'.
    , if srcPar == dstPar && oldChildPos == newChildPos
      then Nothing
      else Just ( oldChildPos, newChildPos )
    )

-- | Remove a layer or group from its parent in the 'LayerHierarchy',
-- returning the updated 'LayerHierarchy' together with the index the item
-- was found within its parent.
--
-- NB: does not delete the layer itself.
removeLayerFromParent :: LayerHierarchy
                      -> ( Parent Unique, Unique )
                      -> ( LayerHierarchy, Word32 )
removeLayerFromParent hierarchy ( parent, u ) =
  let ( fromJust -> oldPar_cs ) = hierarchy Map.! parent
      newChildren = Just $ ( filter ( /= u ) ) oldPar_cs
      oldChildPos = fromIntegral $ fromJust $ elemIndex u oldPar_cs
  in ( Map.insert parent newChildren hierarchy, oldChildPos )

-- | Add a layer to a parent in the 'LayerHierarchy', returning the updated
-- 'LayerHierarchy' together with the index the item was placed within its parent.
--
-- NB: does not add the layer itself.
insertLayerIntoParent :: LayerHierarchy
                      -> ( Parent Unique, Maybe ( Unique, Bool ) )
                          -- ^ destination
                          --
                          --  - @Nothing@: drop as first element of group
                          --  - @Just (u, above)@ drop above/below u
                      -> Unique
                      -> ( LayerHierarchy, Word32 )
insertLayerIntoParent hierarchy ( par, mbTgtUniq ) srcUniq =
  let
    ( fromJust -> newPar_cs ) = hierarchy Map.! par
    ( parent', newChildPos ) =
      case mbTgtUniq of
        -- Drop as first child of group.
        Nothing ->
          ( Just ( srcUniq : filter ( /= srcUniq ) newPar_cs )
          , 0
          )
        -- Drop (before or after) given child.
        Just ( tgtUniq, dropAbove ) ->
          let ( bef, aft ) = break ( == tgtUniq ) $ filter ( /= srcUniq ) newPar_cs
          in  ( Just $
                  if dropAbove
                  then bef ++ [ srcUniq ] ++ aft
                  else bef ++ take 1 aft ++ [ srcUniq ] ++ drop 1 aft
              , fromIntegral ( length ( takeWhile ( /= tgtUniq ) $ newPar_cs ) )
              + if dropAbove then 0 else 1
              )
  in ( Map.insert par parent' hierarchy, newChildPos )

--------------------------------------------------------------------------------
-- Sample data for illustration.

testContent :: Content
testContent =
  Content
    { layerHierarchy =
        Map.fromList $
          -- NB: this should never be constructed by hand (too error-prone);
          -- this is just for demonstration purposes.
          [ ( Root                , Just [ Unique 1, Unique 2, Unique 11, Unique 12, Unique 13, Unique 14 ] )
          , ( Parent ( Unique 1  ), Nothing )
          , ( Parent ( Unique 2  ), Just [ Unique 3, Unique 4, Unique 5, Unique 10 ] )
          , ( Parent ( Unique 3  ), Nothing )
          , ( Parent ( Unique 4  ), Nothing )
          , ( Parent ( Unique 5  ), Just [ Unique 6, Unique 7, Unique 8, Unique 9 ] )
          , ( Parent ( Unique 6  ), Nothing )
          , ( Parent ( Unique 7  ), Nothing )
          , ( Parent ( Unique 8  ), Just [ ] )
          , ( Parent ( Unique 9  ), Nothing )
          , ( Parent ( Unique 10 ), Nothing )
          , ( Parent ( Unique 11 ), Nothing )
          , ( Parent ( Unique 12 ), Nothing )
          , ( Parent ( Unique 13 ), Nothing )
          , ( Parent ( Unique 14 ), Just [ Unique 15, Unique 16, Unique 17 ] )
          , ( Parent ( Unique 15 ), Nothing )
          , ( Parent ( Unique 16 ), Nothing )
          , ( Parent ( Unique 17 ), Just [ Unique 18 ] )
          , ( Parent ( Unique 18 ), Nothing )
          ]
    }

testInitialUnique :: Unique
testInitialUnique
  = succ
  $ maximum
  $ catMaybes
  $ fmap ( \ case { Root -> Nothing; Parent i -> Just i } )
  $ Map.keys
  $ layerHierarchy testContent

testMetadata :: Metadata
testMetadata = Metadata
        { names = Map.fromList
                    [ ( Unique 1, "layer 1" )
                    , ( Unique 2, "group 2" )
                    ,   ( Unique 3, "layer 2.1" )
                    ,   ( Unique 4, "layer 2.2" )
                    ,   ( Unique 5, "group 2.3" )
                    ,     ( Unique 6, "layer 2.3.1" )
                    ,     ( Unique 7, "layer 2.3.2" )
                    ,     ( Unique 8, "group 2.3.3" )
                    ,     ( Unique 9, "layer 2.3.4" )
                    ,   ( Unique 10, "layer 2.4" )
                    , ( Unique 11, "layer 3" )
                    , ( Unique 12, "layer 4" )
                    , ( Unique 13, "layer 5" )
                    , ( Unique 14, "group 6" )
                    ,   ( Unique 15, "layer 6.1" )
                    ,   ( Unique 16, "layer 6.2" )
                    ,   ( Unique 17, "group 6.3" )
                    ,     ( Unique 18, "layer 6.3.1" )
                    ]
        , invisibles = Set.fromList [ Unique 4, Unique 7 ]
        }
testInitialHistory :: History
testInitialHistory =
  History
    { past    = mempty
    , present = ( testContent, testMetadata )
    , future  = mempty
    }