mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
implement stroke list popover menu functionality
This commit is contained in:
parent
27269809e7
commit
53243621b5
|
@ -208,7 +208,6 @@ runApplication application = do
|
||||||
openDocumentsTVar <- STM.newTVarIO testDocuments
|
openDocumentsTVar <- STM.newTVarIO testDocuments
|
||||||
strokeListModelsTVar <- STM.newTVarIO Map.empty
|
strokeListModelsTVar <- STM.newTVarIO Map.empty
|
||||||
parStoresTVar <- STM.newTVarIO Map.empty
|
parStoresTVar <- STM.newTVarIO Map.empty
|
||||||
listModelUpToDateTMVar <- STM.newTMVarIO ()
|
|
||||||
mousePosTVar <- STM.newTVarIO Nothing
|
mousePosTVar <- STM.newTVarIO Nothing
|
||||||
mouseHoldTVar <- STM.newTVarIO Nothing
|
mouseHoldTVar <- STM.newTVarIO Nothing
|
||||||
modifiersTVar <- STM.newTVarIO Set.empty
|
modifiersTVar <- STM.newTVarIO Set.empty
|
||||||
|
|
|
@ -115,6 +115,10 @@ import MetaBrush.Application.UpdateDocument
|
||||||
import MetaBrush.Asset.WindowIcons
|
import MetaBrush.Asset.WindowIcons
|
||||||
( drawClose )
|
( drawClose )
|
||||||
import MetaBrush.Document.Diff
|
import MetaBrush.Document.Diff
|
||||||
|
( Diff(..)
|
||||||
|
, HierarchyDiff(..), HistoryDiff(..), ContentDiff(..)
|
||||||
|
, DragMoveSelect(..), SelectionMode(..)
|
||||||
|
)
|
||||||
import MetaBrush.Document.History
|
import MetaBrush.Document.History
|
||||||
( DocumentHistory(..), Do(..)
|
( DocumentHistory(..), Do(..)
|
||||||
, newHistory, back, fwd
|
, newHistory, back, fwd
|
||||||
|
@ -136,7 +140,7 @@ import MetaBrush.UI.InfoBar
|
||||||
import MetaBrush.UI.FileBar
|
import MetaBrush.UI.FileBar
|
||||||
( newFileTab, removeFileTab )
|
( newFileTab, removeFileTab )
|
||||||
import MetaBrush.UI.StrokeTreeView
|
import MetaBrush.UI.StrokeTreeView
|
||||||
( applyDeletionToStrokeHierarchy, applyDiffToListModel )
|
( applyDeletionToStrokeHierarchy, applyDiffToListModel, updateLayerHierarchy, DoLayerChange (..), LayerChange (..) )
|
||||||
import MetaBrush.UI.Viewport
|
import MetaBrush.UI.Viewport
|
||||||
( Viewport(..) )
|
( Viewport(..) )
|
||||||
import MetaBrush.Unique
|
import MetaBrush.Unique
|
||||||
|
@ -690,29 +694,33 @@ instance HandleAction Delete where
|
||||||
-- Delete layer --
|
-- Delete layer --
|
||||||
------------------
|
------------------
|
||||||
|
|
||||||
data DeleteLayer = DeleteLayer !MetaBrush.Layer.Layer
|
data DeleteLayer = DeleteLayer !ChildLayer
|
||||||
deriving stock Show
|
deriving stock Show
|
||||||
|
|
||||||
instance HandleAction MetaBrush.Application.Action.DeleteLayer where
|
instance HandleAction DeleteLayer where
|
||||||
handleAction
|
handleAction _ vars
|
||||||
uiElts
|
( DeleteLayer l ) =
|
||||||
vars@( Variables { toolTVar, modeTVar } )
|
updateLayerHierarchy vars $
|
||||||
_ =
|
DoLayerChange $
|
||||||
return ()
|
DeleteItems ( NE.singleton l )
|
||||||
|
|
||||||
---------------
|
---------------
|
||||||
-- New group --
|
-- New group --
|
||||||
---------------
|
---------------
|
||||||
|
|
||||||
data GroupPosition = GroupAbove | GroupBelow | GroupContaining
|
data NewGroup = NewGroup !RelativePosition !ChildLayer
|
||||||
deriving stock Show
|
|
||||||
|
|
||||||
data NewGroup = NewGroup !GroupPosition !MetaBrush.Layer.Layer
|
|
||||||
deriving stock Show
|
deriving stock Show
|
||||||
|
|
||||||
instance HandleAction NewGroup where
|
instance HandleAction NewGroup where
|
||||||
handleAction ( UIElements { viewport = Viewport {..} } ) ( Variables { redrawStrokesTVar, showGuidesTVar } ) ( NewGroup pos lay ) = do
|
handleAction _ vars ( NewGroup pos lay ) = do
|
||||||
return ()
|
u <- Reader.runReaderT freshUnique ( uniqueSupply vars )
|
||||||
|
updateLayerHierarchy vars $
|
||||||
|
DoLayerChange $
|
||||||
|
NewItem
|
||||||
|
{ newUnique = u
|
||||||
|
, newIsGroup = True
|
||||||
|
, newPosition = ( lay, pos )
|
||||||
|
}
|
||||||
|
|
||||||
-------------------
|
-------------------
|
||||||
-- Toggle guides --
|
-- Toggle guides --
|
||||||
|
|
|
@ -15,11 +15,12 @@ import Data.Text
|
||||||
import Math.Linear
|
import Math.Linear
|
||||||
( ℝ(..), T(..) )
|
( ℝ(..), T(..) )
|
||||||
import MetaBrush.Application.Context
|
import MetaBrush.Application.Context
|
||||||
|
import MetaBrush.Layer
|
||||||
|
( ChildLayer, RelativePosition )
|
||||||
import MetaBrush.UI.Viewport
|
import MetaBrush.UI.Viewport
|
||||||
( Ruler(..) )
|
( Ruler(..) )
|
||||||
import MetaBrush.Unique
|
import MetaBrush.Unique
|
||||||
( Unique )
|
( Unique )
|
||||||
import MetaBrush.Layer (Layer)
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
@ -86,11 +87,10 @@ instance HandleAction Duplicate
|
||||||
data Delete = Delete
|
data Delete = Delete
|
||||||
instance HandleAction Delete
|
instance HandleAction Delete
|
||||||
|
|
||||||
data DeleteLayer = DeleteLayer !Layer
|
data DeleteLayer = DeleteLayer !ChildLayer
|
||||||
instance HandleAction DeleteLayer
|
instance HandleAction DeleteLayer
|
||||||
|
|
||||||
data GroupPosition = GroupAbove | GroupBelow | GroupContaining
|
data NewGroup = NewGroup !RelativePosition !ChildLayer
|
||||||
data NewGroup = NewGroup !GroupPosition !Layer
|
|
||||||
instance HandleAction NewGroup
|
instance HandleAction NewGroup
|
||||||
|
|
||||||
data ToggleGuides = ToggleGuides
|
data ToggleGuides = ToggleGuides
|
||||||
|
|
|
@ -32,8 +32,7 @@ import Data.Hashable
|
||||||
( Hashable )
|
( Hashable )
|
||||||
|
|
||||||
-- stm
|
-- stm
|
||||||
import qualified Control.Concurrent.STM.TVar as STM
|
import qualified Control.Concurrent.STM as STM
|
||||||
import qualified Control.Concurrent.STM.TMVar as STM
|
|
||||||
|
|
||||||
-- text
|
-- text
|
||||||
import Data.Text
|
import Data.Text
|
||||||
|
@ -111,10 +110,8 @@ data Variables
|
||||||
-- This allows us to know, given a parent and a child index,
|
-- This allows us to know, given a parent and a child index,
|
||||||
-- how to insert/delete from the 'GTK.TreeListModel'.
|
-- how to insert/delete from the 'GTK.TreeListModel'.
|
||||||
, parStoresTVar :: !( STM.TVar ( Map Unique ( Map ( Parent Unique ) GIO.ListStore ) ) )
|
, parStoresTVar :: !( STM.TVar ( Map Unique ( Map ( Parent Unique ) GIO.ListStore ) ) )
|
||||||
|
-- ^ The TMVar is used to ensure that the layer hierarchy data
|
||||||
-- | This TMVar is used to ensure that the layer hierarchy data
|
-- is kept in-sync between the application and the UI's 'GTK.TreeListModel'.
|
||||||
-- is kept in-sync between the application and the UI's 'GTK.TreeListModel'.
|
|
||||||
, listModelUpToDateTMVar :: !( STM.TMVar () )
|
|
||||||
|
|
||||||
, selectedBrushTVar :: !( STM.TVar ( Maybe SomeBrush ) )
|
, selectedBrushTVar :: !( STM.TVar ( Maybe SomeBrush ) )
|
||||||
|
|
||||||
|
|
|
@ -7,6 +7,14 @@ import Control.Monad
|
||||||
( void )
|
( void )
|
||||||
import Data.Foldable
|
import Data.Foldable
|
||||||
( for_, traverse_ )
|
( for_, traverse_ )
|
||||||
|
import Data.IORef
|
||||||
|
( IORef, newIORef, atomicModifyIORef' )
|
||||||
|
import qualified Data.List.NonEmpty as NE
|
||||||
|
import System.IO.Unsafe
|
||||||
|
( unsafePerformIO )
|
||||||
|
|
||||||
|
-- haskell-gi-base
|
||||||
|
import qualified Data.GI.Base.Signals as GI
|
||||||
|
|
||||||
-- gi-cairo-connector
|
-- gi-cairo-connector
|
||||||
import qualified GI.Cairo.Render.Connector as Cairo
|
import qualified GI.Cairo.Render.Connector as Cairo
|
||||||
|
@ -15,6 +23,9 @@ import qualified GI.Cairo.Render.Connector as Cairo
|
||||||
-- gi-gio
|
-- gi-gio
|
||||||
import qualified GI.Gio as GIO
|
import qualified GI.Gio as GIO
|
||||||
|
|
||||||
|
-- gi-gobject
|
||||||
|
import qualified GI.GObject as GObject
|
||||||
|
|
||||||
-- gi-gtk
|
-- gi-gtk
|
||||||
import qualified GI.Gtk as GTK
|
import qualified GI.Gtk as GTK
|
||||||
|
|
||||||
|
@ -32,7 +43,7 @@ import Control.Monad.IO.Class
|
||||||
import Data.HashMap.Strict
|
import Data.HashMap.Strict
|
||||||
( HashMap )
|
( HashMap )
|
||||||
import qualified Data.HashMap.Strict as HashMap
|
import qualified Data.HashMap.Strict as HashMap
|
||||||
( lookup, traverseWithKey )
|
( insert, lookup, traverseWithKey, empty )
|
||||||
import Data.HashSet
|
import Data.HashSet
|
||||||
( HashSet )
|
( HashSet )
|
||||||
import qualified Data.HashSet as HashSet
|
import qualified Data.HashSet as HashSet
|
||||||
|
@ -48,7 +59,7 @@ import MetaBrush.Asset.WindowIcons
|
||||||
import MetaBrush.GTK.Util
|
import MetaBrush.GTK.Util
|
||||||
( widgetAddClass, widgetAddClasses )
|
( widgetAddClass, widgetAddClasses )
|
||||||
import MetaBrush.Layer
|
import MetaBrush.Layer
|
||||||
( Layer(..) )
|
( Layer(..), RelativePosition(..), WithinParent(.. ))
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Types for describing menu items.
|
-- Types for describing menu items.
|
||||||
|
@ -93,18 +104,20 @@ menuActionNames = HashSet.fromList
|
||||||
, WinAction "about"
|
, WinAction "about"
|
||||||
-- preferences
|
-- preferences
|
||||||
, WinAction "prefs"
|
, WinAction "prefs"
|
||||||
-- stroke actions
|
]
|
||||||
|
|
||||||
|
strokeMenuActionNames :: HashSet ActionName
|
||||||
|
strokeMenuActionNames = HashSet.fromList
|
||||||
|
[ WinAction "deleteLayer"
|
||||||
, WinAction "newGroupAbove"
|
, WinAction "newGroupAbove"
|
||||||
, WinAction "newGroupBelow"
|
, WinAction "newGroupBelow"
|
||||||
, WinAction "newGroupContaining"
|
|
||||||
, WinAction "deleteLayer"
|
|
||||||
]
|
]
|
||||||
|
|
||||||
createMenuActions :: IO ( HashMap ActionName GIO.SimpleAction )
|
createMenuActions :: IO ( HashMap ActionName GIO.SimpleAction )
|
||||||
createMenuActions =
|
createMenuActions =
|
||||||
HashMap.traverseWithKey
|
HashMap.traverseWithKey
|
||||||
( \ actionName _ -> GIO.simpleActionNew ( actionSimpleName actionName ) Nothing )
|
( \ actionName _ -> GIO.simpleActionNew ( actionSimpleName actionName ) Nothing )
|
||||||
( HashSet.toMap menuActionNames )
|
( HashSet.toMap menuActionNames <> HashSet.toMap strokeMenuActionNames )
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Menu used in MetaBrush.
|
-- Menu used in MetaBrush.
|
||||||
|
@ -171,21 +184,26 @@ helpMenuDescription =
|
||||||
[ MenuItemDescription "About MetaBrush" ( Just $ WinAction "about", About ) ( Just "<Ctrl>question" )
|
[ MenuItemDescription "About MetaBrush" ( Just $ WinAction "about", About ) ( Just "<Ctrl>question" )
|
||||||
]
|
]
|
||||||
|
|
||||||
strokeMenuDescription :: Layer -> [ MenuItem ]
|
strokeMenuDescription :: WithinParent Layer -> [ MenuItem ]
|
||||||
strokeMenuDescription lay =
|
strokeMenuDescription item@( WithinParent _ lay ) =
|
||||||
[ case lay of
|
[ case lay of
|
||||||
StrokeLayer {} -> MenuItemDescription "Delete stroke" ( Nothing, DeleteLayer lay) Nothing
|
StrokeLayer {} -> MenuItemDescription "Delete stroke" ( Just $ WinAction "deleteLayer", DeleteLayer child ) Nothing
|
||||||
GroupLayer {} -> MenuItemDescription "Delete group" ( Nothing, DeleteLayer lay) Nothing
|
GroupLayer {} -> MenuItemDescription "Delete group" ( Just $ WinAction "deleteLayer", DeleteLayer child ) Nothing
|
||||||
, Section ( Just "New group" ) $
|
, Section ( Just "New group" ) $
|
||||||
[ MenuItemDescription "...above" ( Nothing, NewGroup GroupAbove lay ) Nothing
|
[ MenuItemDescription "...above" ( Just $ WinAction "newGroupAbove", NewGroup Above child ) Nothing
|
||||||
, MenuItemDescription "...containing" ( Nothing, NewGroup GroupContaining lay ) Nothing
|
, MenuItemDescription "...below" ( Just $ WinAction "newGroupBelow", NewGroup Below child ) Nothing
|
||||||
, MenuItemDescription "...below" ( Nothing, NewGroup GroupBelow lay ) Nothing
|
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
|
where
|
||||||
|
child = fmap layerUnique item
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Creating a GTK popover menu bar from a menu description.
|
-- Creating a GTK popover menu bar from a menu description.
|
||||||
|
|
||||||
|
{-# NOINLINE previousActions #-}
|
||||||
|
previousActions :: IORef ( HashMap Text ( NE.NonEmpty GI.SignalHandlerId ) )
|
||||||
|
previousActions = unsafePerformIO $ newIORef HashMap.empty
|
||||||
|
|
||||||
makeMenu :: MonadIO m => UIElements -> Variables -> GIO.Menu -> [ MenuItem ] -> m ()
|
makeMenu :: MonadIO m => UIElements -> Variables -> GIO.Menu -> [ MenuItem ] -> m ()
|
||||||
makeMenu uiElts@( UIElements { application, window, menuActions } ) vars menu = traverse_ \case
|
makeMenu uiElts@( UIElements { application, window, menuActions } ) vars menu = traverse_ \case
|
||||||
SubmenuDescription
|
SubmenuDescription
|
||||||
|
@ -200,23 +218,32 @@ makeMenu uiElts@( UIElements { application, window, menuActions } ) vars menu =
|
||||||
, menuItemAction = ( mbActionName, actionData )
|
, menuItemAction = ( mbActionName, actionData )
|
||||||
, menuItemAccel
|
, menuItemAccel
|
||||||
} -> do
|
} -> do
|
||||||
for_ mbActionName \ actionName -> do
|
for_ mbActionName $ \ actionName -> do
|
||||||
let
|
let
|
||||||
simpleName :: Text
|
simpleName :: Text
|
||||||
simpleName = actionSimpleName actionName
|
simpleName = actionSimpleName actionName
|
||||||
case HashMap.lookup actionName menuActions of
|
case HashMap.lookup actionName menuActions of
|
||||||
Nothing ->
|
Nothing ->
|
||||||
error
|
error
|
||||||
( "Could not create menu item labelled " <> Text.unpack menuItemLabel <>
|
( "Could not create menu item labelled " <> Text.unpack menuItemLabel <>
|
||||||
": missing action " <> show actionName
|
": missing action " <> show actionName
|
||||||
)
|
)
|
||||||
Just menuItemAction -> do
|
Just menuItemAction -> do
|
||||||
_ <- GIO.onSimpleActionActivate menuItemAction
|
-- Un-register any previously registered actions.
|
||||||
( \ _ -> handleAction uiElts vars actionData )
|
-- (For stroke menu actions in which we create a new set of actions
|
||||||
GIO.actionMapAddAction window menuItemAction
|
-- each time the popover menu pop ups.)
|
||||||
for_ menuItemAccel \ accelText -> do
|
signalId
|
||||||
actionDetailedName <- GIO.actionPrintDetailedName simpleName Nothing
|
<- GIO.onSimpleActionActivate menuItemAction
|
||||||
GTK.applicationSetAccelsForAction application ( actionPrefix actionName <> actionDetailedName ) [accelText]
|
( \ _ -> handleAction uiElts vars actionData )
|
||||||
|
prevActions <- liftIO $ atomicModifyIORef' previousActions $ \ oldActionsMap ->
|
||||||
|
let old = HashMap.lookup simpleName oldActionsMap
|
||||||
|
in ( HashMap.insert simpleName ( NE.singleton signalId ) oldActionsMap, maybe [] NE.toList old )
|
||||||
|
for_ prevActions $ GObject.signalHandlerDisconnect menuItemAction
|
||||||
|
GIO.actionMapRemoveAction window simpleName
|
||||||
|
GIO.actionMapAddAction window menuItemAction
|
||||||
|
for_ menuItemAccel \ accelText -> do
|
||||||
|
actionDetailedName <- GIO.actionPrintDetailedName simpleName Nothing
|
||||||
|
GTK.applicationSetAccelsForAction application ( actionPrefix actionName <> actionDetailedName ) [accelText]
|
||||||
menuItem <- GIO.menuItemNew ( Just menuItemLabel ) ( fmap ( \ name -> actionPrefix name <> actionSimpleName name ) mbActionName )
|
menuItem <- GIO.menuItemNew ( Just menuItemLabel ) ( fmap ( \ name -> actionPrefix name <> actionSimpleName name ) mbActionName )
|
||||||
GIO.menuAppendItem menu menuItem
|
GIO.menuAppendItem menu menuItem
|
||||||
Section
|
Section
|
||||||
|
|
|
@ -8,11 +8,13 @@ module MetaBrush.UI.StrokeTreeView
|
||||||
( newLayersListModel
|
( newLayersListModel
|
||||||
, newLayerView
|
, newLayerView
|
||||||
, switchStrokeView
|
, switchStrokeView
|
||||||
|
, updateLayerHierarchy
|
||||||
, applyDeletionToStrokeHierarchy
|
, applyDeletionToStrokeHierarchy
|
||||||
, applyChangeToLayerHierarchy
|
, applyChangeToLayerHierarchy
|
||||||
, applyDiffToListModel
|
, applyDiffToListModel
|
||||||
, getSelectedItem
|
, getSelectedItem
|
||||||
, DragSourceData(..)
|
, DragSourceData(..)
|
||||||
|
, DoLayerChange(..), LayerChange(..)
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -20,7 +22,7 @@ module MetaBrush.UI.StrokeTreeView
|
||||||
import Control.Arrow
|
import Control.Arrow
|
||||||
( second )
|
( second )
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
( unless, void, when )
|
( unless, void )
|
||||||
import Data.Foldable
|
import Data.Foldable
|
||||||
( for_ )
|
( for_ )
|
||||||
import Data.List
|
import Data.List
|
||||||
|
@ -33,7 +35,6 @@ import Data.Traversable
|
||||||
import Data.Word
|
import Data.Word
|
||||||
( Word32 )
|
( Word32 )
|
||||||
import GHC.Stack
|
import GHC.Stack
|
||||||
( HasCallStack )
|
|
||||||
|
|
||||||
-- containers
|
-- containers
|
||||||
import Data.Map.Strict
|
import Data.Map.Strict
|
||||||
|
@ -49,6 +50,9 @@ import Data.Generics.Product.Fields
|
||||||
-- gi-gdk
|
-- gi-gdk
|
||||||
import qualified GI.Gdk as GDK
|
import qualified GI.Gdk as GDK
|
||||||
|
|
||||||
|
-- gi-glib
|
||||||
|
import qualified GI.GLib as GLib
|
||||||
|
|
||||||
-- gi-gio
|
-- gi-gio
|
||||||
import qualified GI.Gio as GIO
|
import qualified GI.Gio as GIO
|
||||||
|
|
||||||
|
@ -70,9 +74,7 @@ import Control.Lens
|
||||||
( over )
|
( over )
|
||||||
|
|
||||||
-- stm
|
-- stm
|
||||||
import qualified Control.Concurrent.STM.TVar as STM
|
import qualified Control.Concurrent.STM as STM
|
||||||
import qualified Control.Concurrent.STM.TMVar as STM
|
|
||||||
import qualified Control.Monad.STM as STM
|
|
||||||
|
|
||||||
-- text
|
-- text
|
||||||
import Data.Text
|
import Data.Text
|
||||||
|
@ -96,7 +98,6 @@ import MetaBrush.Unique
|
||||||
import MetaBrush.UI.Menu
|
import MetaBrush.UI.Menu
|
||||||
( strokeMenuDescription, makeMenu )
|
( strokeMenuDescription, makeMenu )
|
||||||
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
-- | Custom GTK object used to hold layer data.
|
-- | Custom GTK object used to hold layer data.
|
||||||
|
@ -225,13 +226,9 @@ newLayersListModel ( Variables { .. } ) docUnique = do
|
||||||
mbOldChildStore <-
|
mbOldChildStore <-
|
||||||
STM.atomically $ do
|
STM.atomically $ do
|
||||||
parStores <- STM.readTVar parStoresTVar
|
parStores <- STM.readTVar parStoresTVar
|
||||||
let mbOldStore =
|
return $
|
||||||
Map.lookup ( Parent groupUnique ) =<< Map.lookup docUnique parStores
|
Map.lookup ( Parent groupUnique )
|
||||||
when ( isNothing mbOldStore ) $
|
=<< Map.lookup docUnique parStores
|
||||||
-- Take a lock to avoid creating multiple child stores
|
|
||||||
-- for the same group.
|
|
||||||
STM.takeTMVar listModelUpToDateTMVar
|
|
||||||
return mbOldStore
|
|
||||||
|
|
||||||
newChildStore <-
|
newChildStore <-
|
||||||
case mbOldChildStore of
|
case mbOldChildStore of
|
||||||
|
@ -258,8 +255,6 @@ newLayersListModel ( Variables { .. } ) docUnique = do
|
||||||
STM.atomically $ do
|
STM.atomically $ do
|
||||||
STM.modifyTVar parStoresTVar
|
STM.modifyTVar parStoresTVar
|
||||||
( Map.insertWith Map.union docUnique ( Map.singleton ( Parent groupUnique ) childStore ) )
|
( Map.insertWith Map.union docUnique ( Map.singleton ( Parent groupUnique ) childStore ) )
|
||||||
STM.putTMVar listModelUpToDateTMVar ()
|
|
||||||
|
|
||||||
return childStore
|
return childStore
|
||||||
|
|
||||||
-- Pass a copy of the (reference to the) child store
|
-- Pass a copy of the (reference to the) child store
|
||||||
|
@ -469,11 +464,16 @@ newLayerView uiElts@( UIElements { window } ) vars = mdo
|
||||||
-- void $ GTK.widgetGrabFocus label
|
-- void $ GTK.widgetGrabFocus label
|
||||||
| button == 3
|
| button == 3
|
||||||
-> do
|
-> do
|
||||||
|
mbTreeListRow <- traverse ( GTK.unsafeCastTo GTK.TreeListRow ) =<< GTK.listItemGetItem listItem
|
||||||
|
treeListRow <- case mbTreeListRow of
|
||||||
|
Nothing -> error "newLayerView ListItem onSetup: no TreeListRow"
|
||||||
|
Just r -> return r
|
||||||
|
srcPar <- fmap snd <$> getParent treeListRow
|
||||||
GTK.widgetUnparent layerPopover
|
GTK.widgetUnparent layerPopover
|
||||||
GTK.widgetSetParent layerPopover expander
|
GTK.widgetSetParent layerPopover expander
|
||||||
layer <- getLayerData listItem
|
layer <- getLayerData listItem
|
||||||
GIO.menuRemoveAll layerMenu
|
GIO.menuRemoveAll layerMenu
|
||||||
makeMenu uiElts vars layerMenu ( strokeMenuDescription layer )
|
makeMenu uiElts vars layerMenu ( strokeMenuDescription ( WithinParent srcPar layer ) )
|
||||||
GTK.popoverMenuSetMenuModel layerPopover ( Just layerMenu )
|
GTK.popoverMenuSetMenuModel layerPopover ( Just layerMenu )
|
||||||
rect <- GDK.newZeroRectangle
|
rect <- GDK.newZeroRectangle
|
||||||
GDK.setRectangleX rect ( round x )
|
GDK.setRectangleX rect ( round x )
|
||||||
|
@ -617,7 +617,7 @@ newLayerView uiElts@( UIElements { window } ) vars = mdo
|
||||||
updateLayerHierarchy vars $
|
updateLayerHierarchy vars $
|
||||||
DoLayerChange $
|
DoLayerChange $
|
||||||
SetBrush
|
SetBrush
|
||||||
{ setBrushStroke = WithinParent ( fmap snd dstPar ) tgtStrokeUnique
|
{ setBrushStroke = WithinParent ( fmap snd dstPar ) tgtStrokeUnique
|
||||||
, setBrushName = brushName
|
, setBrushName = brushName
|
||||||
}
|
}
|
||||||
return True
|
return True
|
||||||
|
@ -626,14 +626,16 @@ newLayerView uiElts@( UIElements { window } ) vars = mdo
|
||||||
let dropTgtUniq = layerUnique dropTgt
|
let dropTgtUniq = layerUnique dropTgt
|
||||||
dstFlatIndex <- GTK.treeListRowGetPosition treeListRow
|
dstFlatIndex <- GTK.treeListRowGetPosition treeListRow
|
||||||
h <- GTK.widgetGetHeight expander
|
h <- GTK.widgetGetHeight expander
|
||||||
let droppedAbove = y < 0.5 * fromIntegral h
|
let dropRelPos = if y < 0.5 * fromIntegral h
|
||||||
|
then Above
|
||||||
|
else Below
|
||||||
expanded <- GTK.treeListRowGetExpanded treeListRow
|
expanded <- GTK.treeListRowGetExpanded treeListRow
|
||||||
|
|
||||||
isDescendant <- isDescendantOf dragSrcUniq listItem
|
isDescendant <- isDescendantOf dragSrcUniq listItem
|
||||||
|
|
||||||
let mbDropIntoGroup
|
let mbDropIntoGroup
|
||||||
| expanded
|
| expanded
|
||||||
, not droppedAbove
|
, Below <- dropRelPos
|
||||||
, not isDescendant
|
, not isDescendant
|
||||||
= Just treeListRow
|
= Just treeListRow
|
||||||
| otherwise
|
| otherwise
|
||||||
|
@ -641,7 +643,7 @@ newLayerView uiElts@( UIElements { window } ) vars = mdo
|
||||||
mbDropOutsideGroup
|
mbDropOutsideGroup
|
||||||
| dragSrcUniq == dropTgtUniq
|
| dragSrcUniq == dropTgtUniq
|
||||||
, Parent par <- dstPar
|
, Parent par <- dstPar
|
||||||
, not droppedAbove
|
, Below <- dropRelPos
|
||||||
= Just par
|
= Just par
|
||||||
| otherwise
|
| otherwise
|
||||||
= Nothing
|
= Nothing
|
||||||
|
@ -691,9 +693,11 @@ newLayerView uiElts@( UIElements { window } ) vars = mdo
|
||||||
{ parent = fmap snd dstPar
|
{ parent = fmap snd dstPar
|
||||||
, item = dropTgtUniq
|
, item = dropTgtUniq
|
||||||
}
|
}
|
||||||
, moveAbove = droppedAbove
|
, moveRelPos = dropRelPos
|
||||||
}
|
}
|
||||||
, if droppedAbove then dstFlatIndex else dstFlatIndex + 1
|
, case dropRelPos of
|
||||||
|
Above -> dstFlatIndex
|
||||||
|
Below -> dstFlatIndex + 1
|
||||||
)
|
)
|
||||||
|
|
||||||
-- Compute the position that the item we are moving will have
|
-- Compute the position that the item we are moving will have
|
||||||
|
@ -957,7 +961,7 @@ data LayerChange
|
||||||
| NewItem
|
| NewItem
|
||||||
{ newUnique :: !Unique
|
{ newUnique :: !Unique
|
||||||
, newIsGroup :: !Bool
|
, newIsGroup :: !Bool
|
||||||
, newSelected :: !( Maybe ChildLayer )
|
, newPosition :: !( ChildLayer, RelativePosition )
|
||||||
}
|
}
|
||||||
| DeleteItems
|
| DeleteItems
|
||||||
{ deleteItems :: !( NE.NonEmpty ChildLayer )
|
{ deleteItems :: !( NE.NonEmpty ChildLayer )
|
||||||
|
@ -985,7 +989,7 @@ data MoveDst
|
||||||
-- | Move an item above or below another item.
|
-- | Move an item above or below another item.
|
||||||
| MoveAboveOrBelow
|
| MoveAboveOrBelow
|
||||||
{ moveDstItem :: !ChildLayer
|
{ moveDstItem :: !ChildLayer
|
||||||
, moveAbove :: !Bool
|
, moveRelPos :: !RelativePosition
|
||||||
-- ^ Whether to move above or below the destination.
|
-- ^ Whether to move above or below the destination.
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -994,91 +998,85 @@ data MoveDst
|
||||||
-- | Update the layer hierarchy, keeping both the application state and
|
-- | Update the layer hierarchy, keeping both the application state and
|
||||||
-- the GTK ListModel in sync.
|
-- the GTK ListModel in sync.
|
||||||
updateLayerHierarchy :: Variables -> DoLayerChange -> IO ()
|
updateLayerHierarchy :: Variables -> DoLayerChange -> IO ()
|
||||||
updateLayerHierarchy
|
updateLayerHierarchy vars@( Variables { parStoresTVar } ) doOrUndo = do
|
||||||
vars@( Variables { parStoresTVar, listModelUpToDateTMVar } )
|
mbDiff <- STM.atomically $ do
|
||||||
doOrUndo = do
|
|
||||||
mbDiff <- STM.atomically $ do
|
|
||||||
|
|
||||||
-- Ensure the GTK ListModel is up to date before continuing
|
-- TODO: need to use 'modifyingCurrentDocument' in some form,
|
||||||
-- (just a precaution).
|
-- but that function doesn't permit modifying history.
|
||||||
STM.takeTMVar listModelUpToDateTMVar
|
|
||||||
|
|
||||||
-- TODO: need to use 'modifyingCurrentDocument' in some form,
|
mbActiveDoc <- activeDocument vars
|
||||||
-- but that function doesn't permit modifying history.
|
( mbNewHist, mbDiff ) <-
|
||||||
|
case mbActiveDoc of
|
||||||
|
Nothing -> return ( Nothing, Nothing)
|
||||||
|
Just ( activeDocUnique, History past ( Document oldPresent oldMeta ) future ) -> do
|
||||||
|
let oldHierarchy = strokeHierarchy oldPresent
|
||||||
|
case doOrUndo of
|
||||||
|
DoLayerChange change -> do
|
||||||
|
let !( !hierarchy', !newNames, mbDiff ) = applyChangeToLayerHierarchy change oldHierarchy
|
||||||
|
!content' = oldPresent { strokeHierarchy = hierarchy' }
|
||||||
|
!meta' = over ( field' @"layerMetadata" . field' @"layerNames" ) ( newNames <> ) oldMeta
|
||||||
|
!( !history', mbDoOrUndo ) =
|
||||||
|
case mbDiff of
|
||||||
|
Nothing ->
|
||||||
|
( History
|
||||||
|
{ past = past
|
||||||
|
, present = Document content' meta'
|
||||||
|
, future = future
|
||||||
|
}
|
||||||
|
, Nothing )
|
||||||
|
Just diff ->
|
||||||
|
( History
|
||||||
|
{ past = past Seq.:|> ( oldPresent, HierarchyDiff diff )
|
||||||
|
, present = Document content' meta'
|
||||||
|
, future = []
|
||||||
|
}
|
||||||
|
, Just ( Do, diff ) )
|
||||||
|
return ( Just ( activeDocUnique, history' ), mbDoOrUndo )
|
||||||
|
UndoChange -> case past of
|
||||||
|
past' Seq.:|> ( present', diff ) -> do
|
||||||
|
let !history' =
|
||||||
|
History
|
||||||
|
{ past = past'
|
||||||
|
, present = Document present' oldMeta
|
||||||
|
, future = ( diff, oldPresent ) : future
|
||||||
|
}
|
||||||
|
return
|
||||||
|
( Just ( activeDocUnique, history' )
|
||||||
|
, case diff of
|
||||||
|
HierarchyDiff hDiff ->
|
||||||
|
Just ( Undo, hDiff )
|
||||||
|
_ -> Nothing
|
||||||
|
)
|
||||||
|
Seq.Empty ->
|
||||||
|
return ( Nothing, Nothing )
|
||||||
|
RedoChange -> case future of
|
||||||
|
( diff, present' ) : future' -> do
|
||||||
|
let history' =
|
||||||
|
History
|
||||||
|
{ past = past Seq.:|> ( oldPresent, diff )
|
||||||
|
, present = Document present' oldMeta
|
||||||
|
, future = future'
|
||||||
|
}
|
||||||
|
return
|
||||||
|
( Just ( activeDocUnique, history' )
|
||||||
|
, case diff of
|
||||||
|
HierarchyDiff hDiff ->
|
||||||
|
Just ( Do, hDiff )
|
||||||
|
_ -> Nothing
|
||||||
|
)
|
||||||
|
[] ->
|
||||||
|
return ( Nothing, Nothing )
|
||||||
|
|
||||||
mbActiveDoc <- activeDocument vars
|
for_ mbNewHist $ \ ( activeDoc, hist ) -> do
|
||||||
( mbNewHist, mbDiff ) <-
|
STM.modifyTVar' ( openDocumentsTVar vars ) ( Map.insert activeDoc hist )
|
||||||
case mbActiveDoc of
|
STM.writeTVar ( redrawStrokesTVar vars ) True
|
||||||
Nothing -> return ( Nothing, Nothing)
|
return $ ( , ) <$> ( fst <$> mbNewHist ) <*> mbDiff
|
||||||
Just ( activeDocUnique, History past ( Document oldPresent oldMeta ) future ) -> do
|
|
||||||
let oldHierarchy = strokeHierarchy oldPresent
|
|
||||||
case doOrUndo of
|
|
||||||
DoLayerChange change -> do
|
|
||||||
let !( !hierarchy', !newNames, mbDiff ) = applyChangeToLayerHierarchy change oldHierarchy
|
|
||||||
!content' = oldPresent { strokeHierarchy = hierarchy' }
|
|
||||||
!meta' = over ( field' @"layerMetadata" . field' @"layerNames" ) ( newNames <> ) oldMeta
|
|
||||||
!( !history', mbDoOrUndo ) =
|
|
||||||
case mbDiff of
|
|
||||||
Nothing ->
|
|
||||||
( History
|
|
||||||
{ past = past
|
|
||||||
, present = Document content' meta'
|
|
||||||
, future = future
|
|
||||||
}
|
|
||||||
, Nothing )
|
|
||||||
Just diff ->
|
|
||||||
( History
|
|
||||||
{ past = past Seq.:|> ( oldPresent, HierarchyDiff diff )
|
|
||||||
, present = Document content' meta'
|
|
||||||
, future = []
|
|
||||||
}
|
|
||||||
, Just ( Do, diff ) )
|
|
||||||
return ( Just ( activeDocUnique, history' ), mbDoOrUndo )
|
|
||||||
UndoChange -> case past of
|
|
||||||
past' Seq.:|> ( present', diff ) -> do
|
|
||||||
let !history' =
|
|
||||||
History
|
|
||||||
{ past = past'
|
|
||||||
, present = Document present' oldMeta
|
|
||||||
, future = ( diff, oldPresent ) : future
|
|
||||||
}
|
|
||||||
return
|
|
||||||
( Just ( activeDocUnique, history' )
|
|
||||||
, case diff of
|
|
||||||
HierarchyDiff hDiff ->
|
|
||||||
Just ( Undo, hDiff )
|
|
||||||
_ -> Nothing
|
|
||||||
)
|
|
||||||
Seq.Empty ->
|
|
||||||
return ( Nothing, Nothing )
|
|
||||||
RedoChange -> case future of
|
|
||||||
( diff, present' ) : future' -> do
|
|
||||||
let history' =
|
|
||||||
History
|
|
||||||
{ past = past Seq.:|> ( oldPresent, diff )
|
|
||||||
, present = Document present' oldMeta
|
|
||||||
, future = future'
|
|
||||||
}
|
|
||||||
return
|
|
||||||
( Just ( activeDocUnique, history' )
|
|
||||||
, case diff of
|
|
||||||
HierarchyDiff hDiff ->
|
|
||||||
Just ( Do, hDiff )
|
|
||||||
_ -> Nothing
|
|
||||||
)
|
|
||||||
[] ->
|
|
||||||
return ( Nothing, Nothing )
|
|
||||||
|
|
||||||
for_ mbNewHist $ \ ( activeDoc, hist ) -> do
|
for_ mbDiff $ \ ( docUnique, diff ) ->
|
||||||
STM.modifyTVar' ( openDocumentsTVar vars ) ( Map.insert activeDoc hist )
|
GLib.idleAdd GLib.PRIORITY_HIGH_IDLE $ do
|
||||||
STM.writeTVar ( redrawStrokesTVar vars ) True
|
|
||||||
return $ ( , ) <$> ( fst <$> mbNewHist ) <*> mbDiff
|
|
||||||
|
|
||||||
for_ mbDiff $ \ ( docUnique, diff ) ->
|
|
||||||
applyDiffToListModel parStoresTVar docUnique diff
|
applyDiffToListModel parStoresTVar docUnique diff
|
||||||
|
return False
|
||||||
|
|
||||||
STM.atomically $
|
|
||||||
STM.writeTMVar listModelUpToDateTMVar ()
|
|
||||||
|
|
||||||
|
|
||||||
-- | Apply a change to the application layer hierarchy.
|
-- | Apply a change to the application layer hierarchy.
|
||||||
|
@ -1093,11 +1091,11 @@ applyChangeToLayerHierarchy change hierarchy =
|
||||||
let mbDst =
|
let mbDst =
|
||||||
case moveDst of
|
case moveDst of
|
||||||
MoveAboveOrBelow
|
MoveAboveOrBelow
|
||||||
{ moveAbove
|
{ moveRelPos
|
||||||
, moveDstItem = WithinParent parUniq tgtUniq
|
, moveDstItem = WithinParent parUniq tgtUniq
|
||||||
} ->
|
} ->
|
||||||
Just ( parUniq
|
Just ( parUniq
|
||||||
, Just ( tgtUniq , moveAbove )
|
, Just ( tgtUniq , moveRelPos )
|
||||||
)
|
)
|
||||||
MoveToTopOfGroup
|
MoveToTopOfGroup
|
||||||
{ dstParUnique } ->
|
{ dstParUnique } ->
|
||||||
|
@ -1118,7 +1116,7 @@ applyChangeToLayerHierarchy change hierarchy =
|
||||||
| otherwise
|
| otherwise
|
||||||
= False
|
= False
|
||||||
, not expandedGroupWithChildren
|
, not expandedGroupWithChildren
|
||||||
-> Just ( grandParentUnique, Just ( parentUnique, False ) )
|
-> Just ( grandParentUnique, Just ( parentUnique, Below ) )
|
||||||
| otherwise
|
| otherwise
|
||||||
-> Nothing
|
-> Nothing
|
||||||
in case mbDst of
|
in case mbDst of
|
||||||
|
@ -1143,14 +1141,9 @@ applyChangeToLayerHierarchy change hierarchy =
|
||||||
}
|
}
|
||||||
Nothing -> Nothing
|
Nothing -> Nothing
|
||||||
)
|
)
|
||||||
NewItem { newUnique = u, newIsGroup, newSelected } ->
|
NewItem { newUnique = u, newIsGroup, newPosition = ( WithinParent dstParUniq childUniq, relPos ) } ->
|
||||||
let ( dstParUniq, dstChild ) = case newSelected of
|
let dropPos = Just ( childUniq, relPos )
|
||||||
Nothing -> ( Root, Nothing )
|
!( !hierarchy', dstChildIx ) = insertLayerIntoParent hierarchy ( dstParUniq, dropPos ) u
|
||||||
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'' =
|
!hierarchy'' =
|
||||||
if newIsGroup
|
if newIsGroup
|
||||||
then insertGroup ( Parent u ) [] hierarchy'
|
then insertGroup ( Parent u ) [] hierarchy'
|
||||||
|
@ -1228,7 +1221,8 @@ applyDeletionToStrokeHierarchy hierarchy0 = go hierarchy0
|
||||||
--
|
--
|
||||||
-- The change to the application 'StrokeHierarchy' is done beforehand,
|
-- The change to the application 'StrokeHierarchy' is done beforehand,
|
||||||
-- in 'applyChangeToLayerHierarchy'.
|
-- in 'applyChangeToLayerHierarchy'.
|
||||||
applyDiffToListModel :: STM.TVar ( Map Unique ( Map ( Parent Unique ) GIO.ListStore ) )
|
applyDiffToListModel :: HasCallStack
|
||||||
|
=> STM.TVar ( Map Unique ( Map ( Parent Unique ) GIO.ListStore ) )
|
||||||
-> Unique
|
-> Unique
|
||||||
-> ( Do, HierarchyDiff )
|
-> ( Do, HierarchyDiff )
|
||||||
-> IO ()
|
-> IO ()
|
||||||
|
@ -1287,7 +1281,7 @@ applyDiffToListModel parStoreTVar docUnique ( doOrUndo, diff ) = do
|
||||||
Just item -> do
|
Just item -> do
|
||||||
GIO.listStoreRemove dstStore dstIx
|
GIO.listStoreRemove dstStore dstIx
|
||||||
GIO.listStoreInsert srcStore srcIx item
|
GIO.listStoreInsert srcStore srcIx item
|
||||||
NewLayer { newPosition = WithinParent dstPar dstIx, newUnique, newIsGroup } ->
|
NewLayer { newPosition = WithinParent dstPar dstIx, newUnique, newIsGroup } -> do
|
||||||
case Map.lookup dstPar parStoreFromUniq of
|
case Map.lookup dstPar parStoreFromUniq of
|
||||||
Nothing ->
|
Nothing ->
|
||||||
putStrLn $ unlines
|
putStrLn $ unlines
|
||||||
|
@ -1372,7 +1366,7 @@ sequentialOn f ( a NE.:| as ) = go ( f a ) as
|
||||||
moveLayerUpdate
|
moveLayerUpdate
|
||||||
:: ( Parent Unique, Unique )
|
:: ( Parent Unique, Unique )
|
||||||
-- ^ source
|
-- ^ source
|
||||||
-> ( Parent Unique, Maybe ( Unique, Bool ) )
|
-> ( Parent Unique, Maybe ( Unique, RelativePosition ) )
|
||||||
-- ^ destination
|
-- ^ destination
|
||||||
--
|
--
|
||||||
-- - @Nothing@: drop as first element of group
|
-- - @Nothing@: drop as first element of group
|
||||||
|
@ -1423,7 +1417,7 @@ removeLayerFromParent hierarchy ( parent, u ) =
|
||||||
--
|
--
|
||||||
-- NB: does not add the layer itself.
|
-- NB: does not add the layer itself.
|
||||||
insertLayerIntoParent :: StrokeHierarchy
|
insertLayerIntoParent :: StrokeHierarchy
|
||||||
-> ( Parent Unique, Maybe ( Unique, Bool ) )
|
-> ( Parent Unique, Maybe ( Unique, RelativePosition ) )
|
||||||
-- ^ destination
|
-- ^ destination
|
||||||
--
|
--
|
||||||
-- - @Nothing@: drop as first element of group
|
-- - @Nothing@: drop as first element of group
|
||||||
|
@ -1441,12 +1435,12 @@ insertLayerIntoParent hierarchy ( newPar, mbTgtUniq ) srcUniq =
|
||||||
, 0
|
, 0
|
||||||
)
|
)
|
||||||
-- Drop (before or after) given child.
|
-- Drop (before or after) given child.
|
||||||
Just ( tgtUniq, dropAbove ) ->
|
Just ( tgtUniq, dropRelPos ) ->
|
||||||
let ( bef, aft ) = break ( == tgtUniq ) $ filter ( /= srcUniq ) newPar_oldCs
|
let ( bef, aft ) = break ( == tgtUniq ) $ filter ( /= srcUniq ) newPar_oldCs
|
||||||
in ( if dropAbove
|
in ( case dropRelPos of
|
||||||
then bef ++ [ srcUniq ] ++ aft
|
Above -> bef ++ [ srcUniq ] ++ aft
|
||||||
else bef ++ take 1 aft ++ [ srcUniq ] ++ drop 1 aft
|
Below -> bef ++ take 1 aft ++ [ srcUniq ] ++ drop 1 aft
|
||||||
, fromIntegral ( length ( takeWhile ( /= tgtUniq ) $ newPar_oldCs ) )
|
, fromIntegral ( length ( takeWhile ( /= tgtUniq ) $ newPar_oldCs ) )
|
||||||
+ if dropAbove then 0 else 1
|
+ case dropRelPos of { Above -> 0; Below -> 1 }
|
||||||
)
|
)
|
||||||
in ( insertGroup newPar newPar_newCs hierarchy, newChildPos )
|
in ( insertGroup newPar newPar_newCs hierarchy, newChildPos )
|
||||||
|
|
|
@ -1,5 +1,8 @@
|
||||||
module MetaBrush.UI.StrokeTreeView where
|
module MetaBrush.UI.StrokeTreeView where
|
||||||
|
|
||||||
|
-- base
|
||||||
|
import GHC.Stack
|
||||||
|
|
||||||
-- containers
|
-- containers
|
||||||
import Data.Map.Strict
|
import Data.Map.Strict
|
||||||
( Map )
|
( Map )
|
||||||
|
@ -28,7 +31,8 @@ switchStrokeView :: GTK.ListView -> Variables -> Maybe Unique -> IO ()
|
||||||
|
|
||||||
newLayerView :: UIElements -> Variables -> IO GTK.ListView
|
newLayerView :: UIElements -> Variables -> IO GTK.ListView
|
||||||
|
|
||||||
applyDiffToListModel :: STM.TVar ( Map Unique ( Map ( Parent Unique ) GIO.ListStore ) )
|
applyDiffToListModel :: HasCallStack
|
||||||
|
=> STM.TVar ( Map Unique ( Map ( Parent Unique ) GIO.ListStore ) )
|
||||||
-> Unique
|
-> Unique
|
||||||
-> ( Do, HierarchyDiff )
|
-> ( Do, HierarchyDiff )
|
||||||
-> IO ()
|
-> IO ()
|
||||||
|
|
|
@ -64,7 +64,7 @@ data WithinParent a =
|
||||||
{ parent :: !( Parent Unique )
|
{ parent :: !( Parent Unique )
|
||||||
, item :: !a
|
, item :: !a
|
||||||
}
|
}
|
||||||
deriving stock ( Show, Eq, Generic )
|
deriving stock ( Show, Eq, Generic, Functor )
|
||||||
deriving anyclass NFData
|
deriving anyclass NFData
|
||||||
|
|
||||||
-- | A child layer within a parent.
|
-- | A child layer within a parent.
|
||||||
|
@ -72,6 +72,12 @@ type ChildLayer = WithinParent Unique
|
||||||
-- | A child layer, with its index among the list of children of its parent.
|
-- | A child layer, with its index among the list of children of its parent.
|
||||||
type ChildLayerPosition = WithinParent Word32
|
type ChildLayerPosition = WithinParent Word32
|
||||||
|
|
||||||
|
-- | Where to position something relative to another layer.
|
||||||
|
data RelativePosition
|
||||||
|
= Above
|
||||||
|
| Below
|
||||||
|
deriving stock ( Eq, Ord, Show )
|
||||||
|
|
||||||
-- | Content in a hierarchical tree-like structure.
|
-- | Content in a hierarchical tree-like structure.
|
||||||
data Hierarchy a =
|
data Hierarchy a =
|
||||||
Hierarchy
|
Hierarchy
|
||||||
|
|
Loading…
Reference in a new issue