hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-05 14:53:37 +00:00
Code Issues Actions Projects Releases Wiki Activity

refactor document modification

Browse source 
* the "modifyingCurrentDocument" now handles
    all the followup actions necessary after
    modifying the current document,
    such as updating the title bar
This commit is contained in:
sheaf 2020-09-05 02:56:59 +02:00
parent 264fa8dff0
commit a098eb6471
4 changed files with 170 additions and 115 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

152
src/app/MetaBrush/Action.hs
View file

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

98
src/app/MetaBrush/Context.hs
View file

@ -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

30
src/app/MetaBrush/UI/FileBar.hs
View file

@ -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

5
src/app/MetaBrush/UI/FileBar.hs-boot
View file

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