closing documents / removing file tabs

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

app/Main.hs

@@ -124,7 +124,7 @@ testDocuments = uniqueMapFromList
   , Document
     { displayName    = "Line"
     , mbFilePath     = Nothing
-    , unsavedChanges = True
+    , unsavedChanges = False
     , viewportCenter = Point2D 0 0
     , zoomFactor     = 1
     , documentUnique = unsafeUnique 1

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;
 }

src/app/MetaBrush/Action.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns        #-}
 {-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE PatternSynonyms       #-}
 {-# LANGUAGE RecordWildCards       #-}
 {-# LANGUAGE TypeApplications      #-}
 {-# LANGUAGE UndecidableInstances  #-}
@@ -18,6 +19,8 @@ import Control.Monad
   ( guard, when, unless, void )
 import Data.Foldable
   ( for_ )
+import Data.Int
+  ( Int32 )
 import Data.Maybe
   ( catMaybes, listToMaybe )
 import Data.Word
@@ -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
+import {-# SOURCE #-} MetaBrush.UI.FileBar
-  ( TabLocation(..), newFileTab )
+  ( 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 -> Variables -> Bool -> Document -> IO ()
-saveAs ( UIElements { window } ) ( Variables { openDocumentsTVar } ) doc = do
+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
+    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
+data Close
-  deriving stock Show
+  = 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 --

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 } )

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

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

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
+    void $ GTK.onButtonClicked closeFileButton
-    --  ( STM.atomically $ signalAction actionTQueue Close )
+      ( handleAction uiElts vars
-
+        ( CloseThis newUnique ( Foreign.free uniquePtr *> GTK.widgetDestroy tab ) )
-    --void $ GTK.onButtonClicked closeFileButton ... ... ...
+      )
 
     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 )

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 ()

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
   }