From a098eb64719c4b2a4125c3b2d28b5905ef257f34 Mon Sep 17 00:00:00 2001 From: sheaf Date: Sat, 5 Sep 2020 02:56:59 +0200 Subject: [PATCH] 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 | 152 ++++++++++++++++----------- src/app/MetaBrush/Context.hs | 98 ++++++++++++----- src/app/MetaBrush/UI/FileBar.hs | 30 ++---- src/app/MetaBrush/UI/FileBar.hs-boot | 5 +- 4 files changed, 170 insertions(+), 115 deletions(-) diff --git a/src/app/MetaBrush/Action.hs b/src/app/MetaBrush/Action.hs index aec572d..3b4904d 100644 --- a/src/app/MetaBrush/Action.hs +++ b/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 - mbDoc <- STM.atomically $ currentDocument vars - case mbDoc of - Nothing -> pure () -- could show a warning message - Just doc@( Document { mbFilePath, unsavedChanges } ) - | Nothing <- mbFilePath - -> saveAs uiElts vars True doc - | False <- unsavedChanges - -> pure () - | Just filePath <- mbFilePath - -> do - saveDocument filePath doc - STM.atomically $ - STM.modifyTVar' openDocumentsTVar - ( Map.insert ( documentUnique doc ) - ( doc { unsavedChanges = False } ) - ) + handleAction uiElts@( UIElements { .. } ) vars@( Variables { .. } ) _ = + save uiElts vars True + +save :: UIElements -> Variables -> Bool -> IO () +save uiElts vars keepOpen = do + mbDoc <- STM.atomically $ currentDocument vars + for_ mbDoc \case + doc@( Document { mbFilePath, unsavedChanges } ) + | Nothing <- mbFilePath + -> saveAs uiElts vars keepOpen + | False <- unsavedChanges + -> pure () + | Just filePath <- mbFilePath + -> modifyingCurrentDocument uiElts vars \ _ -> do + let + 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 - mbDoc <- STM.atomically $ currentDocument vars - case mbDoc of - Nothing -> pure () -- could show a warning message - Just doc -> saveAs uiElts vars True doc + handleAction uiElts vars _ = saveAs uiElts vars True -saveAs :: UIElements -> Variables -> Bool -> Document -> IO () -saveAs ( UIElements { .. } ) vars@( Variables { openDocumentsTVar } ) keepOpen doc = do +saveAs :: UIElements -> Variables -> Bool -> IO () +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 - for_ mbFilePath \ filePath -> do - -- set the document's new file path, and modify to indicate "no unsaved changes" - let - fullFilePath :: FilePath - fullFilePath - | ".mb" <- takeExtension filePath - = filePath + fmap fullFilePath . listToMaybe <$> GTK.fileChooserGetFilenames fileChooser + where + fullFilePath :: FilePath -> FilePath + fullFilePath fp + | ".mb" <- takeExtension fp + = fp | 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 window title viewportDrawingArea infoBar vars ( documentUnique doc ) + = fp <.> "mb" ----------- -- 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 - SaveAndClose -> saveAs uiElts vars False doc + JustClose -> closeDocument documentUnique + 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 . Just $ selectAt mode selMode pos doc + -> pure ( UpdateDocTo $ Just $ selectRectangle mode selMode pos0 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 () ---------------------- diff --git a/src/app/MetaBrush/Context.hs b/src/app/MetaBrush/Context.hs index d7fbf65..e6dc115 100644 --- a/src/app/MetaBrush/Context.hs +++ b/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 ( UIElements { .. } ) ( Variables { .. } ) f = do - mbActions <- STM.atomically do - mbUnique <- STM.readTVar activeDocumentTVar - for mbUnique \ unique -> do - docs <- STM.readTVar openDocumentsTVar - mbUpdateTitleAction <- - join <$> for ( Map.lookup unique docs ) \ oldDoc -> do - mbNewDoc <- f oldDoc - for mbNewDoc \ newDoc -> do - STM.writeTVar openDocumentsTVar ( Map.insert unique newDoc docs ) - pure do - updateTitle window title $ Just ( displayName newDoc, unsavedChanges newDoc ) - GTK.widgetQueueDraw viewportDrawingArea - mbActiveTab <- Map.lookup unique <$> STM.readTVar fileBarTabsTVar - pure ( for_ mbActiveTab GTK.widgetQueueDraw *> sequenceA_ mbUpdateTitleAction ) - sequenceA_ mbActions +modifyingCurrentDocument :: DocumentModification modif => UIElements -> Variables -> ( Document -> STM modif ) -> IO () +modifyingCurrentDocument ( UIElements { .. } ) vars@( Variables { .. } ) f = do + mbAction <- STM.atomically . runMaybeT $ do + unique <- MaybeT ( STM.readTVar activeDocumentTVar ) + oldDoc <- MaybeT ( Map.lookup unique <$> STM.readTVar openDocumentsTVar ) + modif <- lift ( f oldDoc ) + forOf_ docFold modif \case + Nothing + -> lift ( STM.modifyTVar' openDocumentsTVar ( Map.delete unique ) ) + Just newDoc + -> lift ( STM.modifyTVar' openDocumentsTVar ( Map.insert unique newDoc ) ) + mbActiveTab <- lift ( Map.lookup unique <$> STM.readTVar fileBarTabsTVar ) + pure + do + forOf_ docFold modif \ mbNewDoc -> do + case mbNewDoc of + 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 diff --git a/src/app/MetaBrush/UI/FileBar.hs b/src/app/MetaBrush/UI/FileBar.hs index 47b01b7..1033e3c 100644 --- a/src/app/MetaBrush/UI/FileBar.hs +++ b/src/app/MetaBrush/UI/FileBar.hs @@ -45,13 +45,11 @@ import MetaBrush.Asset.CloseTabButton import MetaBrush.Asset.Colours ( Colours ) import MetaBrush.Context - ( UIElements(..), Variables(..) - , updateTitle - ) + ( UIElements(..), Variables(..) ) 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 window title viewportDrawingArea infoBar vars@( Variables { .. } ) docUnique = do +removeFileTab :: Variables -> Unique -> IO () +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. - 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 + sequenceA_ cleanupAction diff --git a/src/app/MetaBrush/UI/FileBar.hs-boot b/src/app/MetaBrush/UI/FileBar.hs-boot index 9b3e07b..378f16f 100644 --- a/src/app/MetaBrush/UI/FileBar.hs-boot +++ b/src/app/MetaBrush/UI/FileBar.hs-boot @@ -45,7 +45,4 @@ newFileTab -> Maybe Document -> TabLocation -> IO () -removeFileTab - :: GTK.Window -> GTK.Label -> GTK.DrawingArea -> InfoBar -> Variables - -> Unique - -> IO () +removeFileTab :: Variables -> Unique -> IO ()