refactor document modification

* the "modifyingCurrentDocument" now handles
    all the followup actions necessary after
    modifying the current document,
    such as updating the title bar

src/app/MetaBrush/Action.hs

@@ -36,7 +36,7 @@ import Data.Act
 
 -- containers
 import qualified Data.Map as Map
-  ( lookup, insert )
+  ( lookup )
 import Data.Sequence
   ( Seq(..) )
 import qualified Data.Sequence as Seq
@@ -75,7 +75,9 @@ import MetaBrush.Context
   ( UIElements(..), Variables(..)
   , Modifier(..), modifierKey
   , HoldAction(..), PartialPath(..)
-  , currentDocument, withCurrentDocument, modifyingCurrentDocument
+  , currentDocument, withCurrentDocument
+  , PureDocModification(..), DocModification(..)
+  , modifyingCurrentDocument
   , updateTitle
   )
 import MetaBrush.Document
@@ -195,23 +197,30 @@ data Save = Save
   deriving stock Show
 
 instance HandleAction Save where
-  handleAction uiElts vars@( Variables { .. } ) _ = do
+  handleAction uiElts@( UIElements { .. } ) vars@( Variables { .. } ) _ =
-    mbDoc <- STM.atomically $ currentDocument vars
+    save uiElts vars True
-    case mbDoc of
+
-      Nothing  -> pure () -- could show a warning message
+save :: UIElements -> Variables -> Bool -> IO ()
-      Just doc@( Document { mbFilePath, unsavedChanges } )
+save uiElts vars keepOpen = do
-        | Nothing <- mbFilePath
+  mbDoc <- STM.atomically $ currentDocument vars
-        -> saveAs uiElts vars True doc
+  for_ mbDoc \case
-        | False <- unsavedChanges
+    doc@( Document { mbFilePath, unsavedChanges } )
-        -> pure ()
+      | Nothing <- mbFilePath
-        | Just filePath <- mbFilePath
+      -> saveAs uiElts vars keepOpen
-        -> do
+      | False <- unsavedChanges
-          saveDocument filePath doc
+      -> pure ()
-          STM.atomically $
+      | Just filePath <- mbFilePath
-            STM.modifyTVar' openDocumentsTVar
+      -> modifyingCurrentDocument uiElts vars \ _ -> do
-              ( Map.insert ( documentUnique doc )
+        let
-                ( doc { unsavedChanges = False } )
+          doc' :: Document
-              )
+          doc' = doc { unsavedChanges = False }
+        if keepOpen
+        then
+          pure $ UpdateDocToAndThen
+            ( Just doc' )
+            ( saveDocument filePath doc' )
+        else
+          pure $ UpdateDocToAndThen Nothing ( saveDocument filePath doc' )
 
 -------------
 -- Save as --
@@ -221,14 +230,26 @@ data SaveAs = SaveAs
   deriving stock Show
 
 instance HandleAction SaveAs where
-  handleAction uiElts vars _ = do
+  handleAction uiElts vars _ = saveAs uiElts vars True
-    mbDoc <- STM.atomically $ currentDocument vars
-    case mbDoc of
-      Nothing  -> pure () -- could show a warning message
-      Just doc -> saveAs uiElts vars True doc
 
-saveAs :: UIElements -> Variables -> Bool -> Document -> IO ()
+saveAs :: UIElements -> Variables -> Bool -> IO ()
-saveAs ( UIElements { .. } ) vars@( Variables { openDocumentsTVar } ) keepOpen doc = do
+saveAs uiElts vars keepOpen = do
+  mbSavePath <- askForSavePath uiElts
+  for_ mbSavePath \ savePath -> do
+    modifyingCurrentDocument uiElts vars \ doc -> do
+      let
+        doc' :: Document
+        doc' = doc { mbFilePath = Just savePath, unsavedChanges = False }
+      if keepOpen
+      then
+        pure $ UpdateDocToAndThen
+          ( Just doc' )
+          ( saveDocument savePath doc' )
+      else
+        pure $ UpdateDocToAndThen Nothing ( saveDocument savePath doc' )
+
+askForSavePath :: UIElements -> IO ( Maybe FilePath )
+askForSavePath ( UIElements { .. } ) = do
   fileChooser <-
     GTK.fileChooserNativeNew ( Just "Save MetaBrush document..." ) ( Just window )
       GTK.FileChooserActionSave
@@ -241,25 +262,14 @@ saveAs ( UIElements { .. } ) vars@( Variables { openDocumentsTVar } ) keepOpen d
   GTK.fileFilterAddPattern fileFilter "*.mb"
   GTK.fileChooserAddFilter fileChooser fileFilter
   void $ GTK.nativeDialogRun fileChooser
-  mbFilePath <- listToMaybe <$> GTK.fileChooserGetFilenames fileChooser
+  fmap fullFilePath . listToMaybe <$> GTK.fileChooserGetFilenames fileChooser
-  for_ mbFilePath \ filePath -> do
+    where
-    -- set the document's new file path, and modify to indicate "no unsaved changes"
+      fullFilePath :: FilePath -> FilePath
-    let
+      fullFilePath fp
-      fullFilePath :: FilePath
+        | ".mb" <- takeExtension fp
-      fullFilePath
+        = fp
-        | ".mb" <- takeExtension filePath
-        = filePath
         | otherwise
-        = filePath <.> "mb"
+        = fp <.> "mb"
-    saveDocument fullFilePath doc
-    if keepOpen
-    then
-      STM.atomically $
-        STM.modifyTVar' openDocumentsTVar
-          ( Map.insert ( documentUnique doc )
-            ( doc { mbFilePath = Just fullFilePath, unsavedChanges = False } )
-          )
-    else removeFileTab window title viewportDrawingArea infoBar vars ( documentUnique doc )
 
 -----------
 -- Close --
@@ -283,7 +293,7 @@ instance HandleAction Close where
       CloseThis unique -> Map.lookup unique <$> STM.readTVarIO openDocumentsTVar
     case mbDoc of
       Nothing -> pure () -- could show a warning message
-      Just doc@( Document { displayName, documentUnique, unsavedChanges } )
+      Just ( Document { displayName, documentUnique, unsavedChanges } )
         | unsavedChanges
         -> do
           dialog <- GTK.new GTK.MessageDialog []
@@ -302,11 +312,19 @@ instance HandleAction Close where
           choice <- GTK.dialogRun dialog
           GTK.widgetDestroy dialog
           case choice of
-            JustClose    -> removeFileTab window title viewportDrawingArea infoBar vars documentUnique
+            JustClose    -> closeDocument documentUnique
-            SaveAndClose -> saveAs uiElts vars False doc
+            SaveAndClose -> save uiElts vars False
             _            -> pure ()
         | otherwise
-        -> removeFileTab window title viewportDrawingArea infoBar vars documentUnique
+        -> closeDocument documentUnique
+
+    where
+      closeDocument :: Unique -> IO ()
+      closeDocument unique = do
+        removeFileTab vars unique
+        updateTitle window title Nothing
+        updateInfoBar viewportDrawingArea infoBar vars
+        GTK.widgetQueueDraw viewportDrawingArea
 
 ---------------------
 -- Switch document --
@@ -426,7 +444,9 @@ instance HandleAction Delete where
         mode <- STM.readTVarIO modeTVar
         case tool of
           -- Delete selected points on pressing 'Delete'.
-          Selection -> modifyingCurrentDocument uiElts vars ( pure . Just . deleteSelected mode )
+          Selection
+            -> modifyingCurrentDocument uiElts vars \ doc ->
+                pure ( UpdateDocTo $ Just ( deleteSelected mode doc ) )
           _ -> pure ()
 
 ------------
@@ -544,11 +564,11 @@ instance HandleAction MouseClick where
                   | Just newDoc <- dragMoveSelect mode pos doc
                   -> do
                     STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold  pos )
-                    pure ( Just newDoc )
+                    pure ( UpdateDocTo $ Just newDoc )
                 -- Rectangular selection.
                 _ -> do
                     STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos )
-                    pure Nothing
+                    pure Don'tModifyDoc
 
             -- Pen tool: start or continue a drawing operation.
             Pen -> do
@@ -566,11 +586,11 @@ instance HandleAction MouseClick where
                       , firstPoint          = True
                       }
                     )
-                  pure ( Just newDoc )
+                  pure ( UpdateDocTo $ Just newDoc )
                 -- Path already started: indicate that we are continuing a path.
                 Just pp -> do
                   STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } )
-                  pure Nothing
+                  pure Don'tModifyDoc
 
       -- Right mouse button: end partial path.
       3 -> do
@@ -621,18 +641,18 @@ instance HandleAction MouseRelease where
                 Just hold
                   | DragMoveHold  pos0 <- hold
                   , pos0 /= pos
-                  -> pure . Just $ translateSelection mode ( pos0 --> pos ) doc
+                  -> pure ( UpdateDocTo $ Just $ translateSelection mode ( pos0 --> pos ) doc )
                   | SelectionHold pos0 <- hold
                   , pos0 /= pos
-                  -> pure . Just $ selectRectangle mode selMode pos0 pos doc
+                  -> pure ( UpdateDocTo $ Just $ selectRectangle mode selMode pos0 pos doc )
-                _ -> pure . Just $ selectAt mode selMode pos doc
+                _ -> pure ( UpdateDocTo $ Just $ selectAt mode selMode pos doc )
 
             Pen -> do
               mbPartialPath <- STM.readTVar partialPathTVar
               case mbPartialPath of
                 -- Normal pen mode mouse click should have created an anchor.
                 -- If no anchor exists, then just ignore the mouse release event.
-                Nothing -> pure Nothing
+                Nothing -> pure Don'tModifyDoc
                 -- Mouse click release possibilities:
                 --
                 --  - click was on complementary draw stroke draw anchor to close the path,
@@ -676,13 +696,13 @@ instance HandleAction MouseRelease where
                             pure $ ControlPoint cp ( PointData Normal Empty )
                         , Just ( PathPoint otherAnchorPt ( PointData Normal Empty ) )
                         ]
-                    pure ( Just $ addToAnchor anchor newSegment doc )
+                    pure ( UpdateDocTo $ Just $ addToAnchor anchor newSegment doc )
                   else
                     if firstPoint
                     -- Continue current partial path.
                     then do
                       STM.writeTVar partialPathTVar ( Just $ PartialPath p1        partialControlPoint anchor False )
-                      pure Nothing
+                      pure Don'tModifyDoc
                     -- Finish current partial path.
                     else do
                       STM.writeTVar partialPathTVar ( Just $ PartialPath pathPoint partialControlPoint anchor False )
@@ -702,7 +722,7 @@ instance HandleAction MouseRelease where
                               pure $ ControlPoint cp ( PointData Normal Empty )
                           , Just ( PathPoint pathPoint ( PointData Normal Empty ) )
                           ]
-                      pure ( Just $ addToAnchor anchor newSegment doc )
+                      pure ( UpdateDocTo $ Just $ addToAnchor anchor newSegment doc )
 
       -- Other mouse buttons: ignored (for the moment at least).
       _ -> pure ()
@@ -766,7 +786,7 @@ instance HandleAction Scroll where
           finalMousePos :: Point2D Double
           finalMousePos = toFinalViewport ( Point2D x y )
         STM.writeTVar mousePosTVar ( Just finalMousePos )
-        pure ( Just newDoc )
+        pure ( UpdateDocTo $ Just newDoc )
       updateInfoBar viewportDrawingArea infoBar vars
 
 --------------------
@@ -779,7 +799,7 @@ data KeyboardPress = KeyboardPress Word32
 instance HandleAction KeyboardPress where
   handleAction uiElts@( UIElements { .. } ) vars@( Variables { .. } ) ( KeyboardPress keyCode ) = do
 
-    _modifiers <- STM.atomically do
+    modifiers <- STM.atomically do
       !modifiers <- STM.readTVar modifiersTVar
       for_ ( modifierKey keyCode ) \ modifier ->
         ( STM.writeTVar modifiersTVar ( Set.insert modifier modifiers ) )
@@ -809,6 +829,14 @@ instance HandleAction KeyboardPress where
                   GTK.widgetQueueDraw viewportDrawingArea
             _ -> pure ()
 
+      -- todo: these should be handled by accelerator,
+      -- but those are not working currently
+      GDK.KEY_Delete -> handleAction uiElts vars Delete
+
+      GDK.KEY_s
+        | any ( \case { Control _ -> True; _ -> False } ) modifiers
+        -> handleAction uiElts vars Save
+
       _ -> pure ()
 
 ----------------------

src/app/MetaBrush/Context.hs

@@ -1,25 +1,27 @@
 {-# LANGUAGE BlockArguments     #-}
+{-# LANGUAGE ConstraintKinds    #-}
 {-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts   #-}
+{-# LANGUAGE LambdaCase         #-}
 {-# LANGUAGE OverloadedStrings  #-}
 {-# LANGUAGE RecordWildCards    #-}
 {-# LANGUAGE NamedFieldPuns     #-}
+{-# LANGUAGE TypeApplications   #-}
 
 module MetaBrush.Context
   ( UIElements(..), Variables(..)
   , LR(..), Modifier(..), modifierKey, modifierType
   , HoldAction(..), PartialPath(..)
-  , currentDocument, withCurrentDocument, modifyingCurrentDocument
+  , currentDocument, withCurrentDocument
+  , PureDocModification(..), DocModification(..)
+  , modifyingCurrentDocument
   , updateTitle
   )
   where
 
 -- base
-import Control.Monad
-  ( join )
 import Data.Foldable
   ( for_, sequenceA_ )
-import Data.Traversable
-  ( for )
 import Data.Word
   ( Word32 )
 
@@ -29,7 +31,7 @@ import Data.Set
 import Data.Map.Strict
   ( Map )
 import qualified Data.Map.Strict as Map
-  ( insert, lookup )
+  ( insert, lookup, delete )
 
 -- gi-gtk
 import qualified GI.Gdk as GDK
@@ -37,18 +39,28 @@ import qualified GI.Gdk as GDK
 -- gi-gtk
 import qualified GI.Gtk as GTK
 
+-- lens
+import Control.Lens.Fold
+  ( Fold, forOf_, sequenceAOf_ )
+
 -- stm
 import Control.Concurrent.STM
   ( STM )
 import qualified Control.Concurrent.STM as STM
   ( atomically )
 import qualified Control.Concurrent.STM.TVar as STM
-  ( TVar, readTVar, readTVar, writeTVar )
+  ( TVar, readTVar, readTVar, modifyTVar' )
 
 -- text
 import Data.Text
   ( Text )
 
+-- transformers
+import Control.Monad.Trans.Class
+  ( lift )
+import Control.Monad.Trans.Maybe
+  ( MaybeT(..) )
+
 -- MetaBrush
 import Math.Vector2D
   ( Point2D )
@@ -59,9 +71,9 @@ import MetaBrush.Document
 import MetaBrush.Document.Draw
   ( DrawAnchor )
 import {-# SOURCE #-} MetaBrush.UI.FileBar
-  ( FileBar )
+  ( FileBar, removeFileTab )
 import {-# SOURCE #-} MetaBrush.UI.InfoBar
-  ( InfoBar )
+  ( InfoBar, updateInfoBar )
 import MetaBrush.UI.ToolBar
   ( Tool, Mode )
 import MetaBrush.Unique
@@ -156,26 +168,60 @@ currentDocument ( Variables { activeDocumentTVar, openDocumentsTVar } )
 withCurrentDocument :: Variables -> ( Document -> STM a ) -> STM ( Maybe a )
 withCurrentDocument vars f = traverse f =<< currentDocument vars
 
+data PureDocModification
+  = Don'tModifyDoc
+  | UpdateDocTo ( Maybe Document )
+
+data DocModification
+  = Don'tModifyDocAndThen { postModifAction :: IO () }
+  | UpdateDocToAndThen
+    { modifDocument   :: ( Maybe Document )
+    , postModifAction :: IO ()
+    }
+
+class DocumentModification modif where
+  docFold    :: Fold modif ( Maybe Document )
+  actionFold :: Fold modif ( IO () )
+
+instance DocumentModification PureDocModification where
+  docFold _ Don'tModifyDoc      = pure Don'tModifyDoc
+  docFold f ( UpdateDocTo mbDoc ) = UpdateDocTo <$> ( f mbDoc )
+  actionFold _ a = pure a
+
+instance DocumentModification DocModification where
+  docFold _ don't@( Don'tModifyDocAndThen {} ) = pure don't
+  docFold f ( UpdateDocToAndThen mbDoc action ) = ( \ mbDoc' -> UpdateDocToAndThen mbDoc' action ) <$> f mbDoc 
+  actionFold f modif = ( \ action' -> modif { postModifAction = action' } ) <$> f ( postModifAction modif )
+
 -- | Modify the currently active document.
 --
 -- Does nothing if no document is currently active.
-modifyingCurrentDocument :: UIElements -> Variables -> ( Document -> STM ( Maybe Document ) ) -> IO ()
+modifyingCurrentDocument :: DocumentModification modif => UIElements -> Variables -> ( Document -> STM modif ) -> IO ()
-modifyingCurrentDocument ( UIElements { .. } ) ( Variables { .. } ) f = do
+modifyingCurrentDocument ( UIElements { .. } ) vars@( Variables { .. } ) f = do
-  mbActions <- STM.atomically do
+  mbAction <- STM.atomically . runMaybeT $ do
-    mbUnique <- STM.readTVar activeDocumentTVar
+    unique <- MaybeT ( STM.readTVar activeDocumentTVar )
-    for mbUnique \ unique -> do
+    oldDoc <- MaybeT ( Map.lookup unique <$> STM.readTVar openDocumentsTVar )
-      docs <- STM.readTVar openDocumentsTVar
+    modif <- lift ( f oldDoc )
-      mbUpdateTitleAction <-
+    forOf_ docFold modif \case
-        join <$> for ( Map.lookup unique docs ) \ oldDoc -> do
+      Nothing
-          mbNewDoc <- f oldDoc
+        -> lift ( STM.modifyTVar' openDocumentsTVar ( Map.delete unique ) )
-          for mbNewDoc \ newDoc -> do
+      Just newDoc
-            STM.writeTVar openDocumentsTVar ( Map.insert unique newDoc docs )
+        -> lift ( STM.modifyTVar' openDocumentsTVar ( Map.insert unique newDoc ) )
-            pure do
+    mbActiveTab <- lift ( Map.lookup unique <$> STM.readTVar fileBarTabsTVar )
-              updateTitle window title $ Just ( displayName newDoc, unsavedChanges newDoc )
+    pure
-              GTK.widgetQueueDraw viewportDrawingArea
+      do
-      mbActiveTab <- Map.lookup unique <$> STM.readTVar fileBarTabsTVar
+        forOf_ docFold modif \ mbNewDoc -> do
-      pure ( for_ mbActiveTab GTK.widgetQueueDraw *> sequenceA_ mbUpdateTitleAction )
+          case mbNewDoc of
-  sequenceA_ mbActions
+            Nothing -> do
+              removeFileTab vars ( documentUnique oldDoc )
+              updateTitle window title Nothing
+              updateInfoBar viewportDrawingArea infoBar vars
+            Just ( Document { displayName, unsavedChanges } ) -> do
+              updateTitle window title ( Just ( displayName, unsavedChanges ) )
+          GTK.widgetQueueDraw viewportDrawingArea
+        for_ mbActiveTab GTK.widgetQueueDraw
+        sequenceAOf_ actionFold modif
+  sequenceA_ mbAction
 
 updateTitle :: GTK.Window -> GTK.Label -> Maybe ( Text, Bool ) -> IO ()
 updateTitle window title mbTitleText = do

src/app/MetaBrush/UI/FileBar.hs

@@ -45,13 +45,11 @@ import MetaBrush.Asset.CloseTabButton
 import MetaBrush.Asset.Colours
   ( Colours )
 import MetaBrush.Context
-  ( UIElements(..), Variables(..)
+  ( UIElements(..), Variables(..) )
-  , updateTitle
-  )
 import MetaBrush.Document
   ( Document(..), emptyDocument )
 import {-# SOURCE #-} MetaBrush.UI.InfoBar
-  ( InfoBar, updateInfoBar )
+  ( InfoBar )
 import MetaBrush.Unique
   ( Unique, freshUnique, uniqueText )
 import MetaBrush.Util
@@ -234,29 +232,15 @@ createFileBar
     pure fileBar
 
 -- | Close a document: remove the corresponding file tab from the file bar.
-removeFileTab :: GTK.Window -> GTK.Label -> GTK.DrawingArea -> InfoBar -> Variables -> Unique -> IO ()
+removeFileTab :: Variables -> Unique -> IO ()
-removeFileTab window title viewportDrawingArea infoBar vars@( Variables { .. } ) docUnique = do
+removeFileTab ( Variables { .. } ) docUnique = do
 
-  cleanupActions <- STM.atomically do
+  cleanupAction <- STM.atomically do
     -- Remove the tab.
     mbTab <- Map.lookup docUnique <$> STM.readTVar fileBarTabsTVar
-    mbAction1 <- for mbTab \ tab -> do
+    for mbTab \ tab -> do
       STM.modifyTVar' openDocumentsTVar ( Map.delete docUnique )
       STM.modifyTVar' fileBarTabsTVar   ( Map.delete docUnique )
       pure ( GTK.widgetDestroy tab )
 
-    -- Update title and drawing area if we closed the active document.
+  sequenceA_ cleanupAction
-    mbActiveUnique <- STM.readTVar activeDocumentTVar
-    mbAction2 <- for mbActiveUnique \ activeUnique ->
-      if activeUnique == docUnique
-      then do
-        STM.writeTVar activeDocumentTVar Nothing
-        pure do
-          updateTitle window title Nothing
-          GTK.widgetQueueDraw viewportDrawingArea
-          updateInfoBar viewportDrawingArea infoBar vars
-      else pure ( pure () )
-
-
-    pure ( sequenceA_ mbAction1 *> sequenceA_ mbAction2 )
-  cleanupActions

src/app/MetaBrush/UI/FileBar.hs-boot

@@ -45,7 +45,4 @@ newFileTab
   -> Maybe Document -> TabLocation
   -> IO ()
 
-removeFileTab
+removeFileTab :: Variables -> Unique -> IO ()
-  :: GTK.Window -> GTK.Label -> GTK.DrawingArea -> InfoBar -> Variables
-  -> Unique
-  -> IO ()