From 341a8ed0cae6f3f1834fd25af68278d23df7bd88 Mon Sep 17 00:00:00 2001 From: sheaf Date: Thu, 3 Sep 2020 05:57:08 +0200 Subject: [PATCH] closing documents / removing file tabs --- MetaBrush.cabal | 2 + app/Main.hs | 6 +- assets/theme.css | 26 +++++++- src/app/MetaBrush/Action.hs | 87 ++++++++++++++++++++----- src/app/MetaBrush/Document/Draw.hs | 4 +- src/app/MetaBrush/Document/Selection.hs | 8 ++- src/app/MetaBrush/Render/Document.hs | 1 + src/app/MetaBrush/UI/FileBar.hs | 59 +++++++++++++---- src/app/MetaBrush/UI/FileBar.hs-boot | 7 +- src/app/MetaBrush/UI/Menu.hs | 2 +- 10 files changed, 162 insertions(+), 40 deletions(-) diff --git a/MetaBrush.cabal b/MetaBrush.cabal index cfc0370..75fc3fc 100644 --- a/MetaBrush.cabal +++ b/MetaBrush.cabal @@ -146,6 +146,8 @@ executable MetaBrush >= 2.0.27 && < 2.1 , gi-glib >= 2.0.23 && < 2.1 + , gi-gobject + ^>= 2.0.24 , gi-gtk >= 3.0.35 && < 3.1 , gi-cairo-render diff --git a/app/Main.hs b/app/Main.hs index ea1dbc0..702c443 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -116,15 +116,15 @@ testDocuments = uniqueMapFromList , strokes = [ Stroke { strokeName = "Ellipse" , strokeVisible = True - , strokeUnique = unsafeUnique 10 - , strokePoints = ellipse 150 100 ( PointData Normal ( rect 30 6 $ BrushPointData Normal ) ) + , strokeUnique = unsafeUnique 10 + , strokePoints = ellipse 150 100 ( PointData Normal ( rect 30 6 $ BrushPointData Normal ) ) } ] } , Document { displayName = "Line" , mbFilePath = Nothing - , unsavedChanges = True + , unsavedChanges = False , viewportCenter = Point2D 0 0 , zoomFactor = 1 , documentUnique = unsafeUnique 1 diff --git a/assets/theme.css b/assets/theme.css index 1d91cad..913ae2f 100644 --- a/assets/theme.css +++ b/assets/theme.css @@ -95,7 +95,7 @@ tooltip { border: 1px solid rgb(28,25,25); } -.window { +.window, .dialog { -GtkWidget-window-dragging: true; } @@ -179,6 +179,30 @@ tooltip { border-top: 2px solid rgb(41, 40, 40); } +.dialog { + border: 1px solid black; + border-radius: 6px; +} + +.dialogButton { + background-color: rgb(72,70,61); + border: 1px solid black; + border-radius: 4px; + margin: 6px; + padding: 2px 10px 2px 10px; +} + +.dialogButton:hover { + border-color:rgb(212, 190, 152); +} + +.dialogButton:active, .dialogButton:checked { + color: rgb(72,70,61); + border-color: black; + background-color: #eadfcc; +} + + .menuBar { padding-left: 4px; } diff --git a/src/app/MetaBrush/Action.hs b/src/app/MetaBrush/Action.hs index b3e94a4..377bddd 100644 --- a/src/app/MetaBrush/Action.hs +++ b/src/app/MetaBrush/Action.hs @@ -7,6 +7,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} @@ -18,8 +19,10 @@ import Control.Monad ( guard, when, unless, void ) import Data.Foldable ( for_ ) +import Data.Int + ( Int32 ) import Data.Maybe - ( catMaybes, listToMaybe) + ( catMaybes, listToMaybe ) import Data.Word ( Word32 ) @@ -33,7 +36,7 @@ import Data.Act -- containers import qualified Data.Map as Map - ( insert ) + ( lookup, insert, delete ) import Data.Sequence ( Seq(..) ) import qualified Data.Sequence as Seq @@ -93,10 +96,14 @@ import MetaBrush.UI.Coordinates ( toViewportCoordinates ) import MetaBrush.UI.InfoBar ( updateInfoBar ) -import MetaBrush.UI.FileBar - ( TabLocation(..), newFileTab ) +import {-# SOURCE #-} MetaBrush.UI.FileBar + ( TabLocation(..), newFileTab, removeFileTab ) import MetaBrush.UI.ToolBar ( Tool(..) ) +import MetaBrush.Unique + ( Unique ) +import MetaBrush.Util + ( widgetAddClass, widgetAddClasses ) -------------------------------------------------------------------------------- @@ -193,7 +200,7 @@ instance HandleAction Save where Nothing -> pure () -- could show a warning message Just doc@( Document { mbFilePath, unsavedChanges } ) | Nothing <- mbFilePath - -> saveAs uiElts vars doc + -> saveAs uiElts vars True doc | False <- unsavedChanges -> pure () | Just filePath <- mbFilePath @@ -217,10 +224,10 @@ instance HandleAction SaveAs where mbDoc <- STM.atomically $ currentDocument vars case mbDoc of Nothing -> pure () -- could show a warning message - Just doc -> saveAs uiElts vars doc + Just doc -> saveAs uiElts vars True doc -saveAs :: UIElements -> Variables -> Document -> IO () -saveAs ( UIElements { window } ) ( Variables { openDocumentsTVar } ) doc = do +saveAs :: UIElements -> Variables -> Bool -> Document -> IO () +saveAs ( UIElements { window, fileBar } ) vars@( Variables { openDocumentsTVar } ) keepOpen doc = do fileChooser <- GTK.fileChooserNativeNew ( Just "Save MetaBrush document..." ) ( Just window ) GTK.FileChooserActionSave @@ -244,22 +251,68 @@ saveAs ( UIElements { window } ) ( Variables { openDocumentsTVar } ) doc = do | otherwise = filePath <.> "mb" saveDocument fullFilePath doc - STM.atomically $ - STM.modifyTVar' openDocumentsTVar - ( Map.insert ( documentUnique doc ) - ( doc { mbFilePath = Just fullFilePath, unsavedChanges = False } ) - ) + if keepOpen + then + STM.atomically $ + STM.modifyTVar' openDocumentsTVar + ( Map.insert ( documentUnique doc ) + ( doc { mbFilePath = Just fullFilePath, unsavedChanges = False } ) + ) + else removeFileTab fileBar vars ( documentUnique doc ) ----------- -- Close -- ----------- -data Close = Close - deriving stock Show +data Close + = CloseActive -- ^ Close active document. + | CloseThis -- ^ Close a specific tab (action to destroy tab is directly given). + { docToClose :: Unique + , destroyTabAction :: IO () + } + +instance Show Close where + show CloseActive = "CloseActive" + show ( CloseThis docToClose _ ) = "CloseThis " <> show docToClose + +pattern JustClose, SaveAndClose, CancelClose :: Int32 +pattern JustClose = 1 +pattern SaveAndClose = 2 +pattern CancelClose = 3 --- TODO instance HandleAction Close where - handleAction _ _ _ = pure () + handleAction uiElts@( UIElements { window, fileBar } ) vars@( Variables { .. } ) close = do + mbDoc <- case close of + CloseActive -> STM.atomically $ currentDocument vars + CloseThis unique _ -> Map.lookup unique <$> STM.readTVarIO openDocumentsTVar + case mbDoc of + Nothing -> pure () -- could show a warning message + Just doc@( Document { displayName, documentUnique } ) -> do + dialog <- GTK.new GTK.MessageDialog [] + GTK.setMessageDialogText dialog ( " \n\"" <> displayName <> "\" contains unsaved changes.\nClose anyway?" ) + GTK.setMessageDialogMessageType dialog GTK.MessageTypeQuestion + GTK.setWindowResizable dialog False + GTK.setWindowDecorated dialog False + GTK.widgetAddEvents dialog + [ GDK.EventMaskKeyPressMask, GDK.EventMaskKeyReleaseMask ] + GTK.windowSetTransientFor dialog ( Just window ) + GTK.windowSetModal dialog True + widgetAddClasses dialog [ "bg", "plain", "text", "dialog" ] + closeButton <- GTK.dialogAddButton dialog "Close" JustClose + saveButton <- GTK.dialogAddButton dialog "Save and close" SaveAndClose + cancelButton <- GTK.dialogAddButton dialog "Cancel" CancelClose + GTK.dialogSetDefaultResponse dialog 1 + for_ [ closeButton, saveButton, cancelButton ] \ button -> widgetAddClass button "dialogButton" + choice <- GTK.dialogRun dialog + GTK.widgetDestroy dialog + case choice of + JustClose -> case close of + CloseActive -> removeFileTab fileBar vars documentUnique + CloseThis _ destroyTab -> do + destroyTab + STM.atomically $ STM.modifyTVar' openDocumentsTVar ( Map.delete documentUnique ) + SaveAndClose -> saveAs uiElts vars False doc + _ -> pure () -------------- -- Quitting -- diff --git a/src/app/MetaBrush/Document/Draw.hs b/src/app/MetaBrush/Document/Draw.hs index 47b85a8..91cd7f2 100644 --- a/src/app/MetaBrush/Document/Draw.hs +++ b/src/app/MetaBrush/Document/Draw.hs @@ -91,7 +91,7 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) = } : ) newDoc - pure ( newDoc', AnchorAtEnd uniq, c ) + pure ( newDoc' { unsavedChanges = True }, AnchorAtEnd uniq, c ) where -- Deselect all points, and try to find a valid anchor for drawing -- (a path start/end point at mouse click point). @@ -128,7 +128,7 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) = squaredNorm ( c --> p :: Vector2D Double ) < 16 / ( zoomFactor * zoomFactor ) addToAnchor :: DrawAnchor -> Seq ( StrokePoint PointData ) -> Document -> Document -addToAnchor anchor newPts = over ( field' @"strokes" . mapped ) addToStroke +addToAnchor anchor newPts = set ( field' @"unsavedChanges" ) True . over ( field' @"strokes" . mapped ) addToStroke where addToStroke :: Stroke -> Stroke addToStroke stroke@( Stroke { strokeUnique, strokePoints = pts } ) diff --git a/src/app/MetaBrush/Document/Selection.hs b/src/app/MetaBrush/Document/Selection.hs index 481c3fe..80c5e4d 100644 --- a/src/app/MetaBrush/Document/Selection.hs +++ b/src/app/MetaBrush/Document/Selection.hs @@ -271,9 +271,11 @@ translateSelection mode t | Brush <- mode = over ( field' @"strokes" . mapped . field' @"strokePoints" . mapped . field' @"pointData" . field' @"brushShape" . mapped ) updateStrokePoint + . set ( field' @"unsavedChanges" ) True | otherwise = over ( field' @"strokes" . mapped . field' @"strokePoints" . mapped ) updateStrokePoint + . set ( field' @"unsavedChanges" ) True where updateStrokePoint :: HasType FocusState pt => StrokePoint pt -> StrokePoint pt updateStrokePoint pt @@ -288,12 +290,14 @@ deleteSelected mode doc = fst . runIdentity . ( `Tardis.runTardisT` ( False, Fal Brush -> ( field' @"strokes" . traverse . field' @"strokePoints" . traverse . field' @"pointData" . field' @"brushShape" ) updateStroke - doc + doc' _ -> ( field' @"strokes" . traverse . field' @"strokePoints" ) updateStroke - doc + doc' where + doc' :: Document + doc' = doc { unsavedChanges = True } updateStroke :: forall pt . HasType FocusState pt diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index ba787fa..fccf200 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -136,6 +136,7 @@ renderDocument modifiedStrokes | Just ( DragMoveHold p0 ) <- mbHoldEvent , Just p1 <- mbMousePos + , p0 /= p1 = strokes $ translateSelection mode ( p0 --> p1 ) doc | Just ( PartialPath p0 cp0 _ _ ) <- mbPartialPath , let diff --git a/src/app/MetaBrush/UI/FileBar.hs b/src/app/MetaBrush/UI/FileBar.hs index bccf926..d82b268 100644 --- a/src/app/MetaBrush/UI/FileBar.hs +++ b/src/app/MetaBrush/UI/FileBar.hs @@ -6,22 +6,32 @@ {-# LANGUAGE TypeApplications #-} module MetaBrush.UI.FileBar - ( FileBar(..), createFileBar, newFileTab + ( FileBar(..) + , createFileBar, newFileTab, removeFileTab , TabLocation(..) ) where -- base import Control.Monad - ( void ) + ( unless, void, when ) import Data.Maybe ( listToMaybe ) import Data.Foldable ( for_ ) +import qualified Foreign.Marshal.Alloc as Foreign + ( malloc, free ) +import qualified Foreign.Ptr as Foreign + ( castPtr, nullPtr ) +import qualified Foreign.Storable as Foreign + ( peek, poke ) -- containers import qualified Data.Map.Strict as Map - ( lookup, insert ) + ( lookup, insert, delete ) + +-- gi-gobject +import qualified GI.GObject as GObject -- gi-gtk import qualified GI.Gtk as GTK @@ -37,6 +47,8 @@ import Data.Text ( Text ) -- MetaBrush +import MetaBrush.Action + ( Close(..), handleAction ) import MetaBrush.Context ( UIElements(..), Variables(..) ) import MetaBrush.Document @@ -72,7 +84,7 @@ newFileTab -> IO () newFileTab vars@( Variables { uniqueSupply, activeDocumentTVar, openDocumentsTVar } ) - ( UIElements { fileBar = FileBar {..}, .. } ) + uiElts@( UIElements { fileBar = FileBar {..}, .. } ) mbDoc newTabLoc = do @@ -99,9 +111,18 @@ newFileTab GTK.boxPackStart tab closeFileButton False False 0 widgetAddClasses pgButton [ "fileBarTabButton" ] widgetAddClasses closeFileButton [ "fileBarCloseButton" ] - GTK.widgetShowAll tab + -- Associate each tab with the corresponding document unique, + -- so we can know which document corresponds to each file tab + -- by only looking at the tab. + let + newUnique :: Unique + newUnique = documentUnique newDoc + uniquePtr <- Foreign.malloc @Unique + Foreign.poke uniquePtr newUnique + GObject.objectSetData tab "unique" ( Foreign.castPtr @Unique @() uniquePtr ) + -- We've placed the new tab at the end. Now rearrange it if needed. case newTabLoc of LastTab -> pure () @@ -134,9 +155,7 @@ newFileTab pure False -- Update the state: switch to this new document. - let - newUnique :: Unique - newUnique = documentUnique newDoc + STM.atomically do STM.modifyTVar' openDocumentsTVar ( Map.insert newUnique newDoc ) STM.writeTVar activeDocumentTVar ( Just newUnique ) @@ -171,14 +190,14 @@ newFileTab GTK.labelSetText title "MetaBrush" GTK.setWindowTitle window "MetaBrush" - --void $ GTK.onButtonClicked closeFileButton - -- ( STM.atomically $ signalAction actionTQueue Close ) - - --void $ GTK.onButtonClicked closeFileButton ... ... ... + void $ GTK.onButtonClicked closeFileButton + ( handleAction uiElts vars + ( CloseThis newUnique ( Foreign.free uniquePtr *> GTK.widgetDestroy tab ) ) + ) GTK.toggleButtonSetActive pgButton True --- | Add the file bar: tabs allowing selection of the active document. +-- | Create a file bar: tabs allowing selection of the active document. -- -- Updates the active document when buttons are clicked. createFileBar @@ -233,3 +252,17 @@ createFileBar LastTab pure fileBar + +-- | Close a document: remove the corresponding file tab from the file bar. +removeFileTab :: FileBar -> Variables -> Unique -> IO () +removeFileTab ( FileBar { fileTabsBox } ) ( Variables { openDocumentsTVar } ) docUnique = do + GTK.containerForeach fileTabsBox \ tab -> do + + uniquePtr <- Foreign.castPtr @() @Unique <$> GObject.objectGetData tab "unique" + unless ( uniquePtr == Foreign.nullPtr ) do + tabUnique <- Foreign.peek uniquePtr + when ( docUnique == tabUnique ) do + Foreign.free uniquePtr + GTK.widgetDestroy tab + + STM.atomically $ STM.modifyTVar' openDocumentsTVar ( Map.delete docUnique ) diff --git a/src/app/MetaBrush/UI/FileBar.hs-boot b/src/app/MetaBrush/UI/FileBar.hs-boot index 9a2ac8b..419a193 100644 --- a/src/app/MetaBrush/UI/FileBar.hs-boot +++ b/src/app/MetaBrush/UI/FileBar.hs-boot @@ -1,5 +1,6 @@ module MetaBrush.UI.FileBar - ( FileBar(..), createFileBar, newFileTab + ( FileBar(..) + , createFileBar, newFileTab, removeFileTab , TabLocation(..) ) where @@ -14,6 +15,8 @@ import MetaBrush.Document ( Document ) import {-# SOURCE #-} MetaBrush.UI.InfoBar ( InfoBar ) +import MetaBrush.Unique + ( Unique ) -------------------------------------------------------------------------------- @@ -36,3 +39,5 @@ createFileBar -> IO FileBar newFileTab :: Variables -> UIElements -> Maybe Document -> TabLocation -> IO () + +removeFileTab :: FileBar -> Variables -> Unique -> IO () diff --git a/src/app/MetaBrush/UI/Menu.hs b/src/app/MetaBrush/UI/Menu.hs index 3ad7dea..76f3134 100644 --- a/src/app/MetaBrush/UI/Menu.hs +++ b/src/app/MetaBrush/UI/Menu.hs @@ -184,7 +184,7 @@ fileMenuDescription , openFolder = MenuItemDescription "Open folder" [ "submenuItem" ] ( OpenFolder AfterCurrentTab ) ( Just ( GDK.KEY_O, [ Control L, Shift L ] ) ) NoSubresource , save = MenuItemDescription "Save" [ "submenuItem" ] Save ( Just ( GDK.KEY_S, [ Control L ] ) ) NoSubresource , saveAs = MenuItemDescription "Save as" [ "submenuItem" ] SaveAs ( Just ( GDK.KEY_S, [ Control L, Shift L ] ) ) NoSubresource - , close = MenuItemDescription "Close" [ "submenuItem" ] Close ( Just ( GDK.KEY_W, [ Control L ] ) ) NoSubresource + , close = MenuItemDescription "Close" [ "submenuItem" ] CloseActive ( Just ( GDK.KEY_W, [ Control L ] ) ) NoSubresource , quit = MenuItemDescription "Quit" [ "submenuItem" ] Quit ( Just ( GDK.KEY_Q, [ Control L ] ) ) NoSubresource }