diff --git a/MetaBrush.cabal b/MetaBrush.cabal index c9c5d0f..3e3690d 100644 --- a/MetaBrush.cabal +++ b/MetaBrush.cabal @@ -149,7 +149,7 @@ common gtk , gi-cairo-connector ^>= 0.1.0 , gi-gdk - >= 4.0.2 && < 4.1 + >= 4.0.9 && < 4.1 , gi-gio >= 2.0.34 && < 2.1 , gi-glib @@ -161,7 +161,7 @@ common gtk , haskell-gi >= 0.26.10 && < 0.27 , haskell-gi-base - >= 0.26.6 && < 0.27 + >= 0.26.8 && < 0.27 -- Workaround for https://github.com/haskell/cabal/issues/4237 -- See https://github.com/commercialhaskell/stack/issues/2197 @@ -246,6 +246,7 @@ executable MetaBrush , MetaBrush.UI.InfoBar , MetaBrush.UI.Menu , MetaBrush.UI.Panels + , MetaBrush.UI.StrokeTreeView , MetaBrush.UI.ToolBar , MetaBrush.UI.Viewport diff --git a/assets/theme.css b/assets/theme.css index 08b5be0..37eba06 100644 --- a/assets/theme.css +++ b/assets/theme.css @@ -1,7 +1,32 @@ +/* .metabrush * { all: unset; } +*/ + +.toggle, .dialogButton, .titleBar, .windowIcon, .fileBarCloseButton, +.newFileButton, .header, .paned, .panel, .tabs, .frame { + all: unset; +} + +.reorderable-page { + all: unset; +} + +.menu * { + all: unset; +} + +.frame > * { + all: unset; +} + + +.notebook { + all: unset; +} + @import url("colours.css"); @@ -470,4 +495,100 @@ To specify it in CSS, set the box-shadow of the contents node." .infoBarInfo { margin-left: -4px; padding-right: 16px; -} \ No newline at end of file +} + +/* Stroke hierarchy layers */ + +row { + border-top: 0px; + border-bottom: 0px; + margin-top: -2px; + margin-bottom: -2px; +} + +/* Slightly hacky way to align layers and groups */ +indent { + margin-left: 4px; + margin-right: 4px; +} + +:selected { + background-color: rgba(255,255,255,0); + font-weight: bold; + color: black; +} + +.layer-item { + color: @plain; + background-color: @active; + border: 0px solid @bg; + transition: + border-color 0.3s ease-out, + border-color 0.2s ease-in, + background-color 0.6s ease-out, + background-color 0.4s ease-in, + box-shadow 0.6s ease-out, + box-shadow 0.4s ease-in; + + padding-top: 4px; + padding-bottom: 4px; + border-top: 1px solid @active; + border-bottom: 1px solid @active; + margin-top: -1px; + margin-bottom: -1px; + padding-left: 3px; +} + +:selected .layer-item { + color: black; + background-color: @contrast; + border: 0px solid @contrast; +} + +/* Add "drop here" areas when a drag has been initiated */ +.dragging-item .layer-item { +} + +/* Style when dragging over an item */ +.drag-over.layer-item { +} + +/* Style when dragging over the top part of an item */ +.drag-top.layer-item { + border-top: 2px solid @highlight; + margin-top: -2px; + box-shadow: + 0 -1px 6px 1px @highlight, + inset 0 8px 6px -6px @highlight; +} + +/* Style when dragging over the bottom part of an item */ +.drag-bot.layer-item { + border-bottom: 2px solid @highlight; + margin-bottom: -2px; + box-shadow: + inset 0 -8px 6px -6px @highlight; +} + +/* Style for item being dragged */ +.dragged.layer-item { + background-color: @bg; + transition: + background-color 0.4s ease-in-out; +} + +/* Wide separator styling */ +.metabrush .wide { + background-color: @bg; + background-size: 0px; + background-image: none; + min-width: 2px; + min-height: 2px; +} + +/* List view */ +.metabrush .view { + margin-top: 3px; + border: 0px; + background-color: @bg; +} diff --git a/src/app/MetaBrush/Application.hs b/src/app/MetaBrush/Application.hs index cc82c8c..5112613 100644 --- a/src/app/MetaBrush/Application.hs +++ b/src/app/MetaBrush/Application.hs @@ -25,8 +25,6 @@ import Data.Map.Strict ( Map ) import qualified Data.Map.Strict as Map import qualified Data.Sequence as Seq -import Data.Set - ( Set ) import qualified Data.Set as Set -- directory @@ -61,9 +59,6 @@ import Control.Lens -- stm import qualified Control.Concurrent.STM as STM - ( atomically, retry ) -import qualified Control.Concurrent.STM.TVar as STM - ( newTVarIO, readTVar, writeTVar ) -- transformers import Control.Monad.Trans.Reader @@ -71,7 +66,7 @@ import Control.Monad.Trans.Reader -- brush-strokes import Math.Root.Isolation - ( RootIsolationOptions(..), defaultRootIsolationOptions ) + ( defaultRootIsolationOptions ) import Math.Bezier.Cubic.Fit ( FitParameters(..) ) import Math.Bezier.Spline @@ -86,16 +81,14 @@ import Math.Linear -- MetaBrush import MetaBrush.Application.Action ( ActionOrigin(..) ) +import MetaBrush.Application.Context + ( UIElements(..), Variables(..) ) + import qualified MetaBrush.Asset.Brushes as Asset.Brushes import MetaBrush.Asset.Colours ( getColours ) import MetaBrush.Asset.Logo ( drawLogo ) -import MetaBrush.Application.Context - ( UIElements(..), Variables(..) - , Modifier(..) - , HoldAction(..), PartialPath(..) - ) import MetaBrush.Application.UpdateDocument ( activeDocument, withActiveDocument ) import MetaBrush.Document @@ -113,15 +106,14 @@ import MetaBrush.Render.Rulers ( renderRuler ) import MetaBrush.Stroke import MetaBrush.UI.FileBar - ( FileBar(..), FileBarTab, createFileBar ) + ( FileBar(..), createFileBar ) import MetaBrush.UI.InfoBar ( InfoBar(..), createInfoBar, updateInfoBar ) import MetaBrush.UI.Menu ( createMenuBar, createMenuActions ) import MetaBrush.UI.Panels - ( createPanelBar ) ---import MetaBrush.UI.StrokeTreeView --- ( newStrokeView ) +import MetaBrush.UI.StrokeTreeView + ( newLayerView ) import MetaBrush.UI.ToolBar ( Tool(..), Mode(..), createToolBar ) import MetaBrush.UI.Viewport @@ -147,7 +139,6 @@ runApplication application = do uniqueSupply <- newUniqueSupply docUnique <- runReaderT freshUnique uniqueSupply - strokeUnique <- runReaderT freshUnique uniqueSupply let testStroke = @@ -175,17 +166,30 @@ runApplication application = do testLayers :: Layers testLayers = - [ StrokeLayer - { layerUnique = strokeUnique - , layerName = "Stroke 1" - , layerVisible = True - , layerLocked = False - , layerStroke = testStroke + [ GroupLayer + { layerName = "Group 1" + , layerVisible = True + , layerLocked = False + , groupChildren = + [ StrokeLayer + { layerName = "Stroke 1" + , layerVisible = True + , layerLocked = False + , layerStroke = testStroke + } + ] + } + , GroupLayer + { layerName = "Group 2" + , layerVisible = True + , layerLocked = False + , groupChildren = [] } ] - ( layerMeta, testStrokes ) = layersStrokeHierarchy testLayers + ( layerMeta, testStrokes ) <- ( `runReaderT` uniqueSupply ) $ layersStrokeHierarchy testLayers + let testDoc :: Document testDoc = emptyDocument "Test" @@ -196,39 +200,38 @@ runApplication application = do testDocuments = newHistory <$> Map.fromList [ ( docUnique, testDoc ) ] - recomputeStrokesTVar <- STM.newTVarIO @Bool False - documentRenderTVar <- STM.newTVarIO @( ( Int32, Int32 ) -> Cairo.Render () ) ( const $ pure () ) - activeDocumentTVar <- STM.newTVarIO @( Maybe Unique ) Nothing - openDocumentsTVar <- STM.newTVarIO @( Map Unique DocumentHistory ) testDocuments - mousePosTVar <- STM.newTVarIO @( Maybe ( ℝ 2 ) ) Nothing - mouseHoldTVar <- STM.newTVarIO @( Maybe HoldAction ) Nothing - modifiersTVar <- STM.newTVarIO @( Set Modifier ) Set.empty - toolTVar <- STM.newTVarIO @Tool Selection - modeTVar <- STM.newTVarIO @Mode PathMode - debugTVar <- STM.newTVarIO @Bool False - partialPathTVar <- STM.newTVarIO @( Maybe PartialPath ) Nothing - fileBarTabsTVar <- STM.newTVarIO @( Map Unique FileBarTab ) Map.empty - showGuidesTVar <- STM.newTVarIO @Bool True - maxHistorySizeTVar <- STM.newTVarIO @Int 1000 - fitParametersTVar <- STM.newTVarIO @FitParameters $ - FitParameters - { maxSubdiv = 2 --5 --2 --3 -- 6 - , nbSegments = 3 - , dist_tol = 5e-3 - , t_tol = 1e-4 - , maxIters = 20 - } - rootsAlgoTVar <- STM.newTVarIO @RootSolvingAlgorithm $ - --HalleyM2 - NewtonRaphson - { maxIters = 20, precision = 8 } - cuspFindingOptionsTVar <- STM.newTVarIO @( Maybe ( RootIsolationOptions 2 3 ) ) $ + recomputeStrokesTVar <- STM.newTVarIO False + documentRenderTVar <- STM.newTVarIO ( const $ pure () ) + activeDocumentTVar <- STM.newTVarIO Nothing + openDocumentsTVar <- STM.newTVarIO testDocuments + strokeListModelsTVar <- STM.newTVarIO Map.empty + parStoresTVar <- STM.newTVarIO Map.empty + listModelUpToDateTMVar <- STM.newTMVarIO () + mousePosTVar <- STM.newTVarIO Nothing + mouseHoldTVar <- STM.newTVarIO Nothing + modifiersTVar <- STM.newTVarIO Set.empty + toolTVar <- STM.newTVarIO Selection + modeTVar <- STM.newTVarIO PathMode + debugTVar <- STM.newTVarIO False + partialPathTVar <- STM.newTVarIO Nothing + fileBarTabsTVar <- STM.newTVarIO Map.empty + showGuidesTVar <- STM.newTVarIO True + maxHistorySizeTVar <- STM.newTVarIO 1000 + fitParametersTVar <- STM.newTVarIO $ + FitParameters + { maxSubdiv = 2 --5 --2 --3 -- 6 + , nbSegments = 3 + , dist_tol = 5e-3 + , t_tol = 1e-4 + , maxIters = 20 + } + rootsAlgoTVar <- STM.newTVarIO $ + --HalleyM2 + NewtonRaphson + { maxIters = 20, precision = 8 } + cuspFindingOptionsTVar <- STM.newTVarIO $ Just defaultRootIsolationOptions - --testDocsStrokeListModels <- - -- for testDocuments ( newStrokeView . strokes . documentContent . present ) - strokeListModelsTVar <- STM.newTVarIO @( Map Unique GTK.SelectionModel ) Map.empty --testDocsStrokeListModels - -- Put all these stateful variables in a record for conciseness. let variables :: Variables @@ -274,6 +277,7 @@ runApplication application = do toolBar <- GTK.boxNew GTK.OrientationVertical 0 mainPane <- GTK.panedNew GTK.OrientationHorizontal + GTK.panedSetWideHandle mainPane True panelBox <- GTK.boxNew GTK.OrientationVertical 0 GTK.gridAttach uiGrid toolBar 0 0 2 1 @@ -428,11 +432,6 @@ runApplication application = do _ <- createToolBar variables colours toolBar - --------------------------------------------------------- - -- Panels bar - - panelsBar <- createPanelBar panelBox - --------------------------------------------------------- -- Info bar @@ -440,6 +439,11 @@ runApplication application = do menuActions <- createMenuActions + --------------------------------------------------------- + -- Panels bar + + panelsBar <- createPanelBar panelBox + rec --------------------------------------------------------- @@ -450,7 +454,7 @@ runApplication application = do colours variables application window windowKeys titleBar titleLabel viewport infoBar menuBar menuActions - panelsBar + panelsBar strokesListView let uiElements :: UIElements @@ -461,6 +465,15 @@ runApplication application = do menuBar <- createMenuBar uiElements variables colours + --------------------------------------------------------- + -- Strokes view + + strokesListView <- newLayerView uiElements variables + + GTK.scrolledWindowSetChild + ( layersScrolledWindow panelsBar ) + ( Just strokesListView ) + GTK.boxAppend mainView fileBarBox GTK.boxAppend mainView viewportGrid GTK.boxAppend mainView infoBarArea diff --git a/src/app/MetaBrush/Application/Action.hs b/src/app/MetaBrush/Application/Action.hs index 51c6243..03cd009 100644 --- a/src/app/MetaBrush/Application/Action.hs +++ b/src/app/MetaBrush/Application/Action.hs @@ -20,8 +20,6 @@ import Data.Traversable ( for ) import Data.Word ( Word32 ) -import GHC.Generics - ( Generic ) -- acts import Data.Act @@ -66,10 +64,6 @@ import qualified GI.Gtk as GTK -- haskell-gi-base import qualified Data.GI.Base as GI --- hashable -import Data.Hashable - ( Hashable ) - -- lens import Control.Lens ( over, set ) @@ -103,10 +97,6 @@ import Math.Linear -- MetaBrush import MetaBrush.Action import MetaBrush.Application.Context - ( UIElements(..), Variables(..) - , Modifier(..), modifierKey - , HoldAction(..), GuideAction(..), PartialPath(..) - ) import MetaBrush.Document ( Document(..), DocumentContent(..), DocumentMetadata(..) , Zoom(..) @@ -142,10 +132,8 @@ import MetaBrush.UI.Coordinates ( toViewportCoordinates ) import MetaBrush.UI.InfoBar ( updateInfoBar ) -import {-# SOURCE #-} MetaBrush.UI.FileBar - ( FileBarTab(..), TabLocation(..), newFileTab, removeFileTab ) -import MetaBrush.UI.ToolBar - ( Tool(..), Mode(..) ) +import MetaBrush.UI.FileBar + ( newFileTab, removeFileTab ) import MetaBrush.UI.Viewport ( Viewport(..) ) import MetaBrush.Unique @@ -157,12 +145,6 @@ import MetaBrush.GTK.Util -------------------------------------------------------------------------------- -data ActionName - = AppAction { actionSimpleName :: !Text } - | WinAction { actionSimpleName :: !Text } - deriving stock ( Eq, Ord, Show, Generic ) - deriving anyclass Hashable - actionPrefix :: ActionName -> Text actionPrefix ( AppAction _ ) = "app." actionPrefix ( WinAction _ ) = "win." @@ -664,10 +646,9 @@ instance HandleAction Delete where Nothing -> pure Don'tModifyDoc Just ( doc', affectedPoints, delStrokes ) -> do - -- TODO: this would also be a hierarchy diff... - -- but for now we will just have emtpy strokes in the - -- layers view. - let diff = HistoryDiff $ ContentDiff $ + -- TODO: only a hierarchy diff if there are + -- any deleted strokes. + let diff = HistoryDiff $ HierarchyDiff $ DeletePoints { deletedPoints = affectedPoints , deletedStrokes = delStrokes @@ -968,6 +949,7 @@ instance HandleAction MouseClick where , newPosition = WithinParent Root 0 -- TODO: add the stroke above the selected layer -- or something of the sort. + , newIsGroup = False } pure ( UpdateDoc $ UpdateDocumentTo newDocument diff ) else diff --git a/src/app/MetaBrush/Application/Action.hs-boot b/src/app/MetaBrush/Application/Action.hs-boot index 7c973cd..2eea202 100644 --- a/src/app/MetaBrush/Application/Action.hs-boot +++ b/src/app/MetaBrush/Application/Action.hs-boot @@ -7,21 +7,10 @@ import Data.Word -- gi-gtk import qualified GI.Gtk as GTK --- hashable -import Data.Hashable - ( Hashable ) - --- text -import Data.Text - ( Text ) - -- MetaBrush import Math.Linear ( ℝ(..), T(..) ) -import {-# SOURCE #-} MetaBrush.Application.Context - ( UIElements, Variables ) -import {-# SOURCE #-} MetaBrush.UI.FileBar - ( TabLocation(..) ) +import MetaBrush.Application.Context import MetaBrush.UI.Viewport ( Ruler(..) ) import MetaBrush.Unique @@ -29,15 +18,6 @@ import MetaBrush.Unique -------------------------------------------------------------------------------- -data ActionName - = AppAction { actionSimpleName :: !Text } - | WinAction { actionSimpleName :: !Text } - -instance Eq ActionName -instance Ord ActionName -instance Show ActionName -instance Hashable ActionName - class HandleAction action where handleAction :: UIElements -> Variables -> action -> IO () diff --git a/src/app/MetaBrush/Application/Context.hs b/src/app/MetaBrush/Application/Context.hs index 1f344ee..9dd0da3 100644 --- a/src/app/MetaBrush/Application/Context.hs +++ b/src/app/MetaBrush/Application/Context.hs @@ -1,15 +1,12 @@ -module MetaBrush.Application.Context - ( UIElements(..), Variables(..) - , LR(..), Modifier(..), modifierKey - , HoldAction(..), GuideAction(..), PartialPath(..) - ) - where +module MetaBrush.Application.Context where -- base import Data.Int ( Int32 ) import Data.Word ( Word32 ) +import GHC.Generics + ( Generic ) -- containers import Data.Set @@ -30,9 +27,17 @@ import qualified GI.Gio as GIO -- gi-gtk import qualified GI.Gtk as GTK +-- hashable +import Data.Hashable + ( Hashable ) + -- stm -import qualified Control.Concurrent.STM.TVar as STM - ( TVar ) +import qualified Control.Concurrent.STM.TVar as STM +import qualified Control.Concurrent.STM.TMVar as STM + +-- text +import Data.Text + ( Text ) -- unordered-containers import Data.HashMap.Strict @@ -51,8 +56,6 @@ import Math.Root.Isolation -- MetaBrush import MetaBrush.Action ( BrushWidgetActionState ) -import {-# SOURCE #-} MetaBrush.Application.Action - ( ActionName ) import MetaBrush.Asset.Colours ( Colours ) import MetaBrush.Document.Diff @@ -61,14 +64,10 @@ import MetaBrush.Draw ( DrawAnchor ) import MetaBrush.Document.History ( DocumentHistory(..) ) -import {-# SOURCE #-} MetaBrush.UI.FileBar - ( FileBar, FileBarTab ) -import {-# SOURCE #-} MetaBrush.UI.InfoBar - ( InfoBar ) +import MetaBrush.Layer + ( Parent ) import MetaBrush.UI.Panels ( PanelsBar ) -import {-# SOURCE #-} MetaBrush.UI.ToolBar - ( Tool, Mode ) import MetaBrush.UI.Viewport ( Viewport(..), Ruler(..) ) import MetaBrush.Unique @@ -79,18 +78,19 @@ import MetaBrush.Unique data UIElements = UIElements - { application :: !GTK.Application - , window :: !GTK.ApplicationWindow - , windowKeys :: !GTK.EventControllerKey - , titleBar :: !GTK.HeaderBar - , titleLabel :: !GTK.Label - , fileBar :: !FileBar - , viewport :: !Viewport - , infoBar :: !InfoBar - , menuBar :: GTK.PopoverMenuBar -- needs to be lazy for RecursiveDo - , menuActions :: !( HashMap ActionName GIO.SimpleAction ) - , panelsBar :: !PanelsBar - , colours :: !Colours + { application :: !GTK.Application + , window :: !GTK.ApplicationWindow + , windowKeys :: !GTK.EventControllerKey + , titleBar :: !GTK.HeaderBar + , titleLabel :: !GTK.Label + , fileBar :: !FileBar + , viewport :: !Viewport + , infoBar :: !InfoBar + , menuBar :: GTK.PopoverMenuBar -- needs to be lazy for RecursiveDo + , menuActions :: !( HashMap ActionName GIO.SimpleAction ) + , panelsBar :: !PanelsBar + , strokesListView :: GTK.ListView + , colours :: !Colours } data Variables @@ -100,7 +100,19 @@ data Variables , documentRenderTVar :: !( STM.TVar ( ( Int32, Int32 ) -> Cairo.Render () ) ) , activeDocumentTVar :: !( STM.TVar ( Maybe Unique ) ) , openDocumentsTVar :: !( STM.TVar ( Map Unique DocumentHistory ) ) - , strokeListModelsTVar :: !( STM.TVar ( Map Unique GTK.SelectionModel ) ) + , strokeListModelsTVar :: !( STM.TVar ( Map Unique GTK.SingleSelection ) ) + + -- | 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'. + , parStoresTVar :: !( STM.TVar ( Map Unique ( Map ( Parent Unique ) GIO.ListStore ) ) ) + + -- | This TMVar is used to ensure that the layer hierarchy data + -- is kept in-sync between the application and the UI's 'GTK.TreeListModel'. + , listModelUpToDateTMVar :: !( STM.TMVar () ) + , mousePosTVar :: !( STM.TVar ( Maybe ( ℝ 2 ) ) ) , mouseHoldTVar :: !( STM.TVar ( Maybe HoldAction ) ) , modifiersTVar :: !( STM.TVar ( Set Modifier ) ) @@ -176,3 +188,62 @@ data PartialPath , firstPoint :: !Bool } deriving stock Show + +-------------------------------------------------------------------------------- + +data Tool + = Selection + | Pen + deriving stock ( Show, Eq ) + +data Mode + = PathMode + | BrushMode + | MetaMode + deriving stock ( Show, Eq ) + +data ToolBar + = ToolBar + { selectionTool, penTool, pathTool, brushTool, metaTool, debugTool + :: !GTK.ToggleButton + } + +-------------------------------------------------------------------------------- + +data FileBar + = FileBar + { fileBarBox :: !GTK.Box + , fileTabsBox :: !GTK.Box + , fileBarPhantomToggleButton :: !GTK.ToggleButton + } + +data FileBarTab + = FileBarTab + { fileBarTab :: !GTK.Box + , fileBarTabButton :: !GTK.ToggleButton + , fileBarTabCloseArea :: !GTK.DrawingArea + } + +data TabLocation + = AfterCurrentTab + | LastTab + deriving stock Show + +-------------------------------------------------------------------------------- + +data InfoBar + = InfoBar + { infoBarArea :: !GTK.Box + , zoomText :: !GTK.Label -- make this editable + , cursorPosText, topLeftPosText, botRightPosText :: !GTK.Label + } + +-------------------------------------------------------------------------------- + +data ActionName + = AppAction { actionSimpleName :: !Text } + | WinAction { actionSimpleName :: !Text } + deriving stock ( Eq, Show, Generic ) + deriving anyclass Hashable + +-------------------------------------------------------------------------------- diff --git a/src/app/MetaBrush/Application/Context.hs-boot b/src/app/MetaBrush/Application/Context.hs-boot deleted file mode 100644 index 4f321b8..0000000 --- a/src/app/MetaBrush/Application/Context.hs-boot +++ /dev/null @@ -1,17 +0,0 @@ -module MetaBrush.Application.Context - ( UIElements, Variables - , Modifier(..), LR(..) ) - where - --------------------------------------------------------------------------------- - -data UIElements - -data Variables - -data LR = L | R - -data Modifier - = Control LR - | Alt LR - | Shift LR diff --git a/src/app/MetaBrush/Application/UpdateDocument.hs b/src/app/MetaBrush/Application/UpdateDocument.hs index 1e9134a..1df9794 100644 --- a/src/app/MetaBrush/Application/UpdateDocument.hs +++ b/src/app/MetaBrush/Application/UpdateDocument.hs @@ -18,12 +18,14 @@ import Data.Traversable -- containers import qualified Data.Map.Strict as Map - ( adjust, delete, lookup ) -- generic-lens import Data.Generics.Product.Fields ( field' ) +-- gi-glib +import qualified GI.GLib as GLib + -- gi-gio import qualified GI.Gio as GIO @@ -40,9 +42,6 @@ import Control.Lens.Fold import Control.Concurrent.STM ( STM ) import qualified Control.Concurrent.STM as STM - ( atomically ) -import qualified Control.Concurrent.STM.TVar as STM - ( readTVar, readTVar, modifyTVar', writeTVar ) -- text import Data.Text @@ -59,24 +58,23 @@ import qualified Data.HashMap.Lazy as HashMap ( lookup ) -- MetaBrush -import {-# SOURCE #-} MetaBrush.Application.Action - ( ActionName(..) ) import MetaBrush.Application.Context - ( UIElements(..), Variables(..) ) import MetaBrush.Document ( Document(..), DocumentContent(..), DocumentMetadata(..) ) import MetaBrush.Document.Diff import MetaBrush.Document.History ( DocumentHistory(..), atStart, atEnd - , newFutureStep, affirmPresent + , newFutureStep, affirmPresentSaved ) import MetaBrush.GTK.Util ( (>>?=) ) import {-# SOURCE #-} MetaBrush.UI.FileBar - ( FileBarTab(..), removeFileTab ) -import {-# SOURCE #-} MetaBrush.UI.InfoBar + ( removeFileTab ) +import MetaBrush.UI.InfoBar ( updateInfoBar ) +import {-# SOURCE #-} MetaBrush.UI.StrokeTreeView + ( switchStrokeView ) import MetaBrush.UI.Viewport ( Viewport(..) ) import MetaBrush.Unique @@ -152,14 +150,14 @@ modifyingCurrentDocument uiElts@( UIElements { menuActions } ) vars@( Variables let change = ActiveDocChange { mbOldDocUnique = Just unique } coerce ( updateUIAction change uiElts vars ) SaveDocument Nothing -> do - STM.modifyTVar' openDocumentsTVar ( Map.adjust affirmPresent unique ) + STM.modifyTVar' openDocumentsTVar ( Map.adjust affirmPresentSaved unique ) coerce ( updateUIAction NoActiveDocChange uiElts vars ) SaveDocument ( Just newFilePath ) -> do STM.modifyTVar' openDocumentsTVar ( Map.adjust - ( affirmPresent + ( affirmPresentSaved . set ( field' @"present" . field' @"documentMetadata" . field' @"documentFilePath" ) - ( Just newFilePath ) + ( Just newFilePath ) ) unique ) @@ -175,7 +173,7 @@ modifyingCurrentDocument uiElts@( UIElements { menuActions } ) vars@( Variables -- Content change. STM.modifyTVar' openDocumentsTVar ( Map.adjust - ( newFutureStep maxHistSize + ( newFutureStep maxHistSize histDiff . set ( field' @"documentContent" . field' @"unsavedChanges" ) True $ newDocument ) @@ -216,11 +214,12 @@ updateUIAction _docChange uiElts@( UIElements { viewport = Viewport {..}, .. } ) mbActiveTabDoc <- fmap join $ for mbDoc \ ( docUnique, _doc ) -> do mbActiveTab <- Map.lookup docUnique <$> STM.readTVar fileBarTabsTVar pure ( (,) <$> mbActiveTab <*> mbDoc ) - --strokeModels <- STM.readTVar strokeListModelsTVar pure do updateTitle window titleLabel mbTitleText updateInfoBar viewportDrawingArea infoBar vars ( fmap ( documentMetadata . snd ) mbDoc ) - --switchStrokeView (strokesListView $ panelsBar) strokeModels (fst <$> mbDoc) + _ <- GLib.idleAdd GLib.PRIORITY_DEFAULT_IDLE $ do + switchStrokeView strokesListView vars ( fst <$> mbDoc ) + return False for_ mbActiveTabDoc \ ( FileBarTab { fileBarTab, fileBarTabButton, fileBarTabCloseArea }, ( _, activeDoc ) ) -> do GTK.buttonSetLabel fileBarTabButton ( documentName $ documentMetadata activeDoc ) GTK.widgetQueueDraw fileBarTab diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index 9ecdc68..3651829 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -251,17 +251,15 @@ getDocumentRender getVisibleStrokes :: Document -> [ ( Maybe Unique, Stroke ) ] getVisibleStrokes ( Document { documentMetadata, documentContent } ) = - let res = - Writer.execWriter $ - forStrokeHierarchy - ( layerMetadata documentMetadata ) - ( strokeHierarchy documentContent ) - ( \ uniq stroke ( StrokeMetadata { strokeVisible } ) -> do - when strokeVisible $ - Writer.tell [ ( Just uniq, stroke ) ] - return PreserveStroke - ) - in if null res then error ( show $ strokeHierarchy documentContent ) else res + Writer.execWriter $ + forStrokeHierarchy + ( layerMetadata documentMetadata ) + ( strokeHierarchy documentContent ) + ( \ uniq stroke ( StrokeMetadata { strokeVisible } ) -> do + when strokeVisible $ + Writer.tell [ ( Just uniq, stroke ) ] + return PreserveStroke + ) -- | Utility type to gather information needed to render a stroke. -- - No outline: just the underlying spline. diff --git a/src/app/MetaBrush/UI/FileBar.hs b/src/app/MetaBrush/UI/FileBar.hs index 5a96a49..dbffe68 100644 --- a/src/app/MetaBrush/UI/FileBar.hs +++ b/src/app/MetaBrush/UI/FileBar.hs @@ -44,20 +44,17 @@ import Data.HashMap.Lazy -- MetaBrush import {-# SOURCE #-} MetaBrush.Application.Action - ( ActionName, SwitchFromTo(..), Close(..), handleAction ) + ( SwitchFromTo(..), Close(..), handleAction ) +import MetaBrush.Application.Context import MetaBrush.Asset.CloseTabButton ( drawCloseTabButton ) import MetaBrush.Asset.Colours ( Colours ) -import MetaBrush.Application.Context - ( UIElements(..), Variables(..) ) import MetaBrush.Document import MetaBrush.Document.History ( DocumentHistory(..), newHistory ) import MetaBrush.Application.UpdateDocument ( updateUIAction, ActiveDocChange (..) ) -import {-# SOURCE #-} MetaBrush.UI.InfoBar - ( InfoBar ) import MetaBrush.UI.Panels ( PanelsBar ) import MetaBrush.UI.Viewport @@ -69,25 +66,6 @@ import MetaBrush.GTK.Util -------------------------------------------------------------------------------- -data FileBar - = FileBar - { fileBarBox :: !GTK.Box - , fileTabsBox :: !GTK.Box - , fileBarPhantomToggleButton :: !GTK.ToggleButton - } - -data FileBarTab - = FileBarTab - { fileBarTab :: !GTK.Box - , fileBarTabButton :: !GTK.ToggleButton - , fileBarTabCloseArea :: !GTK.DrawingArea - } - -data TabLocation - = AfterCurrentTab - | LastTab - deriving stock Show - newFileTab :: UIElements -> Variables @@ -158,8 +136,8 @@ newFileTab } -- Update the state: switch to this new document. uiUpdateAction <- STM.atomically do - STM.modifyTVar' openDocumentsTVar ( Map.insert thisTabDocUnique thisTabDocHist ) - STM.modifyTVar' fileBarTabsTVar ( Map.insert thisTabDocUnique fileBarTab ) + STM.modifyTVar' openDocumentsTVar ( Map.insert thisTabDocUnique thisTabDocHist ) + STM.modifyTVar' fileBarTabsTVar ( Map.insert thisTabDocUnique fileBarTab ) mbOldDoc <- STM.readTVar activeDocumentTVar STM.writeTVar activeDocumentTVar ( Just thisTabDocUnique ) let change = ActiveDocChange { mbOldDocUnique = mbOldDoc } @@ -212,11 +190,13 @@ createFileBar -> GTK.HeaderBar -> GTK.Label -> Viewport -> InfoBar -> GTK.PopoverMenuBar -> HashMap ActionName GIO.SimpleAction -> PanelsBar + -> GTK.ListView -> IO FileBar createFileBar colours vars@( Variables { openDocumentsTVar } ) - application window windowKeys titleBar titleLabel viewport infoBar menuBar menuActions panelsBar + application window windowKeys titleBar titleLabel viewport infoBar menuBar menuActions + panelsBar strokesListView = do -- Create file bar: box containing scrollable tabs, and a "+" button after it. diff --git a/src/app/MetaBrush/UI/FileBar.hs-boot b/src/app/MetaBrush/UI/FileBar.hs-boot index 9d7fb7c..f5a2815 100644 --- a/src/app/MetaBrush/UI/FileBar.hs-boot +++ b/src/app/MetaBrush/UI/FileBar.hs-boot @@ -4,12 +4,8 @@ module MetaBrush.UI.FileBar ) where --- gi-gtk -import qualified GI.Gtk as GTK - -- MetaBrush -import {-# SOURCE #-} MetaBrush.Application.Context - ( Variables, UIElements ) +import MetaBrush.Application.Context import MetaBrush.Document.History ( DocumentHistory ) import MetaBrush.Unique @@ -17,25 +13,5 @@ import MetaBrush.Unique -------------------------------------------------------------------------------- -data FileBar - = FileBar - { fileBarBox :: !GTK.Box - , fileTabsBox :: !GTK.Box - , fileBarPhantomToggleButton :: !GTK.ToggleButton - } - -data FileBarTab - = FileBarTab - { fileBarTab :: !GTK.Box - , fileBarTabButton :: !GTK.ToggleButton - , fileBarTabCloseArea :: !GTK.DrawingArea - } - -data TabLocation - = AfterCurrentTab - | LastTab - -instance Show TabLocation - newFileTab :: UIElements -> Variables -> Maybe ( Unique, DocumentHistory ) -> TabLocation -> IO () removeFileTab :: UIElements -> Variables -> Unique -> IO () diff --git a/src/app/MetaBrush/UI/InfoBar.hs b/src/app/MetaBrush/UI/InfoBar.hs index cf99059..b5afb9d 100644 --- a/src/app/MetaBrush/UI/InfoBar.hs +++ b/src/app/MetaBrush/UI/InfoBar.hs @@ -34,17 +34,18 @@ import qualified Control.Concurrent.STM.TVar as STM import qualified Data.Text as Text ( pack ) --- MetaBrush +-- brush-strokes import Math.Linear ( ℝ(..) ) + +-- MetaBrush +import MetaBrush.Application.Context import MetaBrush.Asset.Colours ( Colours ) import MetaBrush.Asset.Cursor ( drawCursorIcon ) import MetaBrush.Asset.InfoBar ( drawMagnifier, drawTopLeftCornerRect ) -import MetaBrush.Application.Context - ( Variables(..) ) import MetaBrush.Document ( DocumentMetadata(..), Zoom(..) ) import MetaBrush.UI.Coordinates @@ -54,13 +55,6 @@ import MetaBrush.GTK.Util -------------------------------------------------------------------------------- -data InfoBar - = InfoBar - { infoBarArea :: !GTK.Box - , zoomText :: !GTK.Label -- make this editable - , cursorPosText, topLeftPosText, botRightPosText :: !GTK.Label - } - -- | Add the UI elements for the info bar: -- -- * current zoom level, diff --git a/src/app/MetaBrush/UI/InfoBar.hs-boot b/src/app/MetaBrush/UI/InfoBar.hs-boot deleted file mode 100644 index 6e5e194..0000000 --- a/src/app/MetaBrush/UI/InfoBar.hs-boot +++ /dev/null @@ -1,24 +0,0 @@ -module MetaBrush.UI.InfoBar - ( InfoBar(..), updateInfoBar ) - where - --- gi-gtk -import qualified GI.Gtk as GTK - --- MetaBrush -import {-# SOURCE #-} MetaBrush.Application.Context - ( Variables ) -import MetaBrush.Document - ( DocumentMetadata ) - --------------------------------------------------------------------------------- - -data InfoBar - = InfoBar - { infoBarArea :: !GTK.Box - , zoomText :: !GTK.Label - , cursorPosText, topLeftPosText, botRightPosText :: !GTK.Label - } - -updateInfoBar - :: GTK.DrawingArea -> InfoBar -> Variables -> Maybe DocumentMetadata -> IO () diff --git a/src/app/MetaBrush/UI/Menu.hs b/src/app/MetaBrush/UI/Menu.hs index be10c83..48f315c 100644 --- a/src/app/MetaBrush/UI/Menu.hs +++ b/src/app/MetaBrush/UI/Menu.hs @@ -42,13 +42,10 @@ import qualified Data.HashSet as HashSet import MetaBrush.Application.Action hiding ( save, saveAs ) import MetaBrush.Application.Context - ( UIElements(..), Variables(..) ) import MetaBrush.Asset.Colours ( Colours ) import MetaBrush.Asset.WindowIcons ( drawMinimise, drawRestoreDown, drawMaximise, drawClose ) -import MetaBrush.UI.FileBar - ( TabLocation(..) ) import MetaBrush.GTK.Util ( widgetAddClass, widgetAddClasses ) diff --git a/src/app/MetaBrush/UI/Panels.hs b/src/app/MetaBrush/UI/Panels.hs index 37f53d8..ce7b716 100644 --- a/src/app/MetaBrush/UI/Panels.hs +++ b/src/app/MetaBrush/UI/Panels.hs @@ -25,10 +25,10 @@ import MetaBrush.GTK.Util data PanelsBar = PanelsBar - { strokesPanelBox, brushesPanelBox, transformPanelBox, historyPanelBox - :: GTK.Box - , strokesListView - :: GTK.ListView + { layersScrolledWindow + :: !GTK.ScrolledWindow + , brushesPanelBox, transformPanelBox, historyPanelBox + :: !GTK.Box } -- | Creates the right hand side panel UI. @@ -38,6 +38,7 @@ createPanelBar panelBox = do widgetAddClass panelBox "panels" pane1 <- GTK.panedNew GTK.OrientationVertical + GTK.panedSetWideHandle pane1 True GTK.widgetSetVexpand pane1 True GTK.boxAppend panelBox pane1 @@ -50,7 +51,9 @@ createPanelBar panelBox = do GTK.panedSetStartChild pane1 ( Just panels1 ) GTK.panedSetEndChild pane1 ( Just panels2 ) - strokesPanelBox <- GTK.boxNew GTK.OrientationVertical 0 + layersScrolledWindow <- GTK.scrolledWindowNew + GTK.scrolledWindowSetPolicy layersScrolledWindow GTK.PolicyTypeNever GTK.PolicyTypeAutomatic + brushesPanelBox <- GTK.boxNew GTK.OrientationVertical 0 transformPanelBox <- GTK.boxNew GTK.OrientationVertical 0 historyPanelBox <- GTK.boxNew GTK.OrientationVertical 0 @@ -63,17 +66,18 @@ createPanelBar panelBox = do for_ [ strokesTab, brushesTab, transformTab, historyTab ] \ tab -> do widgetAddClasses tab [ "plain", "text", "panelTab" ] - for_ [ strokesPanelBox, brushesPanelBox, transformPanelBox, historyPanelBox ] \ panel -> do + widgetAddClass layersScrolledWindow "panel" + for_ [ brushesPanelBox, transformPanelBox, historyPanelBox ] \ panel -> do widgetAddClass panel "panel" - void $ GTK.notebookAppendPage panels1 strokesPanelBox ( Just strokesTab ) - void $ GTK.notebookAppendPage panels1 brushesPanelBox ( Just brushesTab ) + void $ GTK.notebookAppendPage panels1 layersScrolledWindow ( Just strokesTab ) + void $ GTK.notebookAppendPage panels1 brushesPanelBox ( Just brushesTab ) void $ GTK.notebookAppendPage panels2 transformPanelBox ( Just transformTab ) void $ GTK.notebookAppendPage panels2 historyPanelBox ( Just historyTab ) - GTK.notebookSetTabReorderable panels1 strokesPanelBox True - GTK.notebookSetTabDetachable panels1 strokesPanelBox True + GTK.notebookSetTabReorderable panels1 layersScrolledWindow True + GTK.notebookSetTabDetachable panels1 layersScrolledWindow True GTK.notebookSetTabReorderable panels1 brushesPanelBox True GTK.notebookSetTabDetachable panels1 brushesPanelBox True @@ -90,8 +94,7 @@ createPanelBar panelBox = do GTK.boxAppend transformPanelBox transformContent GTK.boxAppend historyPanelBox historyContent - --GTK.boxAppend strokesPanelBox strokesListView - return $ - PanelsBar { strokesPanelBox, strokesListView = error "todo" - , brushesPanelBox, transformPanelBox, historyPanelBox } + PanelsBar { layersScrolledWindow + , brushesPanelBox, transformPanelBox, historyPanelBox + } diff --git a/src/app/MetaBrush/UI/StrokeTreeView.hs b/src/app/MetaBrush/UI/StrokeTreeView.hs index e69de29..c98463c 100644 --- a/src/app/MetaBrush/UI/StrokeTreeView.hs +++ b/src/app/MetaBrush/UI/StrokeTreeView.hs @@ -0,0 +1,1235 @@ +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} + +module MetaBrush.UI.StrokeTreeView where + +-- base +import Control.Monad + ( unless, void, when ) +import Data.Foldable + ( for_ ) +import Data.List + ( elemIndex ) +import Data.Maybe + ( fromJust, isJust, isNothing ) +import Data.Traversable + ( for ) +import Data.Word + ( Word32 ) +import GHC.Stack + ( HasCallStack ) + +-- containers +import Data.Map.Strict + ( Map ) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.Sequence as Seq + +-- generic-lens +import Data.Generics.Product.Fields + ( field' ) + +-- 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 + +-- 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 + +-- lens +import Control.Lens + ( over ) + +-- stm +import qualified Control.Concurrent.STM.TVar as STM +import qualified Control.Concurrent.STM.TMVar as STM +import qualified Control.Monad.STM as STM + +-- text +import Data.Text + ( Text ) + +-- MetaBrush +import MetaBrush.Application.Context +import MetaBrush.Application.UpdateDocument +import MetaBrush.Document +import MetaBrush.Document.Diff +import MetaBrush.Document.History +import MetaBrush.Layer +import MetaBrush.Stroke hiding ( Layer(..) ) +import MetaBrush.UI.Panels ( PanelsBar(..) ) +import MetaBrush.Unique +import MetaBrush.Util + ( (!) ) + +-------------------------------------------------------------------------------- + +-- | 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 ] + + +instance GI.DerivedGObject LayerItem where + type GObjectParentType LayerItem = GObject.Object + type GObjectPrivateData LayerItem = Maybe Layer + objectTypeName = "MetaBrush-LayerItem" + objectClassInit _ = return () + objectInstanceInit _ _ = return Nothing + objectInterfaces = [ ] + +-------------------------------------------------------------------------------- +-- GTK TreeListModel -- +----------------------- + +-- | Switch to a different stroke view, creating it on the fly if it +-- doesn't exist already. +switchStrokeView :: GTK.ListView -> Variables -> Maybe Unique -> IO () +switchStrokeView layersListView vars@( Variables { .. } ) mbDocUnique = do + mbDocListModel <- for mbDocUnique $ \ docUnique -> do + models <- STM.readTVarIO strokeListModelsTVar + case Map.lookup docUnique models of + Just lm -> return lm + Nothing -> do + lm <- newLayersListModel vars docUnique + STM.atomically $ + STM.modifyTVar' strokeListModelsTVar ( Map.insert docUnique lm ) + return lm + GTK.listViewSetModel layersListView mbDocListModel + +-- | Create a new 'GTK.TreeListModel' with 'GTK.SingleSelection' +-- from the document with the given 'Unique'. +newLayersListModel :: Variables -> Unique -> IO GTK.SingleSelection +newLayersListModel ( Variables { .. } ) docUnique = do + + itemType <- GI.glibType @LayerItem + + store0 <- GIO.listStoreNew itemType + ( store, mbDocHist ) <- STM.atomically do + mbDocHist <- Map.lookup docUnique <$> STM.readTVar openDocumentsTVar + mbDocStore <- Map.lookup docUnique <$> STM.readTVar parStoresTVar + store <- case mbDocStore of + Nothing -> do + STM.modifyTVar' parStoresTVar ( Map.insert docUnique ( Map.singleton Root store0 ) ) + return store0 + Just store -> + return ( store ! Root ) + return ( store, mbDocHist ) + + for_ mbDocHist $ \ activeDocHist -> do + + let layerHierarchy = strokeHierarchy $ documentContent $ present activeDocHist + for_ ( topLevel layerHierarchy ) $ \ layerUniq -> do + let mbChildren = lookupChildren_maybe ( Parent layerUniq ) layerHierarchy + layer = case mbChildren of + Nothing -> StrokeLayer { layerUnique = layerUniq } + Just {} -> GroupLayer { 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 + + selectionModel <- GI.withManagedPtr model $ \ lmPtr -> + GI.withNewObject lmPtr $ \ lmCopy -> + GTK.singleSelectionNew ( Just lmCopy ) + + return selectionModel + + where + createChildModel :: GObject.Object -> IO ( Maybe GIO.ListModel ) + createChildModel parent = do + dat <- getLayerData =<< GTK.unsafeCastTo LayerItem parent + case dat of + StrokeLayer {} -> return Nothing + GroupLayer { layerUnique = groupUnique } -> do + mbDocHist <- Map.lookup docUnique <$> STM.atomically ( STM.readTVar openDocumentsTVar ) + case mbDocHist of + Nothing -> return Nothing + Just docHist -> do + let layerHierarchy = strokeHierarchy $ documentContent $ present docHist + children = lookupChildren ( Parent groupUnique ) layerHierarchy + + -- Try to re-use an existing list store, if there is one. + mbOldChildStore <- + STM.atomically $ do + mbOldStore <- + Map.lookup ( Parent groupUnique ) . ( ! docUnique ) <$> STM.readTVar parStoresTVar + 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 = lookupChildren_maybe ( Parent childUniq ) layerHierarchy + childLayer = case mbChildChildren of + Nothing -> StrokeLayer{ layerUnique = childUniq } + Just {} -> GroupLayer { 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 parStoresTVar + ( Map.insertWith Map.union docUnique ( Map.singleton ( Parent groupUnique ) childStore ) ) + STM.putTMVar listModelUpToDateTMVar () + + return childStore + + -- Pass a copy of the (reference to the) child store + -- 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 Layer +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 { panelsBar = PanelsBar { layersScrolledWindow } } ) vars = 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 + modifyingCurrentDocument uiElts vars \ doc -> do + let doc' = + over ( field' @"documentMetadata" . field' @"layerMetadata" + . field' @"invisibleLayers" + ) + ( if visible then Set.delete uniq else Set.insert uniq ) + doc + return $ + UpdateDoc $ UpdateDocumentTo doc' TrivialDiff + + ------------------- + -- 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 + layer <- getLayerData listItem + modifyingCurrentDocument uiElts vars \ doc -> do + let doc' = + over ( field' @"documentMetadata" . field' @"layerMetadata" + . field' @"layerNames" + ) + ( Map.insert ( layerUnique layer ) newText ) + doc + return $ + UpdateDoc $ UpdateDocumentTo doc' TrivialDiff + + ---------------- + -- 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 + + mbSelModel <- GTK.listViewGetModel listView + for_ mbSelModel \ selModel0 -> do + selModel <- GTK.unsafeCastTo GTK.SingleSelection selModel0 + rowPos <- GTK.treeListRowGetPosition treeListRow + GTK.singleSelectionSetSelected selModel rowPos + + let dnd_sourceItem = + WithinParent + { parent = fmap snd srcPar + , item = srcUniq + } + + val <- GDK.contentProviderNewForValue =<< GIO.toGValue ( GI.HValue dnd_sourceItem ) + GTK.widgetAddCssClass layersScrolledWindow "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 layersScrolledWindow "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 layersScrolledWindow "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 ChildLayer ) val + + mbTreeListRow <- traverse ( GTK.unsafeCastTo GTK.TreeListRow ) =<< GTK.listItemGetItem listItem + treeListRow <- case mbTreeListRow of + Nothing -> error "newLayerView ListItem onSetup: no TreeListRow" + Just r -> return r + + dstFlatIndex <- GTK.treeListRowGetPosition treeListRow + h <- GTK.widgetGetHeight expander + let droppedAbove = y < 0.5 * fromIntegral h + expanded <- GTK.treeListRowGetExpanded treeListRow + + dstPar <- getParent treeListRow + isDescendant <- isDescendantOf dragSrcUniq listItem + + let mbDropIntoGroup + | 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. + mbSelModel <- GTK.listViewGetModel listView + case mbSelModel of + Nothing -> return False + Just selModel0 -> do + selModel <- GTK.unsafeCastTo GTK.SingleSelection selModel0 + layersListModel + <- GTK.unsafeCastTo GTK.TreeListModel =<< fmap fromJust ( GTK.singleSelectionGetModel selModel ) + + mbSelItem <- GTK.singleSelectionGetSelectedItem selModel + mbSelIx <- for mbSelItem $ \ selItem -> do + selRow <- GTK.unsafeCastTo GTK.TreeListRow selItem + GTK.treeListRowGetPosition selRow + + -- Now compute the final destination position. + mbDstPosAfterShift <- + case mbSelIx of + Nothing -> + return Nothing + Just selIx + -- If we moved up, simply use the destination position. + | selIx >= newPosInTree + -> return $ Just newPosInTree + | otherwise + -> do + -- If we moved down, we need to substract the number of items + -- moved. Note that this depends on which TreeExpander nodes + -- are expanded. + mbSelRow <- GTK.treeListModelGetRow layersListModel selIx + case mbSelRow of + Nothing -> return Nothing + Just selRow0 -> do + selRow <- GTK.unsafeCastTo GTK.TreeListRow selRow0 + nbDescendants <- getNbExpandedDescendants layersListModel selRow + return $ + if newPosInTree < nbDescendants + then Nothing + else Just $ newPosInTree - nbDescendants + + updateLayerHierarchy vars $ + DoLayerChange $ + Move + { moveSrc = dragSrc + , moveDst = dropDst + } + + -- After moving, update the selected item to be the moved item. + case mbDstPosAfterShift of + Nothing -> return () + Just dstPos -> + GTK.singleSelectionSetSelected selModel dstPos + return True + + void $ GTK.onDropTargetEnter dropTarget $ \ _x y -> do + GTK.widgetAddCssClass expander "drag-over" + 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 + + layer <- getLayerData listItem + mbActiveDoc <- STM.atomically $ activeDocument vars + for_ mbActiveDoc $ \ ( _activeDocUnique, activeDocHist ) -> do + let meta = layerMetadata $ documentMetadata $ present activeDocHist + + -- All we do is set the name and visibility of this layer/group. + + let layerText = layerNames meta ! layerUnique layer + layerVisible = not $ Set.member ( layerUnique layer ) ( invisibleLayers meta ) + + 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 ) + + GTK.widgetSetVisible checkButton True + GTK.checkButtonSetActive checkButton layerVisible + GTK.editableSetText layerLabel layerText + + listView <- GTK.listViewNew ( Nothing @GTK.SingleSelection ) ( 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 ChildLayer ) +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 + } + +-------------------------------------------------------------------------------- + +-- | Do or undo? +data Do = Do | Undo + deriving stock ( Eq, Show ) + +-- | Do, undo or redo? +data DoLayerChange = DoLayerChange !LayerChange | RedoChange | UndoChange + +-- | Description of a change to the layer hierarchy. +data LayerChange + = Move + { moveSrc :: !ChildLayer + , moveDst :: !MoveDst + } + | NewItem + { newUnique :: !Unique + , newIsGroup :: !Bool + , newSelected :: !( Maybe ChildLayer ) + } + | Delete + { deleteItem :: !ChildLayer + } + +-- | 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 :: !ChildLayer + , moveAbove :: !Bool + -- ^ Whether to move above or below the destination. + } + +-------------------------------------------------------------------------------- + +-- | Update the layer hierarchy, keeping both the application state and +-- the GTK ListModel in sync. +updateLayerHierarchy :: Variables -> DoLayerChange -> IO () +updateLayerHierarchy + vars@( Variables { parStoresTVar, listModelUpToDateTMVar } ) + doOrUndo = do + mbDiff <- STM.atomically $ do + + -- Ensure the GTK ListModel is up to date before continuing + -- (just a precaution). + STM.takeTMVar listModelUpToDateTMVar + + -- TODO: need to use 'modifyingCurrentDocument' in some form, + -- but that function doesn't permit modifying history. + + mbActiveDoc <- activeDocument vars + ( mbNewHist, mbDiff ) <- + case mbActiveDoc of + Nothing -> return ( Nothing, Nothing) + Just ( activeDocUnique, History past ( Document oldPresent oldMeta ) future ) -> do + let oldHierarchy = strokeHierarchy oldPresent + case doOrUndo of + DoLayerChange change -> do + let !( !hierarchy', !newNames, mbDiff ) = applyChangeToLayerHierarchy change oldHierarchy + !content' = oldPresent { strokeHierarchy = hierarchy' } + !meta' = over ( field' @"layerMetadata" . field' @"layerNames" ) ( newNames <> ) oldMeta + !( !history', mbDoOrUndo ) = + case mbDiff of + Nothing -> + ( History + { past = past + , present = Document content' meta' + , future = future + } + , Nothing ) + Just diff -> + ( History + { past = past Seq.:|> ( oldPresent, HierarchyDiff diff ) + , present = Document content' meta' + , future = [] + } + , Just ( Do, diff ) ) + return ( Just ( activeDocUnique, history' ), mbDoOrUndo ) + UndoChange -> case past of + past' Seq.:|> ( present', diff ) -> do + let !history' = + History + { past = past' + , present = Document present' oldMeta + , future = ( diff, oldPresent ) : future + } + return + ( Just ( activeDocUnique, history' ) + , case diff of + HierarchyDiff hDiff -> + Just ( Undo, hDiff ) + _ -> Nothing + ) + Seq.Empty -> + return ( Nothing, Nothing ) + RedoChange -> case future of + ( diff, present' ) : future' -> do + let history' = + History + { past = past Seq.:|> ( oldPresent, diff ) + , present = Document present' oldMeta + , future = future' + } + return + ( Just ( activeDocUnique, history' ) + , case diff of + HierarchyDiff hDiff -> + Just ( Do, hDiff ) + _ -> Nothing + ) + [] -> + return ( Nothing, Nothing ) + + for_ mbNewHist $ \ ( activeDoc, hist ) -> + STM.modifyTVar' ( openDocumentsTVar vars ) ( Map.insert activeDoc hist ) + return $ ( , ) <$> ( fst <$> mbNewHist ) <*> mbDiff + + for_ mbDiff $ \ ( docUnique, diff ) -> + applyDiffToListModel parStoresTVar docUnique diff + + STM.atomically $ + STM.writeTMVar listModelUpToDateTMVar () + + +-- | Apply a change to the application layer hierarchy. +-- +-- The change to the GTK ListModel is done in 'applyDiffToListModel'. +applyChangeToLayerHierarchy :: LayerChange -> StrokeHierarchy -> ( StrokeHierarchy, Map Unique Text, Maybe HierarchyDiff ) +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 <- lookupChildren_maybe ( Parent parentUnique ) hierarchy + , 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 <- lookupChildren_maybe ( Parent itemUnique ) hierarchy + , 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 $ + MoveLayer + { moveUnique = srcUniq + , srcPos = WithinParent srcParUniq srcChildIx + , dstPos = 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'' = + if newIsGroup + then insertGroup ( Parent u ) [] hierarchy' + else hierarchy' + in + ( hierarchy'' + , Map.singleton u ( if newIsGroup then "Group" else "Layer" ) + , Just $ + NewLayer + { newPosition = WithinParent dstParUniq dstChildIx + , newUnique = u + , newIsGroup + } + ) + Delete { deleteItem = WithinParent parUniq delUniq } -> + let !( !hierarchy', childIx ) = removeLayerFromParent hierarchy ( parUniq, delUniq ) + !( !hierarchy'', mbHadChildren ) = + deleteLayerKey delUniq hierarchy' + in + ( hierarchy'' + , Map.empty + , Just $ + DeleteLayer + { delPosition = WithinParent parUniq childIx + , delUnique = delUniq + , delIsGroup = isJust mbHadChildren + } + ) + +-- | Apply a change to the 'ListModel' underlying the UI +-- representation of the layer hierarchy. +-- +-- The change to the application 'StrokeHierarchy' is done beforehand, +-- in 'applyChangeToLayerHierarchy'. +applyDiffToListModel :: STM.TVar ( Map Unique ( Map ( Parent Unique ) GIO.ListStore ) ) + -> Unique + -> ( Do, HierarchyDiff ) + -> IO () +applyDiffToListModel parStoreTVar docUnique ( 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 <- ( ! docUnique ) <$> STM.readTVarIO parStoreTVar + case diff of + MoveLayer { srcPos = WithinParent srcPar srcIx + , dstPos = WithinParent dstPar dstIx } -> do + let srcStore = parStoreFromUniq ! srcPar + dstStore = parStoreFromUniq ! dstPar + case doOrUndo of + Do -> do + item <- fromJust <$> GIO.listModelGetItem srcStore srcIx + GIO.listStoreRemove srcStore srcIx + GIO.listStoreInsert dstStore dstIx item + Undo -> do + item <- fromJust <$> GIO.listModelGetItem dstStore dstIx + GIO.listStoreRemove dstStore dstIx + GIO.listStoreInsert srcStore srcIx item + NewLayer { newPosition = WithinParent dstPar dstIx, newUnique, newIsGroup } -> do + let dstStore = parStoreFromUniq ! dstPar + case doOrUndo of + Do -> do + item <- GI.new LayerItem [] + GI.gobjectSetPrivateData item ( Just $ if newIsGroup then GroupLayer newUnique else StrokeLayer newUnique ) + GIO.listStoreInsert dstStore dstIx item + Undo -> + GIO.listStoreRemove dstStore dstIx + DeleteLayer { delPosition = WithinParent srcPar srcIx, delUnique, delIsGroup } -> do + let srcStore = parStoreFromUniq ! srcPar + case doOrUndo of + Do -> GIO.listStoreRemove srcStore srcIx + Undo -> do + item <- GI.new LayerItem [] + GI.gobjectSetPrivateData item ( Just $ if delIsGroup then GroupLayer delUnique else StrokeLayer delUnique ) + GIO.listStoreInsert srcStore srcIx item + DeletePoints {} -> + error "TODO" + +-- | Update the 'StrokeHierarchy' 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 'StrokeHierarchy', 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 + -> StrokeHierarchy + -- ^ hierarchy to update + -> ( StrokeHierarchy, 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 'StrokeHierarchy', +-- returning the updated 'StrokeHierarchy' together with the index the item +-- was found within its parent. +-- +-- NB: does not delete the layer itself. +removeLayerFromParent :: StrokeHierarchy + -> ( Parent Unique, Unique ) + -> ( StrokeHierarchy, Word32 ) +removeLayerFromParent hierarchy ( parent, u ) = + let oldPar_cs = lookupChildren parent hierarchy + newChildren = filter ( /= u ) oldPar_cs + oldChildPos = fromIntegral $ fromJust $ elemIndex u oldPar_cs + in ( insertGroup parent newChildren hierarchy, oldChildPos ) + +-- | Add a layer to a parent in the 'StrokeHierarchy', returning the updated +-- 'StrokeHierarchy' together with the index the item was placed within its parent. +-- +-- NB: does not add the layer itself. +insertLayerIntoParent :: StrokeHierarchy + -> ( Parent Unique, Maybe ( Unique, Bool ) ) + -- ^ destination + -- + -- - @Nothing@: drop as first element of group + -- - @Just (u, above)@ drop above/below u + -> Unique + -> ( StrokeHierarchy, Word32 ) +insertLayerIntoParent hierarchy ( newPar, mbTgtUniq ) srcUniq = + let + newPar_oldCs = lookupChildren newPar hierarchy + ( newPar_newCs, newChildPos ) = + case mbTgtUniq of + -- Drop as first child of group. + Nothing -> + ( srcUniq : filter ( /= srcUniq ) newPar_oldCs + , 0 + ) + -- Drop (before or after) given child. + Just ( tgtUniq, dropAbove ) -> + let ( bef, aft ) = break ( == tgtUniq ) $ filter ( /= srcUniq ) newPar_oldCs + in ( if dropAbove + then bef ++ [ srcUniq ] ++ aft + else bef ++ take 1 aft ++ [ srcUniq ] ++ drop 1 aft + , fromIntegral ( length ( takeWhile ( /= tgtUniq ) $ newPar_oldCs ) ) + + if dropAbove then 0 else 1 + ) + in ( insertGroup newPar newPar_newCs hierarchy, newChildPos ) diff --git a/src/app/MetaBrush/UI/StrokeTreeView.hs-boot b/src/app/MetaBrush/UI/StrokeTreeView.hs-boot new file mode 100644 index 0000000..16c2f22 --- /dev/null +++ b/src/app/MetaBrush/UI/StrokeTreeView.hs-boot @@ -0,0 +1,16 @@ +module MetaBrush.UI.StrokeTreeView where + +-- gi-gtk +import qualified GI.Gtk as GTK + +-- MetaBrush +import MetaBrush.Application.Context +import MetaBrush.Unique + +-------------------------------------------------------------------------------- + +newLayersListModel :: Variables -> Unique -> IO GTK.SingleSelection + +switchStrokeView :: GTK.ListView -> Variables -> Maybe Unique -> IO () + +newLayerView :: UIElements -> Variables -> IO GTK.ListView diff --git a/src/app/MetaBrush/UI/ToolBar.hs b/src/app/MetaBrush/UI/ToolBar.hs index 92ebddf..1ea6a66 100644 --- a/src/app/MetaBrush/UI/ToolBar.hs +++ b/src/app/MetaBrush/UI/ToolBar.hs @@ -28,36 +28,18 @@ import qualified Control.Concurrent.STM.TVar as STM ( writeTVar ) -- MetaBrush +import MetaBrush.Application.Context import MetaBrush.Asset.Colours ( Colours ) import MetaBrush.Asset.Cursor ( drawCursorIcon ) import MetaBrush.Asset.Tools ( drawBug, drawBrush, drawMeta, drawPath, drawPen ) -import MetaBrush.Application.Context - ( Variables(..) ) import MetaBrush.GTK.Util ( widgetAddClass ) -------------------------------------------------------------------------------- -data Tool - = Selection - | Pen - deriving stock ( Show, Eq ) - -data Mode - = PathMode - | BrushMode - | MetaMode - deriving stock ( Show, Eq ) - -data ToolBar - = ToolBar - { selectionTool, penTool, pathTool, brushTool, metaTool, debugTool - :: !GTK.ToggleButton - } - createToolBar :: Variables -> Colours -> GTK.Box -> IO ToolBar createToolBar ( Variables {..} ) colours toolBar = do diff --git a/src/app/MetaBrush/UI/ToolBar.hs-boot b/src/app/MetaBrush/UI/ToolBar.hs-boot deleted file mode 100644 index 559c966..0000000 --- a/src/app/MetaBrush/UI/ToolBar.hs-boot +++ /dev/null @@ -1,29 +0,0 @@ -module MetaBrush.UI.ToolBar - ( Tool(..), Mode(..) - , ToolBar(..) - ) - where - --- gi-gtk -import qualified GI.Gtk as GTK - --------------------------------------------------------------------------------- - -data Tool - = Selection - | Pen - -instance Show Tool - -data Mode - = PathMode - | BrushMode - | MetaMode - -instance Show Mode - -data ToolBar - = ToolBar - { selectionTool, penTool, pathTool, brushTool, metaTool, debugTool - :: !GTK.ToggleButton - } diff --git a/src/metabrushes/MetaBrush/Document/Diff.hs b/src/metabrushes/MetaBrush/Document/Diff.hs index 354389b..34704ed 100644 --- a/src/metabrushes/MetaBrush/Document/Diff.hs +++ b/src/metabrushes/MetaBrush/Document/Diff.hs @@ -56,12 +56,18 @@ data DocumentDiff data HierarchyDiff = NewLayer { newUnique :: !Unique + , newIsGroup :: !Bool , newPosition :: !ChildLayerPosition } | DeleteLayer { delUnique :: !Unique + , delIsGroup :: !Bool , delPosition :: !ChildLayerPosition } + | DeletePoints + { deletedPoints :: !StrokePoints + , deletedStrokes :: !( Set Unique ) + } | MoveLayer { moveUnique :: !Unique , srcPos :: !ChildLayerPosition @@ -113,10 +119,6 @@ data ContentDiff { continuedStroke :: !Unique , newSegment :: !( Spline Open () () ) } - | DeletePoints - { deletedPoints :: !StrokePoints - , deletedStrokes :: !( Set Unique) - } | UpdateBrushParameters { updateBrushStroke :: !Unique , updateBrushPoint :: !PointIndex diff --git a/src/metabrushes/MetaBrush/Document/History.hs b/src/metabrushes/MetaBrush/Document/History.hs index 078e5f4..380879a 100644 --- a/src/metabrushes/MetaBrush/Document/History.hs +++ b/src/metabrushes/MetaBrush/Document/History.hs @@ -2,7 +2,7 @@ module MetaBrush.Document.History ( DocumentHistory(..) , back, fwd, newHistory, newFutureStep , atStart, atEnd - , affirmPresent + , affirmPresentSaved ) where @@ -27,18 +27,22 @@ import Data.Generics.Product.Fields -- lens import Control.Lens ( set ) +import Control.Lens.Tuple + ( _1, _2 ) -- MetaBrush import MetaBrush.Document ( Document(..), DocumentContent(..) ) +import MetaBrush.Document.Diff + ( HistoryDiff ) -------------------------------------------------------------------------------- data DocumentHistory = History - { past :: !( Seq DocumentContent ) + { past :: !( Seq ( DocumentContent, HistoryDiff ) ) , present :: !Document - , future :: ![ DocumentContent ] + , future :: ![ ( HistoryDiff, DocumentContent ) ] } deriving stock ( Show, Generic ) instance NFData DocumentHistory where @@ -47,21 +51,29 @@ instance NFData DocumentHistory where back :: DocumentHistory -> DocumentHistory back hist@( History { past = ps, present = c, future = fs } ) = case ps of - Empty -> hist - qs :|> q -> History { past = qs, present = c { documentContent = q }, future = documentContent c : fs } + Empty + -> hist + qs :|> ( q, diff ) + -> History { past = qs + , present = c { documentContent = q } + , future = ( diff, documentContent c ) : fs } fwd :: DocumentHistory -> DocumentHistory fwd hist@( History { past = ps, present = c, future = fs } ) = case fs of - [] -> hist - g : gs -> History { past = ps :|> documentContent c, present = c { documentContent = g }, future = gs } + [] + -> hist + ( diff, g ) : gs + -> History { past = ps :|> ( documentContent c, diff ) + , present = c { documentContent = g } + , future = gs } newHistory :: Document -> DocumentHistory newHistory a = History { past = Empty, present = a, future = [] } -newFutureStep :: Int -> Document -> DocumentHistory -> DocumentHistory -newFutureStep maxPastDocs a ( History { past = ps, present = c } ) = +newFutureStep :: Int -> HistoryDiff -> Document -> DocumentHistory -> DocumentHistory +newFutureStep maxPastDocs diff a ( History { past = ps, present = c } ) = History - { past = Seq.drop ( n - maxPastDocs ) ( ps :|> documentContent c ) + { past = Seq.drop ( n - maxPastDocs ) ( ps :|> ( documentContent c, diff ) ) , present = a , future = [] } @@ -77,11 +89,11 @@ atEnd hist = null ( future hist ) -------------------------------------------------------------------------------- -affirmPresent :: DocumentHistory -> DocumentHistory -affirmPresent - = set ( field' @"past" . traverse . field' @"unsavedChanges" ) +affirmPresentSaved :: DocumentHistory -> DocumentHistory +affirmPresentSaved + = set ( field' @"past" . traverse . _1 . field' @"unsavedChanges" ) True - . set ( field' @"present" . field' @"documentContent" . field' @"unsavedChanges" ) + . set ( field' @"present" . field' @"documentContent" . field' @"unsavedChanges" ) False - . set ( field' @"future" . traverse . field' @"unsavedChanges" ) + . set ( field' @"future" . traverse . _2 . field' @"unsavedChanges" ) True diff --git a/src/metabrushes/MetaBrush/Document/Serialise.hs b/src/metabrushes/MetaBrush/Document/Serialise.hs index 2826f71..509d26f 100644 --- a/src/metabrushes/MetaBrush/Document/Serialise.hs +++ b/src/metabrushes/MetaBrush/Document/Serialise.hs @@ -305,9 +305,8 @@ encodeLayer = . JSON.Encoder.atOptKey' "locked" JSON.Encoder.bool ( if layerLocked layer then Just True else Nothing ) . encodeLayerData -decodeLayer :: MonadIO m => UniqueSupply -> JSON.Decoder m Layer -decodeLayer uniqueSupply = do - layerUnique <- lift ( liftIO . STM.atomically $ Reader.runReaderT freshUnique uniqueSupply ) +decodeLayer :: MonadIO m => JSON.Decoder m Layer +decodeLayer = do mbLayerName <- JSON.Decoder.atKeyOptional "name" JSON.Decoder.text mbLayerVisible <- JSON.Decoder.atKeyOptional "visible" JSON.Decoder.bool mbLayerLocked <- JSON.Decoder.atKeyOptional "locked" JSON.Decoder.bool @@ -317,11 +316,11 @@ decodeLayer uniqueSupply = do case mbLayerStroke of Nothing -> do let layerName = fromMaybe "Group" mbLayerName - groupChildren <- fromMaybe [] <$> JSON.Decoder.atKeyOptional "contents" ( JSON.Decoder.list ( decodeLayer uniqueSupply ) ) - pure ( GroupLayer { layerUnique, layerName, layerVisible, layerLocked, groupChildren } ) + groupChildren <- fromMaybe [] <$> JSON.Decoder.atKeyOptional "contents" ( JSON.Decoder.list decodeLayer ) + pure ( GroupLayer { layerName, layerVisible, layerLocked, groupChildren } ) Just layerStroke -> do let layerName = fromMaybe "Stroke" mbLayerName - pure ( StrokeLayer { layerUnique, layerName, layerVisible, layerLocked, layerStroke } ) + pure ( StrokeLayer { layerName, layerVisible, layerLocked, layerStroke } ) encodeGuide :: Applicative f => JSON.Encoder f Guide encodeGuide = JSON.Encoder.mapLikeObj \ ( Guide { guidePoint, guideNormal } ) -> @@ -335,31 +334,6 @@ decodeGuide uniqueSupply = do guideNormal <- JSON.Decoder.atKey "normal" ( decoder @( T ( ℝ 2 ) ) ) pure ( guideUnique, Guide { guidePoint, guideNormal } ) -encodeDocumentContent :: Applicative f => JSON.Encoder f ( LayerMetadata, DocumentContent ) -encodeDocumentContent = JSON.Encoder.mapLikeObj \ ( layerMetadata, Content { strokeHierarchy } ) -> - JSON.Encoder.atKey' "strokes" ( JSON.Encoder.list encodeLayer ) $ - strokeHierarchyLayers layerMetadata strokeHierarchy - -decodeDocumentContent :: MonadIO m => UniqueSupply -> JSON.Decoder m ( LayerMetadata, DocumentContent ) -decodeDocumentContent uniqueSupply = do - let - unsavedChanges :: Bool - unsavedChanges = False - layers <- JSON.Decoder.atKey "strokes" ( JSON.Decoder.list $ decodeLayer uniqueSupply ) - let ( layerMetadata, strokeHierarchy ) = layersStrokeHierarchy layers - pure ( layerMetadata, Content { unsavedChanges, strokeHierarchy } ) - - -encodeDocumentMetadata :: Applicative f => JSON.Encoder f DocumentMetadata -encodeDocumentMetadata = - JSON.Encoder.mapLikeObj - \ ( Metadata { documentName, viewportCenter, documentZoom, documentGuides } ) -> - JSON.Encoder.atKey' "name" JSON.Encoder.text documentName - . JSON.Encoder.atKey' "center" ( encoder @( ℝ 2 ) ) viewportCenter - . JSON.Encoder.atKey' "zoom" ( encoder @Double ) ( zoomFactor documentZoom ) - . JSON.Encoder.atKey' "guides" ( JSON.Encoder.list encodeGuide ) ( Map.elems documentGuides ) - - decodeDocumentMetadata :: MonadIO m => UniqueSupply @@ -367,31 +341,41 @@ decodeDocumentMetadata -> LayerMetadata -> JSON.Decoder m DocumentMetadata decodeDocumentMetadata uniqueSupply mbFilePath layerMetadata = do - documentName <- JSON.Decoder.atKey "name" JSON.Decoder.text - viewportCenter <- JSON.Decoder.atKey "center" ( decoder @( ℝ 2 ) ) - zoomFactor <- JSON.Decoder.atKey "zoom" ( decoder @Double ) - guides <- JSON.Decoder.atKey "guides" ( JSON.Decoder.list $ decodeGuide uniqueSupply ) + documentName <- JSON.Decoder.atKeyOptional "name" JSON.Decoder.text + viewportCenter <- JSON.Decoder.atKeyOptional "center" ( decoder @( ℝ 2 ) ) + zoomFactor <- JSON.Decoder.atKeyOptional "zoom" ( decoder @Double ) + guides <- JSON.Decoder.atKeyOptional "guides" ( JSON.Decoder.list $ decodeGuide uniqueSupply ) pure $ Metadata - { documentName + { documentName = fromMaybe "Document" documentName , documentFilePath = mbFilePath - , viewportCenter - , documentZoom = Zoom { zoomFactor } - , documentGuides = Map.fromList guides + , viewportCenter = fromMaybe ( ℝ2 0 0 ) viewportCenter + , documentZoom = maybe ( Zoom 1 ) Zoom zoomFactor + , documentGuides = Map.fromList $ fromMaybe [] guides , layerMetadata - , selectedPoints = mempty + , selectedPoints = mempty } encodeDocument :: Applicative f => JSON.Encoder f Document encodeDocument = JSON.Encoder.mapLikeObj - \ ( Document { documentMetadata, documentContent } ) -> + \ ( Document { documentMetadata = meta, documentContent } ) -> JSON.Encoder.atKey' "version" ( JSON.Encoder.list JSON.Encoder.int ) ( versionBranch Cabal.version ) - . JSON.Encoder.atKey' "metadata" encodeDocumentMetadata documentMetadata - . JSON.Encoder.atKey' "content" encodeDocumentContent ( layerMetadata documentMetadata, documentContent ) + . JSON.Encoder.atKey' "name" JSON.Encoder.text ( documentName meta ) + . JSON.Encoder.atKey' "center" ( encoder @( ℝ 2 ) ) ( viewportCenter meta ) + . JSON.Encoder.atKey' "zoom" ( encoder @Double ) ( zoomFactor $ documentZoom meta ) + . JSON.Encoder.atKey' "guides" ( JSON.Encoder.list encodeGuide ) ( Map.elems $ documentGuides meta ) + . JSON.Encoder.atKey' "strokes" ( JSON.Encoder.list encodeLayer ) ( strokeHierarchyLayers ( layerMetadata meta ) ( strokeHierarchy documentContent ) ) decodeDocument :: MonadIO m => UniqueSupply -> Maybe FilePath -> JSON.Decoder m Document decodeDocument uniqueSupply mbFilePath = do - ( layerMetadata, documentContent ) <- - JSON.Decoder.atKey "content" ( decodeDocumentContent uniqueSupply ) - documentMetadata <- JSON.Decoder.atKey "metadata" $ decodeDocumentMetadata uniqueSupply mbFilePath layerMetadata + let + unsavedChanges :: Bool + unsavedChanges = False + mbLayers1 <- JSON.Decoder.atKeyOptional "strokes" ( JSON.Decoder.list decodeLayer ) + -- Preserve back-compat (a previous format used 'content.strokes' instead of 'strokes'). + mbLayers2 <- JSON.Decoder.atKeyOptional "content" ( JSON.Decoder.atKeyOptional "strokes" ( JSON.Decoder.list decodeLayer ) ) + let layers = fromMaybe [] mbLayers1 <> fromMaybe [] ( fromMaybe ( Just [] ) mbLayers2 ) + ( layerMetadata, strokeHierarchy ) <- lift $ ( `Reader.runReaderT` uniqueSupply ) $ layersStrokeHierarchy layers + let documentContent = Content { unsavedChanges, strokeHierarchy } + documentMetadata <- decodeDocumentMetadata uniqueSupply mbFilePath layerMetadata pure ( Document { documentMetadata, documentContent } ) diff --git a/src/metabrushes/MetaBrush/Layer.hs b/src/metabrushes/MetaBrush/Layer.hs index 40c8f90..3f585a9 100644 --- a/src/metabrushes/MetaBrush/Layer.hs +++ b/src/metabrushes/MetaBrush/Layer.hs @@ -1,6 +1,8 @@ module MetaBrush.Layer where -- base +import Data.Maybe + ( fromJust ) import Data.Word ( Word32 ) import GHC.Generics @@ -86,3 +88,24 @@ emptyHierarchy = , groups = Map.empty , content = Map.empty } + +lookupChildren :: Parent Unique -> Hierarchy a -> [ Unique ] +lookupChildren p h = fromJust $ lookupChildren_maybe p h + +lookupChildren_maybe :: Parent Unique -> Hierarchy a -> Maybe [ Unique ] +lookupChildren_maybe Root ( Hierarchy { topLevel } ) = Just topLevel +lookupChildren_maybe ( Parent u ) ( Hierarchy { groups } ) = groups Map.!? u + +insertGroup :: Parent Unique -> [ Unique ] -> Hierarchy a -> Hierarchy a +insertGroup Root us h = h { topLevel = us } +insertGroup ( Parent u ) us h = h { groups = Map.insert u us ( groups h ) } + +-- | Delete the key of a layer in a 'Hierarchy'. +-- +-- Does not remove it from any child lists, just from the "keys" of the maps. +deleteLayerKey :: Unique -> Hierarchy a -> ( Hierarchy a, Maybe [ Unique ] ) +deleteLayerKey u ( Hierarchy tl gs cs ) = + case Map.updateLookupWithKey ( \ _ _ -> Nothing ) u gs of + ( mbChildren, gs' ) -> + let cs' = Map.delete u cs + in ( Hierarchy tl gs' cs', mbChildren ) diff --git a/src/metabrushes/MetaBrush/Stroke.hs b/src/metabrushes/MetaBrush/Stroke.hs index dd37978..e42944c 100644 --- a/src/metabrushes/MetaBrush/Stroke.hs +++ b/src/metabrushes/MetaBrush/Stroke.hs @@ -4,6 +4,8 @@ module MetaBrush.Stroke where -- base +import Control.Arrow + ( (***) ) import Control.Monad.ST ( RealWorld ) import Data.Coerce @@ -52,9 +54,13 @@ import Data.Text ( Text ) -- transformers -import Control.Monad.State.Strict - ( State ) -import qualified Control.Monad.State.Strict as State +import Control.Monad.IO.Class + ( MonadIO ) +import Control.Monad.Trans.Reader + ( ReaderT ) +import Control.Monad.Trans.State.Strict + ( StateT ) +import qualified Control.Monad.Trans.State.Strict as State -- brush-strokes import Math.Bezier.Spline @@ -73,10 +79,13 @@ import Math.Linear -- MetaBrush import MetaBrush.Brush ( NamedBrush, PointFields ) -import MetaBrush.Layer hiding ( Layer(..) ) +import MetaBrush.Layer + ( Hierarchy(..), LayerMetadata(..), emptyHierarchy ) import MetaBrush.Records import MetaBrush.Unique - ( Unique ) + ( Unique, UniqueSupply, freshUnique ) +import MetaBrush.Util + ( (!) ) -------------------------------------------------------------------------------- @@ -273,12 +282,12 @@ forStrokeHierarchy let meta = StrokeMetadata - { strokeName = layerNames Map.! u + { strokeName = layerNames ! u , strokeVisible = vis' , strokeLocked = lock' } in - insertMaybe par u <$> acc <*> f u ( content hierarchy0 Map.! u ) meta + insertMaybe par u <$> acc <*> f u ( content hierarchy0 ! u ) meta Just ds -> foldr' ( g ( Just u ) ( vis', lock' ) ) acc ds @@ -294,15 +303,13 @@ type Layers = [ Layer ] -- Used for serialisation/deserialisation only. data Layer = StrokeLayer - { layerUnique :: !Unique - , layerName :: !Text + { layerName :: !Text , layerVisible :: !Bool , layerLocked :: !Bool , layerStroke :: !Stroke } | GroupLayer - { layerUnique :: !Unique - , layerName :: !Text + { layerName :: !Text , layerVisible :: !Bool , layerLocked :: !Bool , groupChildren :: !Layers @@ -317,50 +324,44 @@ strokeHierarchyLayers go :: Unique -> Layer go layerUnique = let - layerName = layerNames Map.! layerUnique + layerName = layerNames ! layerUnique layerVisible = not $ layerUnique `Set.member` invisibleLayers layerLocked = layerUnique `Set.member` lockedLayers in case Map.lookup layerUnique hierarchy of Nothing -> StrokeLayer - { layerUnique, layerName, layerVisible, layerLocked - , layerStroke = content Map.! layerUnique + { layerName, layerVisible, layerLocked + , layerStroke = content ! layerUnique } Just cs -> GroupLayer - { layerUnique, layerName, layerVisible, layerLocked + { layerName, layerVisible, layerLocked , groupChildren = map go cs } -layersStrokeHierarchy :: Layers -> ( LayerMetadata, StrokeHierarchy ) -layersStrokeHierarchy lays = ( `State.execState` ( mempty, emptyHierarchy ) ) $ do +{-# INLINEABLE layersStrokeHierarchy #-} +layersStrokeHierarchy :: forall m. MonadIO m => Layers -> ReaderT UniqueSupply m ( LayerMetadata, StrokeHierarchy ) +layersStrokeHierarchy lays = ( `State.execStateT` ( mempty, emptyHierarchy ) ) $ do us <- traverse go lays State.modify' ( \ ( meta, hierarchy ) -> ( meta, hierarchy { topLevel = us } ) ) where - go :: Layer -> State ( LayerMetadata, StrokeHierarchy ) Unique + go :: Layer -> StateT ( LayerMetadata, StrokeHierarchy ) ( ReaderT UniqueSupply m ) Unique go l = do - ( LayerMetadata { layerNames = nms, invisibleLayers = invis, lockedLayers = locked } - , oldHierarchy@( Hierarchy _topLevel oldGroups oldStrokes ) - ) <- State.get - let u = layerUnique l - newMeta = + u <- freshUnique + let updMeta ( LayerMetadata nms invis locked ) = LayerMetadata { layerNames = Map.insert u ( layerName l ) nms , invisibleLayers = if layerVisible l then invis else Set.insert u invis , lockedLayers = if layerLocked l then Set.insert u locked else locked } - newHierarchy <- - case l of - StrokeLayer { layerStroke } -> - return $ - oldHierarchy - { content = Map.insert u layerStroke oldStrokes } - GroupLayer { groupChildren } -> do - us <- traverse go groupChildren - return $ - oldHierarchy { groups = Map.insert u us oldGroups } - State.put ( newMeta, newHierarchy ) + updHierarchy <- case l of + StrokeLayer { layerStroke } -> + return $ \ h -> h { content = Map.insert u layerStroke ( content h ) } + GroupLayer { groupChildren } -> do + us <- traverse go groupChildren + return $ \ h -> h { groups = Map.insert u us ( groups h ) } + State.modify' ( updMeta *** updHierarchy ) return u -------------------------------------------------------------------------------- diff --git a/src/metabrushes/MetaBrush/Unique.hs b/src/metabrushes/MetaBrush/Unique.hs index 5d5bf48..78ba608 100644 --- a/src/metabrushes/MetaBrush/Unique.hs +++ b/src/metabrushes/MetaBrush/Unique.hs @@ -46,9 +46,6 @@ import Control.Monad.Reader import Control.Concurrent.STM ( STM ) import qualified Control.Concurrent.STM as STM - ( atomically ) -import qualified Control.Concurrent.STM.TVar as STM - ( TVar, newTVarIO, readTVar, writeTVar ) -- text import Data.Text @@ -96,15 +93,13 @@ class Monad m => MonadUnique m where instance {-# OVERLAPPABLE #-} ( Monad m, MonadReader r m, HasType UniqueSupply r, MonadIO m ) => MonadUnique m where freshUnique = do UniqueSupply { uniqueSupplyTVar } <- view ( typed @UniqueSupply ) - liftIO $ STM.atomically do - uniq@( Unique !i ) <- STM.readTVar uniqueSupplyTVar - STM.writeTVar uniqueSupplyTVar ( Unique ( succ i ) ) - pure uniq + liftIO $ STM.atomically $ STM.stateTVar uniqueSupplyTVar doSucc instance MonadUnique ( ReaderT UniqueSupply STM ) where freshUnique = do UniqueSupply { uniqueSupplyTVar } <- ask - lift do - uniq@( Unique !i ) <- STM.readTVar uniqueSupplyTVar - STM.writeTVar uniqueSupplyTVar ( Unique ( succ i ) ) - pure uniq + lift $ STM.stateTVar uniqueSupplyTVar doSucc + +doSucc :: Unique -> ( Unique, Unique ) +doSucc uniq@( Unique !i ) = ( uniq, Unique ( succ i ) ) + diff --git a/src/metabrushes/MetaBrush/Util.hs b/src/metabrushes/MetaBrush/Util.hs index f0b9646..01c4ea6 100644 --- a/src/metabrushes/MetaBrush/Util.hs +++ b/src/metabrushes/MetaBrush/Util.hs @@ -1,9 +1,25 @@ module MetaBrush.Util ( Exists(..) + , (!) ) where +-- base +import GHC.Stack + ( HasCallStack ) + +-- containers +import Data.Map.Strict + ( Map ) +import qualified Data.Map.Strict as Map + -------------------------------------------------------------------------------- data Exists c where Exists :: c a => a -> Exists c + +infixl 9 ! +(!) :: ( Show k, Ord k, HasCallStack ) => Map k a -> k -> a +m ! k = case Map.lookup k m of + Nothing -> error $ "MetaBrush internal error: key not in map: " ++ show k + Just a -> a \ No newline at end of file