diff --git a/MetaBrush.cabal b/MetaBrush.cabal index 2a67f47..36757ae 100644 --- a/MetaBrush.cabal +++ b/MetaBrush.cabal @@ -32,6 +32,8 @@ common common ^>= 0.3.1.0 , containers >= 0.6.0.1 && < 0.6.4 + , deepseq + ^>= 1.4.4.0 , generic-data >= 0.8.0.0 && < 0.8.4.0 , generic-lens @@ -45,7 +47,7 @@ common common Haskell2010 ghc-options: - -O2 + -O1 -fexpose-all-unfoldings -fspecialise-aggressively -Wall @@ -77,9 +79,7 @@ library , Math.Vector2D build-depends: - deepseq - ^>= 1.4.4.0 - , groups-generic + groups-generic ^>= 0.1.0.0 , hmatrix ^>= 0.20.0.0 @@ -114,9 +114,11 @@ executable MetaBrush , MetaBrush.Context , MetaBrush.Document , MetaBrush.Document.Draw + , MetaBrush.Document.History , MetaBrush.Document.Selection , MetaBrush.Document.Serialise , MetaBrush.Document.SubdivideStroke + , MetaBrush.Document.Update , MetaBrush.Event , MetaBrush.Render.Document , MetaBrush.Render.Rulers diff --git a/app/Main.hs b/app/Main.hs index cb6cbd9..d5c6c18 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE OverloadedStrings #-} @@ -16,6 +17,8 @@ import Control.Monad ( void ) import Data.Foldable ( for_ ) +import Data.Function + ( (&) ) import Data.Int ( Int32 ) import System.Exit @@ -41,6 +44,10 @@ import qualified Data.Set as Set import qualified System.Directory as Directory ( canonicalizePath ) +-- generic-lens +import Data.Generics.Product.Fields + ( field' ) + -- gi-cairo-connector import qualified GI.Cairo.Render.Connector as Cairo ( renderWithContext ) @@ -51,6 +58,10 @@ import qualified GI.Gdk as GDK -- gi-gtk import qualified GI.Gtk as GTK +-- lens +import Control.Lens + ( (.~) ) + -- stm import qualified Control.Concurrent.STM as STM ( atomically ) @@ -80,13 +91,16 @@ import MetaBrush.Context ( UIElements(..), Variables(..) , Modifier(..) , HoldAction(..), PartialPath(..) - , withCurrentDocument ) import MetaBrush.Document ( Document(..), emptyDocument , Stroke(..), FocusState(..) , PointData(..), BrushPointData(..) ) +import MetaBrush.Document.History + ( DocumentHistory(..), newHistory ) +import MetaBrush.Document.Update + ( activeDocument, withActiveDocument ) import MetaBrush.Event ( handleEvents ) import MetaBrush.Render.Document @@ -117,38 +131,35 @@ import qualified Paths_MetaBrush as Cabal -------------------------------------------------------------------------------- -testDocuments :: Map Unique Document -testDocuments = uniqueMapFromList - [ ( emptyDocument "Closed" ( unsafeUnique 0 ) ) - { strokes = - [ Stroke - { strokeName = "Ellipse" - , strokeVisible = True - , strokeUnique = unsafeUnique 10 - , strokePoints = ellipse 150 100 ( PointData Normal ( rect 30 6 $ BrushPointData Normal ) ) - } - ] - } - , ( emptyDocument "Line" ( unsafeUnique 1 ) ) - { strokes = - [ Stroke - { strokeName = "Line" - , strokeVisible = True - , strokeUnique = unsafeUnique 11 - , strokePoints = linePts - } - ] - } - , ( emptyDocument "Short line" ( unsafeUnique 2 ) ) - { strokes = - [ Stroke - { strokeName = "ShortLine" - , strokeVisible = True - , strokeUnique = unsafeUnique 12 - , strokePoints = linePts2 - } - ] - } +testDocuments :: Map Unique DocumentHistory +testDocuments = fmap newHistory $ uniqueMapFromList + [ emptyDocument "Closed" ( unsafeUnique 0 ) + & ( field' @"documentContent" . field' @"strokes" ) .~ + [ Stroke + { strokeName = "Ellipse" + , strokeVisible = True + , strokeUnique = unsafeUnique 10 + , strokePoints = ellipse 150 100 ( PointData Normal ( rect 30 6 $ BrushPointData Normal ) ) + } + ] + , emptyDocument "Line" ( unsafeUnique 1 ) + & ( field' @"documentContent" . field' @"strokes" ) .~ + [ Stroke + { strokeName = "Line" + , strokeVisible = True + , strokeUnique = unsafeUnique 11 + , strokePoints = linePts + } + ] + , emptyDocument "Short line" ( unsafeUnique 2 ) + & ( field' @"documentContent" . field' @"strokes" ) .~ + [ Stroke + { strokeName = "ShortLine" + , strokeVisible = True + , strokeUnique = unsafeUnique 12 + , strokePoints = linePts2 + } + ] ] where linePts :: Seq ( StrokePoint PointData ) @@ -189,16 +200,17 @@ main = do -- Initialise state uniqueSupply <- newUniqueSupply - activeDocumentTVar <- STM.newTVarIO @( Maybe Unique ) Nothing - openDocumentsTVar <- STM.newTVarIO @( Map Unique Document ) testDocuments - mousePosTVar <- STM.newTVarIO @( Maybe ( Point2D Double ) ) Nothing - mouseHoldTVar <- STM.newTVarIO @( Maybe HoldAction ) Nothing - modifiersTVar <- STM.newTVarIO @( Set Modifier ) Set.empty - toolTVar <- STM.newTVarIO @Tool Selection - modeTVar <- STM.newTVarIO @Mode Path - partialPathTVar <- STM.newTVarIO @( Maybe PartialPath ) Nothing - fileBarTabsTVar <- STM.newTVarIO @( Map Unique GTK.Box ) Map.empty - showGuidesTVar <- STM.newTVarIO @Bool True + activeDocumentTVar <- STM.newTVarIO @( Maybe Unique ) Nothing + openDocumentsTVar <- STM.newTVarIO @( Map Unique DocumentHistory ) testDocuments + mousePosTVar <- STM.newTVarIO @( Maybe ( Point2D Double ) ) Nothing + mouseHoldTVar <- STM.newTVarIO @( Maybe HoldAction ) Nothing + modifiersTVar <- STM.newTVarIO @( Set Modifier ) Set.empty + toolTVar <- STM.newTVarIO @Tool Selection + modeTVar <- STM.newTVarIO @Mode Path + partialPathTVar <- STM.newTVarIO @( Maybe PartialPath ) Nothing + fileBarTabsTVar <- STM.newTVarIO @( Map Unique ( GTK.Box, GTK.RadioButton ) ) Map.empty + showGuidesTVar <- STM.newTVarIO @Bool True + maxHistorySizeTVar <- STM.newTVarIO @Int 1000 fitParametersTVar <- STM.newTVarIO @FitParameters ( FitParameters { maxSubdiv = 2 @@ -319,7 +331,7 @@ main = do -- Get the relevant document information viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea - mbRender <- STM.atomically $ withCurrentDocument variables \ doc@( Document {..} ) -> do + mbRender <- STM.atomically $ withActiveDocument variables \ doc@( Document {..} ) -> do mbMousePos <- STM.readTVar mousePosTVar mbHoldAction <- STM.readTVar mouseHoldTVar mbPartialPath <- STM.readTVar partialPathTVar @@ -350,7 +362,7 @@ main = do viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea width <- GTK.widgetGetAllocatedWidth rulerDrawingArea height <- GTK.widgetGetAllocatedHeight rulerDrawingArea - mbRender <- STM.atomically $ withCurrentDocument variables \ doc@( Document {..} ) -> do + mbRender <- STM.atomically $ withActiveDocument variables \ doc@( Document {..} ) -> do mbMousePos <- STM.readTVar mousePosTVar mbHoldAction <- STM.readTVar mouseHoldTVar showGuides <- STM.readTVar showGuidesTVar @@ -411,7 +423,8 @@ main = do -- GTK main loop GTK.widgetShowAll window - updateInfoBar viewportDrawingArea infoBar variables -- need to update the info bar after widgets have been realized + mbDoc <- fmap present <$> ( STM.atomically $ activeDocument variables ) + updateInfoBar viewportDrawingArea infoBar variables mbDoc -- need to update the info bar after widgets have been realized GTK.main exitSuccess diff --git a/cabal.project b/cabal.project index 8bf8a5f..2745e04 100644 --- a/cabal.project +++ b/cabal.project @@ -9,9 +9,9 @@ allow-newer: -- fixes gi-cairo-render to work with haskell-gi >= 0.24 source-repository-package type: git - location: https://github.com/thestr4ng3r/gi-cairo-render - tag: 8727c43cdf91aeedffc9cb4c5575f56660a86399 - subdir: gi-cairo-render + location: https://github.com/sheaf/gi-cairo-render + tag: a53d1596e36ce7bbff517940260faf1c4d02ffcc + subdir: gi-cairo-render gi-cairo-connector -- latest version of hmatrix source-repository-package diff --git a/installation_notes.md b/installation_notes.md index 9a6f466..dd65689 100644 --- a/installation_notes.md +++ b/installation_notes.md @@ -93,7 +93,7 @@ Libs: -L${libdir} -lgraphite2 Cflags: -I${includedir} ``` -The package `fontconfig` also presented this issue; this was resolved in [this patch](https://github.com/msys2/MINGW-packages/issues/872). +See [this patch](https://github.com/msys2/MINGW-packages/pull/6966). The package `fontconfig` also presented this issue; this was resolved in [this patch](https://github.com/msys2/MINGW-packages/issues/872). ### Missing C library `openblas` diff --git a/src/app/MetaBrush/Action.hs b/src/app/MetaBrush/Action.hs index 3846e29..0d29572 100644 --- a/src/app/MetaBrush/Action.hs +++ b/src/app/MetaBrush/Action.hs @@ -9,6 +9,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} @@ -18,7 +19,7 @@ module MetaBrush.Action where import Control.Monad ( guard, when, unless, void ) import Data.Foldable - ( for_ ) + ( for_, sequenceA_ ) import Data.Int ( Int32 ) import Data.Maybe @@ -36,7 +37,7 @@ import Data.Act -- containers import qualified Data.Map as Map - ( lookup ) + ( insert, lookup ) import Data.Sequence ( Seq(..) ) import qualified Data.Sequence as Seq @@ -77,6 +78,8 @@ import qualified Control.Concurrent.STM.TVar as STM -- text import Data.Text ( Text ) +import qualified Data.Text as Text + ( pack ) -- MetaBrush import Math.Bezier.Stroke @@ -89,17 +92,17 @@ import MetaBrush.Context ( UIElements(..), Variables(..) , Modifier(..), modifierKey , HoldAction(..), GuideAction(..), PartialPath(..) - , currentDocument, withCurrentDocument - , PureDocModification(..), DocModification(..) - , modifyingCurrentDocument - , updateTitle ) import MetaBrush.Document - ( Document(..), PointData(..), FocusState(..) ) + ( Document(..), DocumentContent(..), PointData(..), FocusState(..) ) import MetaBrush.Document.Draw ( addToAnchor, getOrCreateDrawAnchor, anchorsAreComplementary ) import MetaBrush.Document ( Guide(..), selectedGuide, addGuide ) +import MetaBrush.Document.History + ( DocumentHistory(..), newHistory + , back, fwd + ) import MetaBrush.Document.Selection ( SelectionMode(..), selectionMode , selectAt, selectRectangle @@ -111,6 +114,12 @@ import MetaBrush.Document.Serialise ( saveDocument, loadDocument ) import MetaBrush.Document.SubdivideStroke ( subdivide ) +import MetaBrush.Document.Update + ( activeDocument, withActiveDocument + , DocChange(..), DocumentUpdate(..), PureDocModification(..), DocModification(..) + , modifyingCurrentDocument + , updateUIAction, updateHistoryState + ) import MetaBrush.UI.Coordinates ( toViewportCoordinates ) import MetaBrush.UI.InfoBar @@ -148,7 +157,7 @@ data NewFile = NewFile TabLocation instance HandleAction NewFile where handleAction uiElts vars ( NewFile tabLoc ) = - newFileTab uiElts vars Nothing tabLoc + newFileTab False uiElts vars Nothing tabLoc --------------- -- Open file -- @@ -175,9 +184,29 @@ instance HandleAction OpenFile where for_ filePaths \ filePath -> do mbDoc <- loadDocument uniqueSupply filePath case mbDoc of - Left _errMessage -> pure () -- TODO: show warning dialog? + Left errMessage -> warningDialog window filePath errMessage Right doc -> do - newFileTab uiElts vars ( Just doc ) tabLoc + let + newDocHist :: DocumentHistory + newDocHist = newHistory doc + newFileTab False uiElts vars ( Just newDocHist ) tabLoc + updateHistoryState uiElts ( Just newDocHist ) + +warningDialog :: Show errMess => GTK.Window -> FilePath -> errMess -> IO () +warningDialog window filePath errMess = do + dialog <- GTK.new GTK.MessageDialog [] + GTK.setMessageDialogText dialog + ( "Could not load file at " <> Text.pack filePath <> ":\n" <> Text.pack ( show errMess ) ) + GTK.setMessageDialogMessageType dialog GTK.MessageTypeWarning + GTK.setWindowResizable dialog False + GTK.setWindowDecorated dialog False + GTK.windowSetTransientFor dialog ( Just window ) + GTK.windowSetModal dialog True + widgetAddClasses dialog [ "bg", "plain", "text", "dialog" ] + closeButton <- GTK.dialogAddButton dialog "OK" 1 + widgetAddClass closeButton "dialogButton" + _ <- GTK.dialogRun dialog + GTK.widgetDestroy dialog ----------------- -- Open folder -- @@ -204,9 +233,13 @@ instance HandleAction OpenFolder where for_ filePaths \ filePath -> when ( takeExtension filePath == ".mb" ) do mbDoc <- loadDocument uniqueSupply ( folderPath filePath ) case mbDoc of - Left _errMessage -> pure () -- TODO: show warning dialog? + Left errMessage -> warningDialog window filePath errMessage Right doc -> do - newFileTab uiElts vars ( Just doc ) tabLoc + let + newDocHist :: DocumentHistory + newDocHist = newHistory doc + newFileTab False uiElts vars ( Just newDocHist ) tabLoc + updateHistoryState uiElts ( Just newDocHist ) pure () --------------- @@ -222,25 +255,19 @@ instance HandleAction Save where save :: UIElements -> Variables -> Bool -> IO () save uiElts vars keepOpen = do - mbDoc <- STM.atomically $ currentDocument vars + mbDoc <- fmap present <$> ( STM.atomically $ activeDocument vars ) for_ mbDoc \case - doc@( Document { mbFilePath, unsavedChanges } ) + doc@( Document { mbFilePath, documentContent } ) | Nothing <- mbFilePath -> saveAs uiElts vars keepOpen - | False <- unsavedChanges + | False <- unsavedChanges documentContent -> 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' ) + modif :: DocumentUpdate + modif = if keepOpen then SaveDocument Nothing else CloseDocument + pure $ UpdateDocAndThen modif ( saveDocument filePath doc ) ------------- -- Save as -- @@ -258,15 +285,9 @@ saveAs uiElts vars keepOpen = do 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' ) + modif :: DocumentUpdate + modif = if keepOpen then SaveDocument ( Just savePath ) else CloseDocument + pure $ UpdateDocAndThen modif ( saveDocument savePath doc ) askForSavePath :: UIElements -> IO ( Maybe FilePath ) askForSavePath ( UIElements {..} ) = do @@ -312,12 +333,15 @@ instance HandleAction Close where vars@( Variables {..} ) close = do mbDoc <- case close of - CloseActive -> STM.atomically ( currentDocument vars ) - CloseThis unique -> Map.lookup unique <$> STM.readTVarIO openDocumentsTVar + CloseActive -> fmap ( ( , True ) . present ) <$> STM.atomically ( activeDocument vars ) + CloseThis unique -> do + mbCurrentDoc <- fmap present <$> STM.atomically ( activeDocument vars ) + mbDoc <- fmap present . Map.lookup unique <$> STM.readTVarIO openDocumentsTVar + pure ( ( \ doc currDoc -> ( doc, documentUnique currDoc == unique ) ) <$> mbDoc <*> mbCurrentDoc ) case mbDoc of Nothing -> pure () -- could show a warning message - Just ( Document { displayName, documentUnique, unsavedChanges } ) - | unsavedChanges + Just ( Document { displayName, documentUnique, documentContent }, isActiveDoc ) + | unsavedChanges documentContent -> do dialog <- GTK.new GTK.MessageDialog [] GTK.setMessageDialogText dialog ( " \n\"" <> displayName <> "\" contains unsaved changes.\nClose anyway?" ) @@ -335,19 +359,24 @@ instance HandleAction Close where choice <- GTK.dialogRun dialog GTK.widgetDestroy dialog case choice of - JustClose -> closeDocument documentUnique + JustClose -> closeDocument isActiveDoc documentUnique SaveAndClose -> save uiElts vars False _ -> pure () | otherwise - -> closeDocument documentUnique + -> closeDocument isActiveDoc documentUnique where - closeDocument :: Unique -> IO () - closeDocument unique = do + closeDocument :: Bool -> Unique -> IO () + closeDocument isActiveDoc unique = do removeFileTab vars unique - updateTitle window title Nothing - updateInfoBar viewportDrawingArea infoBar vars - GTK.widgetQueueDraw viewportDrawingArea + when isActiveDoc do + uiUpdateAction <- STM.atomically do + STM.writeTVar activeDocumentTVar Nothing + uiUpdateAction <- updateUIAction uiElts vars + pure do + uiUpdateAction + updateHistoryState uiElts Nothing + uiUpdateAction --------------------- -- Switch document -- @@ -358,21 +387,17 @@ data SwitchTo = SwitchTo Unique instance HandleAction SwitchTo where handleAction - ( UIElements { viewport = Viewport {..}, .. } ) + uiElts@( UIElements { viewport = Viewport {..}, .. } ) vars@( Variables {..} ) ( SwitchTo newUnique ) = do - mbNewDocAndTab <- STM.atomically do + uiUpdateAction <- STM.atomically do STM.writeTVar activeDocumentTVar ( Just newUnique ) - newDoc <- Map.lookup newUnique <$> STM.readTVar openDocumentsTVar - newTab <- Map.lookup newUnique <$> STM.readTVar fileBarTabsTVar - pure ( (,) <$> newDoc <*> newTab ) - case mbNewDocAndTab of - Nothing -> updateTitle window title Nothing - Just ( Document {..}, tab ) -> do - updateTitle window title ( Just ( displayName, unsavedChanges ) ) - updateInfoBar viewportDrawingArea infoBar vars - GTK.widgetQueueDraw tab - GTK.widgetQueueDraw viewportDrawingArea + mbHist <- Map.lookup newUnique <$> STM.readTVar openDocumentsTVar + uiUpdateAction <- updateUIAction uiElts vars + pure do + uiUpdateAction + updateHistoryState uiElts mbHist + uiUpdateAction -------------- -- Quitting -- @@ -387,38 +412,43 @@ instance HandleAction Quit where quitEverything :: GTK.Window -> IO () quitEverything window = GTK.widgetDestroy window *> GTK.mainQuit ----------- --- Undo -- ----------- +---------------- +-- Undo & Redo -- +---------------- data Undo = Undo deriving stock Show --- TODO instance HandleAction Undo where - handleAction _ _ _ = pure () + handleAction uiElts@( UIElements {..} ) vars@( Variables {..} ) _ = updateHistory back uiElts vars ----------- --- Redo -- ----------- data Redo = Redo deriving stock Show --- TODO instance HandleAction Redo where - handleAction _ _ _ = pure () + handleAction uiElts@( UIElements {..} ) vars@( Variables {..} ) _ = updateHistory fwd uiElts vars ---------------------- --- Discard changes -- ---------------------- - -data DiscardChanges = DiscardChanges - deriving stock Show - --- TODO -instance HandleAction DiscardChanges where - handleAction _ _ _ = pure () +updateHistory :: ( DocumentHistory -> DocumentHistory ) -> UIElements -> Variables -> IO () +updateHistory f uiElts@( UIElements {..} ) vars@( Variables {..} ) = do + uiUpdateAction <- STM.atomically do + mbUnique <- STM.readTVar activeDocumentTVar + case mbUnique of + Nothing -> pure ( pure () ) + Just unique -> do + mbDocHistory <- Map.lookup unique <$> STM.readTVar openDocumentsTVar + case mbDocHistory of + Nothing -> pure ( pure () ) + Just docHistory -> do + let + newDocHistory :: DocumentHistory + newDocHistory = f docHistory + STM.modifyTVar' openDocumentsTVar ( Map.insert unique newDocHistory ) + uiUpdateAction <- updateUIAction uiElts vars + pure do + updateHistoryState uiElts ( Just newDocHistory ) + uiUpdateAction + uiUpdateAction --------- -- Cut -- @@ -482,8 +512,14 @@ instance HandleAction Delete where case tool of -- Delete selected points on pressing 'Delete'. Selection - -> modifyingCurrentDocument uiElts vars \ doc -> - pure ( UpdateDocTo $ Just ( deleteSelected mode doc ) ) + -> modifyingCurrentDocument uiElts vars \ doc -> do + let + newDoc :: Document + docChanged :: Bool + ( newDoc, docChanged ) = deleteSelected mode doc + if docChanged + then pure $ UpdateDoc ( UpdateDocumentTo $ HistoryChange newDoc ) + else pure Don'tModifyDoc _ -> pure () ------------------- @@ -559,7 +595,7 @@ instance HandleAction MouseMove where = do viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea - void . STM.atomically $ withCurrentDocument vars \ ( Document {..} ) -> do + uiUpdateAction <- STM.atomically $ withActiveDocument vars \ doc@( Document {..} ) -> do modifiers <- STM.readTVar modifiersTVar let toViewport :: Point2D Double -> Point2D Double @@ -578,11 +614,12 @@ instance HandleAction MouseMove where , Just pp <- mbPartialPath -> STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just pos } ) _ -> pure () - - updateInfoBar viewportDrawingArea infoBar vars - GTK.widgetQueueDraw viewportDrawingArea - for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do - GTK.widgetQueueDraw drawingArea + pure do + updateInfoBar viewportDrawingArea infoBar vars ( Just doc ) + GTK.widgetQueueDraw viewportDrawingArea + for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do + GTK.widgetQueueDraw drawingArea + sequenceA_ uiUpdateAction ----------------- -- Mouse click -- @@ -641,7 +678,7 @@ instance HandleAction MouseClick where | Just newDoc <- dragMoveSelect mode pos doc -> do STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos ) - pure ( UpdateDocTo $ Just newDoc ) + pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc ) -- Rectangular selection. _ -> do STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos ) @@ -663,7 +700,7 @@ instance HandleAction MouseClick where , firstPoint = True } ) - pure ( UpdateDocTo $ Just newDoc ) + pure ( UpdateDoc . UpdateDocumentTo . HistoryChange $ newDoc ) -- Path already started: indicate that we are continuing a path. Just pp -> do STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } ) @@ -683,7 +720,7 @@ instance HandleAction MouseClick where mbSubdivide = subdivide mode pos doc case mbSubdivide of Nothing -> pure Don'tModifyDoc - Just newDoc -> pure ( UpdateDocTo $ Just newDoc ) + Just newDoc -> pure ( UpdateDoc . UpdateDocumentTo . HistoryChange $ newDoc ) -- Ignore double click event otherwise. _ -> pure Don'tModifyDoc @@ -759,11 +796,11 @@ instance HandleAction MouseRelease where | keepGuide -> pure $ over - ( field' @"guides" . ix guideUnique . field' @"guidePoint" ) + ( field' @"documentContent" . field' @"guides" . ix guideUnique . field' @"guidePoint" ) ( ( holdStartPos --> pos :: Vector2D Double ) • ) doc | otherwise - -> pure $ set ( field' @"guides" . at guideUnique ) Nothing doc + -> pure $ set ( field' @"documentContent" . field' @"guides" . at guideUnique ) Nothing doc where l, t :: Double Point2D l t = toViewport ( Point2D 0 0 ) @@ -773,7 +810,7 @@ instance HandleAction MouseRelease where && ( y >= 0 || hy < t ) -- so we must compare it to the point (l,t) instead of (0,0) && x <= viewportWidth && y <= viewportHeight - pure ( UpdateDocTo ( Just newDoc ) ) + pure ( UpdateDoc . UpdateDocumentTo . HistoryChange $ newDoc ) _ -> do tool <- STM.readTVar toolTVar @@ -788,11 +825,17 @@ instance HandleAction MouseRelease where Just hold | DragMoveHold pos0 <- hold , pos0 /= pos - -> pure ( UpdateDocTo $ Just $ translateSelection mode ( pos0 --> pos ) doc ) + , let + newDoc :: Document + docChanged :: Bool + ( newDoc, docChanged ) = translateSelection mode ( pos0 --> pos ) doc + -> if docChanged + then pure ( UpdateDoc . UpdateDocumentTo . HistoryChange $ newDoc ) + else pure Don'tModifyDoc | SelectionHold pos0 <- hold , pos0 /= pos - -> pure ( UpdateDocTo $ Just $ selectRectangle mode selMode pos0 pos doc ) - _ -> pure ( UpdateDocTo $ Just $ selectAt mode selMode pos doc ) + -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectRectangle mode selMode pos0 pos doc ) + _ -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectAt mode selMode pos doc ) Pen -> do mbPartialPath <- STM.readTVar partialPathTVar @@ -843,7 +886,7 @@ instance HandleAction MouseRelease where pure $ ControlPoint cp ( PointData Normal Empty ) , Just ( PathPoint otherAnchorPt ( PointData Normal Empty ) ) ] - pure ( UpdateDocTo $ Just $ addToAnchor anchor newSegment doc ) + pure ( UpdateDoc . UpdateDocumentTo . HistoryChange $ addToAnchor anchor newSegment doc ) else if firstPoint -- Continue current partial path. @@ -869,7 +912,7 @@ instance HandleAction MouseRelease where pure $ ControlPoint cp ( PointData Normal Empty ) , Just ( PathPoint pathPoint ( PointData Normal Empty ) ) ] - pure ( UpdateDocTo $ Just $ addToAnchor anchor newSegment doc ) + pure ( UpdateDoc . UpdateDocumentTo . HistoryChange $ addToAnchor anchor newSegment doc ) -- Other mouse buttons: ignored (for the moment at least). _ -> pure () @@ -936,8 +979,7 @@ instance HandleAction Scroll where finalMousePos :: Point2D Double finalMousePos = toFinalViewport ( Point2D x y ) STM.writeTVar mousePosTVar ( Just finalMousePos ) - pure ( UpdateDocTo $ Just newDoc ) - updateInfoBar viewportDrawingArea infoBar vars + pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc ) -------------------- -- Keyboard press -- diff --git a/src/app/MetaBrush/Action.hs-boot b/src/app/MetaBrush/Action.hs-boot index cfea934..ab0058b 100644 --- a/src/app/MetaBrush/Action.hs-boot +++ b/src/app/MetaBrush/Action.hs-boot @@ -60,9 +60,6 @@ instance HandleAction Undo data Redo = Redo instance HandleAction Redo -data DiscardChanges = DiscardChanges -instance HandleAction DiscardChanges - data Cut = Cut instance HandleAction Cut diff --git a/src/app/MetaBrush/Context.hs b/src/app/MetaBrush/Context.hs index 0648dc3..31fd953 100644 --- a/src/app/MetaBrush/Context.hs +++ b/src/app/MetaBrush/Context.hs @@ -1,27 +1,14 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NamedFieldPuns #-} module MetaBrush.Context ( UIElements(..), Variables(..) , LR(..), Modifier(..), modifierKey, modifierType , HoldAction(..), GuideAction(..), PartialPath(..) - , currentDocument, withCurrentDocument - , PureDocModification(..), DocModification(..) - , modifyingCurrentDocument - , updateTitle ) where -- base -import Data.Foldable - ( for_, sequenceA_ ) import Data.Word ( Word32 ) @@ -30,8 +17,6 @@ import Data.Set ( Set ) import Data.Map.Strict ( Map ) -import qualified Data.Map.Strict as Map - ( insert, lookup, delete ) -- gi-gtk import qualified GI.Gdk as GDK @@ -39,27 +24,9 @@ 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, modifyTVar' ) - --- text -import Data.Text - ( Text ) - --- transformers -import Control.Monad.Trans.Class - ( lift ) -import Control.Monad.Trans.Maybe - ( MaybeT(..) ) + ( TVar ) -- MetaBrush import Math.Bezier.Cubic.Fit @@ -68,14 +35,14 @@ import Math.Vector2D ( Point2D ) import MetaBrush.Asset.Colours ( Colours ) -import MetaBrush.Document - ( Document(..) ) import MetaBrush.Document.Draw ( DrawAnchor ) +import MetaBrush.Document.History + ( DocumentHistory(..) ) import {-# SOURCE #-} MetaBrush.UI.FileBar - ( FileBar, removeFileTab ) + ( FileBar ) import {-# SOURCE #-} MetaBrush.UI.InfoBar - ( InfoBar, updateInfoBar ) + ( InfoBar ) import {-# SOURCE #-} MetaBrush.UI.Menu ( Menu, ResourceType(Object) ) import MetaBrush.UI.ToolBar @@ -84,8 +51,6 @@ import MetaBrush.UI.Viewport ( Viewport(..), Ruler(..) ) import MetaBrush.Unique ( UniqueSupply, Unique ) -import MetaBrush.Util - ( (>>?=) ) -------------------------------------------------------------------------------- @@ -104,17 +69,18 @@ data UIElements data Variables = Variables { uniqueSupply :: !UniqueSupply - , activeDocumentTVar :: !( STM.TVar ( Maybe Unique ) ) - , openDocumentsTVar :: !( STM.TVar ( Map Unique Document ) ) - , mousePosTVar :: !( STM.TVar ( Maybe ( Point2D Double ) ) ) - , mouseHoldTVar :: !( STM.TVar ( Maybe HoldAction ) ) - , modifiersTVar :: !( STM.TVar ( Set Modifier ) ) - , toolTVar :: !( STM.TVar Tool ) - , modeTVar :: !( STM.TVar Mode ) - , partialPathTVar :: !( STM.TVar ( Maybe PartialPath ) ) - , fileBarTabsTVar :: !( STM.TVar ( Map Unique GTK.Box ) ) - , showGuidesTVar :: !( STM.TVar Bool ) - , fitParametersTVar :: !( STM.TVar FitParameters ) + , activeDocumentTVar :: !( STM.TVar ( Maybe Unique ) ) + , openDocumentsTVar :: !( STM.TVar ( Map Unique DocumentHistory ) ) + , mousePosTVar :: !( STM.TVar ( Maybe ( Point2D Double ) ) ) + , mouseHoldTVar :: !( STM.TVar ( Maybe HoldAction ) ) + , modifiersTVar :: !( STM.TVar ( Set Modifier ) ) + , toolTVar :: !( STM.TVar Tool ) + , modeTVar :: !( STM.TVar Mode ) + , partialPathTVar :: !( STM.TVar ( Maybe PartialPath ) ) + , fileBarTabsTVar :: !( STM.TVar ( Map Unique ( GTK.Box, GTK.RadioButton ) ) ) + , showGuidesTVar :: !( STM.TVar Bool ) + , maxHistorySizeTVar :: !( STM.TVar Int ) + , fitParametersTVar :: !( STM.TVar FitParameters ) } -------------------------------------------------------------------------------- @@ -172,88 +138,3 @@ data PartialPath , firstPoint :: !Bool } deriving stock Show - --------------------------------------------------------------------------------- - --- | Read the currently active document from the stateful variables. -currentDocument :: Variables -> STM ( Maybe Document ) -currentDocument ( Variables { activeDocumentTVar, openDocumentsTVar } ) - = STM.readTVar activeDocumentTVar - >>?= ( \ unique -> Map.lookup unique <$> STM.readTVar openDocumentsTVar ) - --- | Do something with the currently active document. --- --- Does nothing if no document is currently active. -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 :: DocumentModification modif => UIElements -> Variables -> ( Document -> STM modif ) -> IO () -modifyingCurrentDocument ( UIElements { viewport = Viewport {..}, .. } ) 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_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do - GTK.widgetQueueDraw drawingArea - for_ mbActiveTab GTK.widgetQueueDraw - sequenceAOf_ actionFold modif - sequenceA_ mbAction - -updateTitle :: GTK.Window -> GTK.Label -> Maybe ( Text, Bool ) -> IO () -updateTitle window title mbTitleText = do - GTK.labelSetText title titleText - GTK.setWindowTitle window titleText - where - titleText :: Text - titleText = case mbTitleText of - Nothing -> "MetaBrush" - Just ( name, hasUnsavedChanges ) - | hasUnsavedChanges - -> "● " <> name <> " – MetaBrush" - | otherwise - -> name <> " – MetaBrush" diff --git a/src/app/MetaBrush/Document.hs b/src/app/MetaBrush/Document.hs index 3f507a0..eae6384 100644 --- a/src/app/MetaBrush/Document.hs +++ b/src/app/MetaBrush/Document.hs @@ -1,17 +1,20 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} module MetaBrush.Document ( AABB(..), mkAABB - , Document(..), emptyDocument + , Document(..), DocumentContent(..) + , emptyDocument , Stroke(..) , PointData(..), BrushPointData(..) , FocusState(..), Hoverable(..), HoverContext(..) @@ -45,6 +48,10 @@ import qualified Data.Map.Strict as Map import Data.Sequence ( Seq ) +-- deepseq +import Control.DeepSeq + ( NFData ) + -- generic-lens import Data.Generics.Product.Fields ( field' ) @@ -80,7 +87,8 @@ import MetaBrush.Unique data AABB = AABB { topLeft, botRight :: !( Point2D Double ) } - deriving stock Show + deriving stock ( Show, Generic ) + deriving anyclass NFData mkAABB :: Point2D Double -> Point2D Double -> AABB mkAABB ( Point2D x1 y1 ) ( Point2D x2 y2 ) = AABB ( Point2D xmin ymin ) ( Point2D xmax ymax ) @@ -92,18 +100,29 @@ mkAABB ( Point2D x1 y1 ) ( Point2D x2 y2 ) = AABB ( Point2D xmin ymin ) ( Point2 | y1 > y2 = ( y2, y1 ) | otherwise = ( y1, y2 ) +-- | Document, together with some extra metadata. data Document = Document - { displayName :: !Text - , mbFilePath :: !( Maybe FilePath ) - , unsavedChanges :: !Bool - , viewportCenter :: !( Point2D Double ) - , zoomFactor :: !Double - , documentUnique :: Unique - , strokes :: ![ Stroke ] - , guides :: !( Map Unique Guide ) - } - deriving stock ( Show, Generic ) + { displayName :: !Text + , mbFilePath :: !( Maybe FilePath ) + , viewportCenter :: !( Point2D Double ) + , zoomFactor :: !Double + , documentUnique :: Unique + , documentContent :: !DocumentContent + } + deriving stock ( Show, Generic ) + deriving anyclass NFData + +-- | Main content of document (data which we keept track of throughout history). +data DocumentContent + = Content + { unsavedChanges :: !Bool + , latestChange :: !Text + , guides :: !( Map Unique Guide ) + , strokes :: ![ Stroke ] + } + deriving stock ( Show, Generic ) + deriving anyclass NFData data Stroke = Stroke @@ -112,7 +131,8 @@ data Stroke , strokeUnique :: Unique , strokePoints :: !( Seq ( StrokePoint PointData ) ) } - deriving stock ( Show, Generic ) + deriving stock ( Show, Generic ) + deriving anyclass NFData data PointData = PointData @@ -120,17 +140,20 @@ data PointData , brushShape :: Seq ( StrokePoint BrushPointData ) } deriving stock ( Show, Generic ) + deriving anyclass NFData data BrushPointData = BrushPointData { brushPointState :: FocusState } deriving stock ( Show, Generic ) + deriving anyclass NFData data FocusState = Normal | Hover | Selected - deriving stock ( Show, Eq ) + deriving stock ( Show, Eq, Generic ) + deriving anyclass NFData instance Semigroup FocusState where Selected <> _ = Selected @@ -150,14 +173,18 @@ _brush = field' @"pointData" . field' @"brushShape" emptyDocument :: Text -> Unique -> Document emptyDocument docName unique = Document - { displayName = docName - , mbFilePath = Nothing - , unsavedChanges = False - , viewportCenter = Point2D 0 0 - , zoomFactor = 1 - , documentUnique = unique - , strokes = [] - , guides = Map.empty + { displayName = docName + , mbFilePath = Nothing + , viewportCenter = Point2D 0 0 + , zoomFactor = 1 + , documentUnique = unique + , documentContent = + Content + { unsavedChanges = False + , latestChange = "New document" + , strokes = [] + , guides = Map.empty + } } -------------------------------------------------------------------------------- @@ -165,7 +192,8 @@ emptyDocument docName unique = data HoverContext = MouseHover !( Point2D Double ) | RectangleHover !AABB - deriving stock Show + deriving stock ( Show, Generic ) + deriving anyclass NFData instance Act ( Vector2D Double ) HoverContext where v • MouseHover p = MouseHover ( v • p ) @@ -200,11 +228,12 @@ data Guide , guideFocus :: !FocusState , guideUnique :: Unique } - deriving stock ( Show, Generic ) + deriving stock ( Show, Generic ) + deriving anyclass NFData -- | Try to select a guide at the given document coordinates. selectedGuide :: Point2D Double -> Document -> Maybe Guide -selectedGuide c ( Document { zoomFactor, guides } ) = +selectedGuide c ( Document { zoomFactor, documentContent = Content { guides } } ) = \case { Min ( Arg _ g ) -> g } <$> foldMap ( selectGuide_maybe c zoomFactor ) guides selectGuide_maybe :: Point2D Double -> Double -> Guide -> Maybe ( ArgMin Double Guide ) @@ -221,7 +250,7 @@ selectGuide_maybe c zoom guide@( Guide { guidePoint = p, guideNormal = n } ) -- | Add new guide after a mouse drag from a ruler area. addGuide :: UniqueSupply -> Ruler -> Point2D Double -> Document -> STM Document -addGuide uniqueSupply ruler p = ( field' @"guides" ) insertNewGuides +addGuide uniqueSupply ruler p = ( field' @"documentContent" . field' @"guides" ) insertNewGuides where insertNewGuides :: Map Unique Guide -> STM ( Map Unique Guide ) insertNewGuides gs = case ruler of diff --git a/src/app/MetaBrush/Document/Draw.hs b/src/app/MetaBrush/Document/Draw.hs index 91cd7f2..14b4857 100644 --- a/src/app/MetaBrush/Document/Draw.hs +++ b/src/app/MetaBrush/Document/Draw.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} module MetaBrush.Document.Draw ( DrawAnchor(..), anchorsAreComplementary @@ -36,6 +37,10 @@ import Control.Lens import Control.Concurrent.STM ( STM ) +-- text +import Data.Text + ( Text ) + -- transformers import Control.Monad.Trans.State.Strict ( State, runState, get, put ) @@ -71,32 +76,46 @@ anchorsAreComplementary ( AnchorAtEnd uniq1 ) ( AnchorAtStart uniq2 ) = True anchorsAreComplementary _ _ = False -getOrCreateDrawAnchor :: UniqueSupply -> Point2D Double -> Document -> STM ( Document, DrawAnchor, Point2D Double ) +getOrCreateDrawAnchor + :: UniqueSupply + -> Point2D Double + -> Document + -> STM ( Document, DrawAnchor, Point2D Double ) getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) = - case ( `runState` Nothing ) $ field' @"strokes" ( traverse updateStroke ) doc of + case ( `runState` Nothing ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc of -- Anchor found: use it. - ( newDoc, Just ( anchor, anchorPt ) ) -> pure ( newDoc, anchor, anchorPt ) + ( newDoc, Just ( ( anchor, anchorPt ), anchorName ) ) -> do + let + newDoc' :: Document + newDoc' = + set ( field' @"documentContent" . field' @"latestChange" ) + ( "Continue stroke " <> anchorName ) + newDoc + pure ( newDoc', anchor, anchorPt ) -- No anchor found: start a new stroke (on a new stroke layer). - ( newDoc, Nothing ) -> do + ( newDoc, Nothing ) -> do uniq <- freshUnique uniqueSupply let newDoc' :: Document - newDoc' = - over ( field' @"strokes" ) - ( Stroke - { strokeName = "Stroke " <> uniqueText uniq - , strokeVisible = True - , strokeUnique = uniq - , strokePoints = Seq.singleton $ PathPoint c ( PointData Normal Empty ) - } - : ) - newDoc - pure ( newDoc' { unsavedChanges = True }, AnchorAtEnd uniq, c ) + newDoc' + = over ( field' @"documentContent" ) + ( over ( field' @"strokes" ) + ( Stroke + { strokeName = "Stroke " <> uniqueText uniq + , strokeVisible = True + , strokeUnique = uniq + , strokePoints = Seq.singleton $ PathPoint c ( PointData Normal Empty ) + } + : ) + . set ( field' @"latestChange" ) "Begin new stroke" + ) + $ newDoc + pure ( newDoc', 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). - updateStroke :: Stroke -> State ( Maybe ( DrawAnchor, Point2D Double ) ) Stroke - updateStroke stroke@( Stroke { strokeVisible, strokePoints, strokeUnique } ) = do + updateStroke :: Stroke -> State ( Maybe ( ( DrawAnchor, Point2D Double ), Text ) ) Stroke + updateStroke stroke@( Stroke { strokeName, strokeVisible, strokePoints, strokeUnique } ) = do mbAnchor <- get case mbAnchor of @@ -106,7 +125,7 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) = Nothing | strokeVisible , Just anchor <- endpointAnchor strokeUnique strokePoints - -> put ( Just anchor ) + -> put ( Just ( anchor, strokeName ) ) $> set ( field' @"strokePoints" . mapped . _selection ) Normal stroke -- Otherwise, just deselect. _ -> pure $ set ( field' @"strokePoints" . mapped . _selection ) Normal stroke @@ -128,7 +147,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 = set ( field' @"unsavedChanges" ) True . over ( field' @"strokes" . mapped ) addToStroke +addToAnchor anchor newPts = over ( field' @"documentContent" . field' @"strokes" . mapped ) addToStroke where addToStroke :: Stroke -> Stroke addToStroke stroke@( Stroke { strokeUnique, strokePoints = pts } ) diff --git a/src/app/MetaBrush/Document/History.hs b/src/app/MetaBrush/Document/History.hs new file mode 100644 index 0000000..4bb959b --- /dev/null +++ b/src/app/MetaBrush/Document/History.hs @@ -0,0 +1,100 @@ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} + +module MetaBrush.Document.History + ( DocumentHistory(..) + , back, fwd, newHistory, newFutureStep + , atStart, atEnd + , affirmPresent + ) + where + +-- base +import GHC.Generics + ( Generic ) + +-- containers +import Data.Sequence + ( Seq(..) ) +import qualified Data.Sequence as Seq + ( length, drop ) + +-- deepseq +import Control.DeepSeq + ( NFData(..), deepseq ) + +-- generic-lens +import Data.Generics.Product.Fields + ( field' ) + +-- lens +import Control.Lens + ( set ) + +-- MetaBrush +import MetaBrush.Document + ( Document(..), DocumentContent(..) ) + +-------------------------------------------------------------------------------- + +data DocumentHistory + = History + { past :: !( Seq DocumentContent ) + , present :: !Document + , future :: ![ DocumentContent ] + } + deriving stock ( Show, Generic ) +instance NFData DocumentHistory where + rnf ( History { past = ps, present, future } ) = + ps `deepseq` present `deepseq` future `deepseq` () + +back :: DocumentHistory -> DocumentHistory +back hist@( History { past = ps, present = c, future = fs } ) = case ps of + Empty -> hist + qs :|> q -> History { past = qs, present = c { documentContent = q }, future = documentContent c : fs } + +fwd :: DocumentHistory -> DocumentHistory +fwd hist@( History { past = ps, present = c, future = fs } ) = case fs of + [] -> hist + g : gs -> History { past = ps :|> documentContent c, present = c { documentContent = g }, future = gs } + +newHistory :: Document -> DocumentHistory +newHistory a = History { past = Empty, present = a, future = [] } + +newFutureStep :: Int -> Document -> DocumentHistory -> DocumentHistory +newFutureStep maxPastDocs a ( History { past = ps, present = c } ) = + History + { past = Seq.drop ( n - maxPastDocs ) ( ps :|> documentContent c ) + , present = a + , future = [] + } + where + n :: Int + n = 1 + Seq.length ps + + + +atStart, atEnd :: DocumentHistory -> Bool +atStart hist = null ( past hist ) +atEnd hist = null ( future hist ) + +-------------------------------------------------------------------------------- + +affirmPresent :: DocumentHistory -> DocumentHistory +affirmPresent + = set ( field' @"past" . traverse . field' @"unsavedChanges" ) + True + . set ( field' @"present" . field' @"documentContent" . field' @"unsavedChanges" ) + False + . set ( field' @"future" . traverse . field' @"unsavedChanges" ) + True diff --git a/src/app/MetaBrush/Document/Selection.hs b/src/app/MetaBrush/Document/Selection.hs index a6eb58f..5c6e114 100644 --- a/src/app/MetaBrush/Document/Selection.hs +++ b/src/app/MetaBrush/Document/Selection.hs @@ -18,6 +18,8 @@ module MetaBrush.Document.Selection where -- base +import Control.Arrow + ( first ) import Control.Category ( (>>>) ) import Data.Functor @@ -45,15 +47,19 @@ import Control.Lens -- tardis import Control.Monad.Trans.Tardis - ( Tardis ) + ( Tardis, TardisT ) import qualified Control.Monad.Trans.Tardis as Tardis ( TardisT(..) , getPast, getFuture, sendPast, sendFuture ) -- transformers +import Control.Monad.Trans.Class + ( lift ) import Control.Monad.Trans.State.Strict - ( State, evalState, get, put ) + ( StateT(..) + , State, runState, evalState, get, put + ) -- MetaBrush import Math.Bezier.Stroke @@ -98,7 +104,7 @@ selectionMode = foldMap \case -- | Updates the selected objects on a single click selection event. selectAt :: Mode -> SelectionMode -> Point2D Double -> Document -> Document selectAt mode selMode c doc@( Document { zoomFactor } ) = - ( `evalState` False ) $ field' @"strokes" ( traverse updateStroke ) doc + ( `evalState` False ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc where updateStroke :: Stroke -> State Bool Stroke updateStroke stroke@( Stroke { strokeVisible } ) @@ -156,7 +162,7 @@ dragMoveSelect mode c doc@( Document { zoomFactor } ) = let res :: Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) Document res = do - newDoc <- field' @"strokes" ( traverse updateStroke ) doc + newDoc <- ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc Tardis.getPast >>= Tardis.sendPast pure newDoc in case runIdentity $ Tardis.runTardisT res ( Nothing, Nothing ) of @@ -230,7 +236,9 @@ dragMoveSelect mode c doc@( Document { zoomFactor } ) = -- | Updates the selected objects on a rectangular selection event. selectRectangle :: Mode -> SelectionMode -> Point2D Double -> Point2D Double -> Document -> Document -selectRectangle mode selMode ( Point2D x0 y0 ) ( Point2D x1 y1 ) = over ( field' @"strokes" . mapped ) updateStroke +selectRectangle mode selMode ( Point2D x0 y0 ) ( Point2D x1 y1 ) + = over ( field' @"documentContent" . field' @"strokes" . mapped ) + updateStroke where xMin, xMax, yMin, yMax :: Double ( xMin, xMax ) = if x0 <= x1 then ( x0, x1 ) else ( x1, x0 ) @@ -266,60 +274,74 @@ selectRectangle mode selMode ( Point2D x0 y0 ) ( Point2D x1 y1 ) = over ( field' | otherwise = x >= xMin && x <= xMax && y >= yMin && y <= yMax -- | Translate all selected points by the given vector. -translateSelection :: Mode -> Vector2D Double -> Document -> Document -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 +translateSelection :: Mode -> Vector2D Double -> Document -> ( Document, Bool ) +translateSelection mode t doc = + ( `runState` False ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc + where - updateStrokePoint :: HasType FocusState pt => StrokePoint pt -> StrokePoint pt + updateStroke :: Stroke -> State Bool Stroke + updateStroke stroke@( Stroke { strokeVisible } ) + | not strokeVisible + = pure stroke + | Brush <- mode + = ( field' @"strokePoints" . traverse . field' @"pointData" . field' @"brushShape" . traverse ) + updateStrokePoint + stroke + | otherwise + = ( field' @"strokePoints" . traverse ) + updateStrokePoint + stroke + + updateStrokePoint :: HasType FocusState pt => StrokePoint pt -> State Bool ( StrokePoint pt ) updateStrokePoint pt | Selected <- view _selection pt - = pt { coords = t • coords pt } + = put True + $> pt { coords = t • coords pt } | otherwise - = pt + = pure pt -- | Delete the selected points. -deleteSelected :: Mode -> Document -> Document -deleteSelected mode doc = fst . runIdentity . ( `Tardis.runTardisT` ( False, False ) ) $ case mode of - Brush -> - ( field' @"strokes" . traverse . field' @"strokePoints" . traverse . field' @"pointData" . field' @"brushShape" ) - updateStroke - doc' - _ -> - ( field' @"strokes" . traverse . field' @"strokePoints" ) - updateStroke - doc' +deleteSelected :: Mode -> Document -> ( Document, Bool ) +deleteSelected mode doc + = first fst . runIdentity . ( `runStateT` False ) . ( `Tardis.runTardisT` ( False, False ) ) + $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc where - doc' :: Document - doc' = doc { unsavedChanges = True } - updateStroke + updateStroke :: Stroke -> TardisT Bool Bool ( State Bool ) Stroke + updateStroke stroke@( Stroke { strokeVisible } ) + | not strokeVisible + = pure stroke + | Brush <- mode + = ( field' @"strokePoints" . traverse . field' @"pointData" . field' @"brushShape" ) + updateStrokePoints + stroke + | otherwise + = ( field' @"strokePoints" ) + updateStrokePoints + stroke + + updateStrokePoints :: forall pt . HasType FocusState pt => Seq ( StrokePoint pt ) - -> Tardis Bool Bool ( Seq ( StrokePoint pt ) ) - updateStroke Empty = pure Empty - updateStroke ( p :<| ps ) = case p of + -> TardisT Bool Bool ( State Bool ) ( Seq ( StrokePoint pt ) ) + updateStrokePoints Empty = pure Empty + updateStrokePoints ( p :<| ps ) = case p of PathPoint {} | Selected <- selectionState -> do Tardis.sendPast True Tardis.sendFuture True - updateStroke ps + lift $ put True + updateStrokePoints ps | otherwise -> do Tardis.sendPast False Tardis.sendFuture False - ( p :<| ) <$> updateStroke ps + ( p :<| ) <$> updateStrokePoints ps _ -> do prevPathPointDeleted <- Tardis.getPast nextPathPointDeleted <- Tardis.getFuture - rest <- updateStroke ps + rest <- updateStrokePoints ps let -- Control point must be deleted: -- - if it is selected, diff --git a/src/app/MetaBrush/Document/Serialise.hs b/src/app/MetaBrush/Document/Serialise.hs index 9570b96..d87ab8c 100644 --- a/src/app/MetaBrush/Document/Serialise.hs +++ b/src/app/MetaBrush/Document/Serialise.hs @@ -119,7 +119,7 @@ import Math.Bezier.Stroke import Math.Vector2D ( Point2D(..), Vector2D(..) ) import MetaBrush.Document - ( Document(..) + ( Document(..), DocumentContent(..) , Guide(..) , Stroke(..) , PointData(..) @@ -350,24 +350,36 @@ decodeGuide uniqueSupply = do pure ( Guide { guidePoint, guideNormal, guideFocus, guideUnique } ) +encodeDocumentContent :: Applicative f => JSON.Encoder f DocumentContent +encodeDocumentContent = JSON.Encoder.mapLikeObj \ ( Content { guides, strokes } ) -> + JSON.Encoder.atKey' "guides" ( encodeUniqueMap encodeGuide ) guides + . JSON.Encoder.atKey' "strokes" ( JSON.Encoder.list encodeStroke ) strokes -encodeDocument :: Applicative f => JSON.Encoder f Document -encodeDocument = JSON.Encoder.mapLikeObj \ ( Document { displayName, viewportCenter, zoomFactor, strokes, guides } ) -> - JSON.Encoder.atKey' "name" JSON.Encoder.text displayName - . JSON.Encoder.atKey' "center" ( encodePoint2D encodeDouble ) viewportCenter - . JSON.Encoder.atKey' "zoom" encodeDouble zoomFactor - . JSON.Encoder.atKey' "strokes" ( JSON.Encoder.list encodeStroke ) strokes - . JSON.Encoder.atKey' "strokes" ( encodeUniqueMap encodeGuide ) guides - -decodeDocument :: MonadIO m => UniqueSupply -> Maybe FilePath -> JSON.Decoder m Document -decodeDocument uniqueSupply mbFilePath = do - displayName <- JSON.Decoder.atKey "name" JSON.Decoder.text +decodeDocumentContent :: MonadIO m => UniqueSupply -> JSON.Decoder m DocumentContent +decodeDocumentContent uniqueSupply = do let unsavedChanges :: Bool unsavedChanges = False - viewportCenter <- JSON.Decoder.atKey "center" ( decodePoint2D decodeDouble ) - zoomFactor <- JSON.Decoder.atKey "zoom" decodeDouble - documentUnique <- lift ( liftIO . STM.atomically $ freshUnique uniqueSupply ) - strokes <- JSON.Decoder.atKey "strokes" ( JSON.Decoder.list ( decodeStroke uniqueSupply ) ) - guides <- JSON.Decoder.atKey "guides" ( decodeUniqueMap ( decodeGuide uniqueSupply ) ) - pure ( Document { displayName, mbFilePath, unsavedChanges, viewportCenter, zoomFactor, documentUnique, strokes, guides } ) + latestChange :: Text + latestChange = "Load document" + strokes <- JSON.Decoder.atKey "strokes" ( JSON.Decoder.list ( decodeStroke uniqueSupply ) ) + guides <- JSON.Decoder.atKey "guides" ( decodeUniqueMap ( decodeGuide uniqueSupply ) ) + pure ( Content { unsavedChanges, latestChange, strokes, guides } ) + + + +encodeDocument :: Applicative f => JSON.Encoder f Document +encodeDocument = JSON.Encoder.mapLikeObj \ ( Document { displayName, viewportCenter, zoomFactor, documentContent } ) -> + JSON.Encoder.atKey' "name" JSON.Encoder.text displayName + . JSON.Encoder.atKey' "center" ( encodePoint2D encodeDouble ) viewportCenter + . JSON.Encoder.atKey' "zoom" encodeDouble zoomFactor + . JSON.Encoder.atKey' "content" encodeDocumentContent documentContent + +decodeDocument :: MonadIO m => UniqueSupply -> Maybe FilePath -> JSON.Decoder m Document +decodeDocument uniqueSupply mbFilePath = do + displayName <- JSON.Decoder.atKey "name" JSON.Decoder.text + viewportCenter <- JSON.Decoder.atKey "center" ( decodePoint2D decodeDouble ) + zoomFactor <- JSON.Decoder.atKey "zoom" decodeDouble + documentUnique <- lift ( liftIO . STM.atomically $ freshUnique uniqueSupply ) + documentContent <- JSON.Decoder.atKey "content" ( decodeDocumentContent uniqueSupply ) + pure ( Document { displayName, mbFilePath, viewportCenter, zoomFactor, documentUnique, documentContent } ) diff --git a/src/app/MetaBrush/Document/SubdivideStroke.hs b/src/app/MetaBrush/Document/SubdivideStroke.hs index ac4bac7..f87d4d5 100644 --- a/src/app/MetaBrush/Document/SubdivideStroke.hs +++ b/src/app/MetaBrush/Document/SubdivideStroke.hs @@ -61,7 +61,11 @@ subdivide mode c doc@( Document { zoomFactor } ) updatedDoc :: Document subdivOccurred :: Bool - ( updatedDoc, subdivOccurred ) = ( `runState` False ) $ field' @"strokes" ( traverse updateStroke ) doc + ( updatedDoc, subdivOccurred ) + = ( `runState` False ) + $ ( field' @"documentContent" . field' @"strokes" . traverse ) + updateStroke + doc updateStroke :: Stroke -> State Bool Stroke updateStroke stroke@( Stroke { strokeVisible } ) diff --git a/src/app/MetaBrush/Document/Update.hs b/src/app/MetaBrush/Document/Update.hs new file mode 100644 index 0000000..4ca1e0a --- /dev/null +++ b/src/app/MetaBrush/Document/Update.hs @@ -0,0 +1,256 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeApplications #-} + +module MetaBrush.Document.Update + ( activeDocument, withActiveDocument + , DocChange(..), DocumentUpdate(..) + , PureDocModification(..), DocModification(..) + , modifyingCurrentDocument + , updateUIAction + , updateHistoryState + ) +where + +-- base +import Control.Arrow + ( (&&&) ) +import Control.Monad + ( join ) +import Data.Coerce + ( coerce ) +import Data.Foldable + ( for_, sequenceA_ ) +import Data.Monoid + ( Ap(..) ) +import Data.Traversable + ( for ) + +-- containers +import qualified Data.Map.Strict as Map + ( adjust, delete, lookup ) + +-- generic-lens +import Data.Generics.Product.Fields + ( field' ) + +-- gi-gtk +import qualified GI.Gtk as GTK + +-- lens +import Control.Lens + ( set ) +import Control.Lens.Fold + ( Fold, foldMapOf, forOf_, sequenceAOf_ ) + +-- stm +import Control.Concurrent.STM + ( STM ) +import qualified Control.Concurrent.STM as STM + ( atomically ) +import qualified Control.Concurrent.STM.TVar as STM + ( readTVar, readTVar, modifyTVar' ) + +-- text +import Data.Text + ( Text ) + +-- transformers +import Control.Monad.Trans.Class + ( lift ) +import Control.Monad.Trans.Maybe + ( MaybeT(..) ) + +-- MetaBrush +import MetaBrush.Context + ( UIElements(..), Variables(..) ) +import MetaBrush.Document + ( Document(..), DocumentContent(..) ) +import MetaBrush.Document.History + ( DocumentHistory(..) + , newFutureStep, affirmPresent + , atStart, atEnd + ) +import {-# SOURCE #-} MetaBrush.UI.FileBar + ( removeFileTab ) +import {-# SOURCE #-} MetaBrush.UI.InfoBar + ( updateInfoBar ) +import MetaBrush.UI.Menu + ( ResourceType(..), MenuItem(..), Menu(..), EditMenu(..) ) +import MetaBrush.UI.Viewport + ( Viewport(..) ) +import MetaBrush.Util + ( (>>?=) ) + +-------------------------------------------------------------------------------- + +-- | Read the currently active document from the stateful variables. +activeDocument :: Variables -> STM ( Maybe DocumentHistory ) +activeDocument ( Variables { activeDocumentTVar, openDocumentsTVar } ) + = STM.readTVar activeDocumentTVar + >>?= ( \ unique -> Map.lookup unique <$> STM.readTVar openDocumentsTVar ) + +-- | Do something with the currently active document. +-- +-- Does nothing if no document is currently active. +withActiveDocument :: Variables -> ( Document -> STM a ) -> STM ( Maybe a ) +withActiveDocument vars f = traverse f =<< ( fmap present <$> activeDocument vars ) + + +data DocChange + = TrivialChange { newDocument :: !Document } + | HistoryChange { newDocument :: !Document } + +data DocumentUpdate + = CloseDocument + | SaveDocument !( Maybe FilePath ) + | UpdateDocumentTo !DocChange + +data PureDocModification + = Don'tModifyDoc + | UpdateDoc !DocumentUpdate + +-- | Modify a document, and then perform some subsequent IO action. +-- +-- It is assumed that the subsequent IO action does not affect the rest of the application, +-- i.e. it doesn't change any of the STM variables or update the UI. +-- For instance: saving a file to disk. +data DocModification + = Don'tModifyDocAndThen + { postModifAction :: IO () } + | UpdateDocAndThen + { modifDocument :: !DocumentUpdate + , postModifAction :: IO () + } + +class DocumentModification modif where + docFold :: Fold modif DocumentUpdate + actionFold :: Fold modif ( IO () ) + +instance DocumentModification PureDocModification where + docFold _ Don'tModifyDoc = pure Don'tModifyDoc + docFold f ( UpdateDoc mbDocInstnt ) = UpdateDoc <$> ( f mbDocInstnt ) + actionFold _ a = pure a + +instance DocumentModification DocModification where + docFold _ don't@( Don'tModifyDocAndThen {} ) = pure don't + docFold f ( UpdateDocAndThen mbDocInstnt action ) = ( \ new -> UpdateDocAndThen new action ) <$> f mbDocInstnt + actionFold f modif = ( \ action' -> modif { postModifAction = action' } ) <$> f ( postModifAction modif ) + +-- | Modify the currently active document. +-- +-- Does nothing if no document is currently active. +modifyingCurrentDocument :: DocumentModification modif => UIElements -> Variables -> ( Document -> STM modif ) -> IO () +modifyingCurrentDocument uiElts@( UIElements { viewport = Viewport {..}, .. } ) vars@( Variables {..} ) f = do + mbAction <- STM.atomically . runMaybeT $ do + unique <- MaybeT ( STM.readTVar activeDocumentTVar ) + oldDoc <- MaybeT ( fmap present . Map.lookup unique <$> STM.readTVar openDocumentsTVar ) + maxHistSize <- lift ( STM.readTVar maxHistorySizeTVar ) + modif <- lift ( f oldDoc ) + Ap uiUpdateAction <- lift . getAp $ flip ( foldMapOf docFold ) modif $ Ap . \case + CloseDocument -> do + STM.modifyTVar' openDocumentsTVar ( Map.delete unique ) + coerce ( updateUIAction uiElts vars ) + SaveDocument Nothing -> do + STM.modifyTVar' openDocumentsTVar ( Map.adjust affirmPresent unique ) + pure ( pure () ) + SaveDocument ( Just newFilePath ) -> do + STM.modifyTVar' openDocumentsTVar + ( Map.adjust + ( affirmPresent + . set ( field' @"present" . field' @"mbFilePath" ) + ( Just newFilePath ) + ) + unique + ) + pure ( pure () ) + UpdateDocumentTo ( TrivialChange newDoc ) -> do + STM.modifyTVar' openDocumentsTVar + ( Map.adjust ( set ( field' @"present" ) newDoc ) unique ) + coerce ( updateUIAction uiElts vars ) + UpdateDocumentTo ( HistoryChange newDoc ) -> do + STM.modifyTVar' openDocumentsTVar + ( Map.adjust + ( newFutureStep maxHistSize + $ set ( field' @"documentContent" . field' @"unsavedChanges" ) True newDoc + ) + unique + ) + uiUpdateAction <- updateUIAction uiElts vars + pure $ Ap do + uiUpdateAction + GTK.widgetSetSensitive undoMenuItem True + GTK.widgetSetSensitive redoMenuItem False + pure + do + forOf_ docFold modif \ mbNewDoc -> do + case mbNewDoc of + CloseDocument -> removeFileTab vars ( documentUnique oldDoc ) + _ -> pure () + uiUpdateAction + sequenceAOf_ actionFold modif + sequenceA_ mbAction + where + undoMenuItem, redoMenuItem :: GTK.MenuItem + undoMenuItem = menuItem $ undo $ menuItemSubmenu $ edit menu + redoMenuItem = menuItem $ redo $ menuItemSubmenu $ edit menu + + +updateUIAction :: UIElements -> Variables -> STM ( IO () ) +updateUIAction ( UIElements { viewport = Viewport {..}, .. } ) vars@( Variables {..} ) = do + mbDocHist <- activeDocument vars + let + mbDoc :: Maybe Document + mbDoc = present <$> mbDocHist + mbTitleText :: Maybe ( Text, Bool ) + mbTitleText = fmap ( displayName &&& unsavedChanges . documentContent ) mbDoc + mbActiveTabDoc <- fmap join $ for mbDoc \doc -> do + mbActiveTab <- Map.lookup ( documentUnique doc ) <$> STM.readTVar fileBarTabsTVar + pure ( (,) <$> mbActiveTab <*> mbDoc ) + pure do + updateTitle window title mbTitleText + updateInfoBar viewportDrawingArea infoBar vars mbDoc + for_ mbActiveTabDoc \ ( ( activeTab, activeTabLabel ), activeDoc ) -> do + GTK.buttonSetLabel activeTabLabel ( displayName activeDoc ) + GTK.widgetQueueDraw activeTab + GTK.widgetQueueDraw viewportDrawingArea + for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do + GTK.widgetQueueDraw drawingArea + +updateTitle :: GTK.Window -> GTK.Label -> Maybe ( Text, Bool ) -> IO () +updateTitle window title mbTitleText = do + GTK.labelSetText title titleText + GTK.setWindowTitle window titleText + where + titleText :: Text + titleText = case mbTitleText of + Nothing -> "MetaBrush" + Just ( name, hasUnsavedChanges ) + | hasUnsavedChanges + -> "● " <> name <> " – MetaBrush" + | otherwise + -> name <> " – MetaBrush" + +updateHistoryState :: UIElements -> Maybe DocumentHistory -> IO () +updateHistoryState ( UIElements {..} ) mbHist = + case mbHist of + Nothing -> do + GTK.widgetSetSensitive undoMenuItem False + GTK.widgetSetSensitive redoMenuItem False + Just hist -> do + if atStart hist + then GTK.widgetSetSensitive undoMenuItem False + else GTK.widgetSetSensitive undoMenuItem True + if atEnd hist + then GTK.widgetSetSensitive redoMenuItem False + else GTK.widgetSetSensitive redoMenuItem True + where + editMenu :: EditMenu Object + editMenu = menuItemSubmenu ( edit menu ) + undoMenuItem, redoMenuItem :: GTK.MenuItem + undoMenuItem = menuItem $ undo $ editMenu + redoMenuItem = menuItem $ redo $ editMenu diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index e2dc812..8c57a7b 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -75,7 +75,8 @@ import MetaBrush.Asset.Colours import MetaBrush.Context ( HoldAction(..), PartialPath(..) ) import MetaBrush.Document - ( Document(..), mkAABB + ( Document(..), DocumentContent(..) + , mkAABB , Stroke(..), FocusState(..) , HoverContext(..), Hoverable(..) , PointData(..), BrushPointData(..) @@ -121,7 +122,7 @@ renderDocument renderDocument cols params mode ( viewportWidth, viewportHeight ) mbMousePos mbHoldEvent mbPartialPath - doc@( Document { viewportCenter = Point2D cx cy, zoomFactor } ) + doc@( Document { viewportCenter = Point2D cx cy, zoomFactor, documentContent = content } ) = do Cairo.save @@ -144,7 +145,7 @@ renderDocument | Just ( DragMoveHold p0 ) <- mbHoldEvent , Just p1 <- mbMousePos , p0 /= p1 - = strokes $ translateSelection mode ( p0 --> p1 ) doc + = strokes . documentContent . fst $ translateSelection mode ( p0 --> p1 ) doc | Just ( PartialPath p0 cp0 _ _ ) <- mbPartialPath , let mbFinalPoint :: Maybe ( Point2D Double ) @@ -172,9 +173,9 @@ renderDocument , Just ( PathPoint finalPoint ( PointData Normal Empty ) ) ] = ( Stroke { strokePoints = previewPts, strokeVisible = True, strokeUnique = undefined, strokeName = undefined } ) - : strokes doc + : strokes content | otherwise - = strokes doc + = strokes content for_ modifiedStrokes ( compositeRenders . getCompose . renderStroke cols mbHoverContext params mode zoomFactor ) renderSelectionRect diff --git a/src/app/MetaBrush/Render/Rulers.hs b/src/app/MetaBrush/Render/Rulers.hs index a7f8d7f..1f148ea 100644 --- a/src/app/MetaBrush/Render/Rulers.hs +++ b/src/app/MetaBrush/Render/Rulers.hs @@ -60,7 +60,8 @@ import MetaBrush.Asset.Colours import MetaBrush.Context ( HoldAction(..), GuideAction(..) ) import MetaBrush.Document - ( Document(..), FocusState(..), Hoverable(..), HoverContext(..) + ( Document(..), DocumentContent(..) + , FocusState(..), Hoverable(..), HoverContext(..) , Guide(..) ) import MetaBrush.UI.Coordinates @@ -82,7 +83,7 @@ renderRuler renderRuler cols@( Colours {..} ) ( viewportWidth, viewportHeight ) actionOrigin ( width, height ) mbMousePos mbHoldEvent showGuides - ( Document { viewportCenter = center@( Point2D cx cy ), zoomFactor, guides } ) = do + ( Document { viewportCenter = center@( Point2D cx cy ), zoomFactor, documentContent = Content { guides } } ) = do let modifiedGuides :: [ Guide ] diff --git a/src/app/MetaBrush/UI/FileBar.hs b/src/app/MetaBrush/UI/FileBar.hs index 6bb34ba..9c85322 100644 --- a/src/app/MetaBrush/UI/FileBar.hs +++ b/src/app/MetaBrush/UI/FileBar.hs @@ -15,7 +15,7 @@ module MetaBrush.UI.FileBar -- base import Control.Monad - ( join, void ) + ( join, unless, void ) import Data.Foldable ( for_, sequenceA_ ) import Data.Traversable @@ -48,9 +48,15 @@ import MetaBrush.Asset.Colours import MetaBrush.Context ( UIElements(..), Variables(..) ) import MetaBrush.Document - ( Document(..), emptyDocument ) + ( Document(..), DocumentContent(..) + , emptyDocument + ) +import MetaBrush.Document.History + ( DocumentHistory(..), newHistory ) +import MetaBrush.Document.Update + ( updateUIAction ) import {-# SOURCE #-} MetaBrush.UI.InfoBar - ( InfoBar, updateInfoBar ) + ( InfoBar ) import {-# SOURCE #-} MetaBrush.UI.Menu ( Menu, ResourceType(Object) ) import MetaBrush.UI.Viewport @@ -77,43 +83,44 @@ data TabLocation deriving stock Show newFileTab - :: UIElements + :: Bool + -> UIElements -> Variables - -> Maybe Document + -> Maybe DocumentHistory -> TabLocation -> IO () newFileTab + initialStage uiElts@( UIElements { fileBar = FileBar {..}, viewport = Viewport {..}, .. } ) vars@( Variables {..} ) - mbDoc + mbDocHist newTabLoc = do - newDoc <- case mbDoc of + newDocHist <- case mbDocHist of -- Use the provided document (e.g. document read from a file). - Just doc -> do - pure doc + Just docHist -> do pure docHist -- Create a new empty document. Nothing -> do newDocUniq <- STM.atomically $ freshUnique uniqueSupply - pure ( emptyDocument ( "Untitled " <> uniqueText newDocUniq ) newDocUniq ) + pure ( newHistory $ emptyDocument ( "Untitled " <> uniqueText newDocUniq ) newDocUniq ) let newUnique :: Unique - newUnique = documentUnique newDoc + newUnique = documentUnique ( present newDocHist ) -- File tab elements. - pgButton <- GTK.radioButtonNewWithLabelFromWidget ( Just fileBarPhantomRadioButton ) ( displayName newDoc ) + pgButton <- GTK.radioButtonNewWithLabelFromWidget ( Just fileBarPhantomRadioButton ) ( displayName $ present newDocHist ) GTK.toggleButtonSetMode pgButton False -- don't display radio indicator closeFileButton <- GTK.buttonNew closeFileArea <- GTK.drawingAreaNew GTK.containerAdd closeFileButton closeFileArea void $ GTK.onWidgetDraw closeFileArea \ cairoContext -> do - mbTabDoc <- Map.lookup newUnique <$> STM.readTVarIO openDocumentsTVar + mbTabDoc <- fmap present . Map.lookup newUnique <$> STM.readTVarIO openDocumentsTVar let unsaved :: Bool - unsaved = maybe False unsavedChanges mbTabDoc + unsaved = maybe False ( unsavedChanges . documentContent ) mbTabDoc flags <- GTK.widgetGetStateFlags closeFileButton Cairo.renderWithContext ( drawCloseTabButton colours unsaved flags ) cairoContext @@ -135,7 +142,7 @@ newFileTab mbUnique <- STM.readTVar activeDocumentTVar for mbUnique \ docUnique -> do Map.lookup docUnique <$> STM.readTVar fileBarTabsTVar - for_ mbActiveTab \ activeTab -> do + for_ mbActiveTab \ ( activeTab, _ ) -> do children <- GTK.containerGetChildren fileTabsBox for_ ( zip children [0..] ) \ ( childWidget, activeTabIndex ) -> do mbBox <- GTK.castTo GTK.Box childWidget @@ -156,13 +163,17 @@ newFileTab pure False -- Update the state: switch to this new document. - STM.atomically do - STM.modifyTVar' openDocumentsTVar ( Map.insert newUnique newDoc ) - STM.modifyTVar' fileBarTabsTVar ( Map.insert newUnique tab ) - STM.writeTVar activeDocumentTVar ( Just newUnique ) - - GTK.widgetQueueDraw viewportDrawingArea - updateInfoBar viewportDrawingArea infoBar vars + uiUpdateAction <- STM.atomically do + STM.modifyTVar' openDocumentsTVar ( Map.insert newUnique newDocHist ) + STM.modifyTVar' fileBarTabsTVar ( Map.insert newUnique ( tab, pgButton ) ) + -- don't update UI if we are just creating file tabs for the first time + -- (we don't have access to the full menu at that point, so this would otherwise loop) + if initialStage + then pure ( pure () ) + else do + STM.writeTVar activeDocumentTVar ( Just newUnique ) + updateUIAction uiElts vars + uiUpdateAction void $ GTK.onButtonClicked pgButton do isActive <- GTK.toggleButtonGetActive pgButton @@ -170,8 +181,7 @@ newFileTab if isActive then do GTK.widgetSetStateFlags tab ( GTK.StateFlagsActive : flags ) True - handleAction uiElts vars - ( SwitchTo newUnique ) + handleAction uiElts vars ( SwitchTo newUnique ) else do GTK.widgetSetStateFlags tab ( filter ( /= GTK.StateFlagsActive ) flags ) True GTK.widgetQueueDraw closeFileArea @@ -180,7 +190,10 @@ newFileTab GTK.widgetQueueDraw closeFileArea handleAction uiElts vars ( CloseThis newUnique ) - GTK.toggleButtonSetActive pgButton True + -- Activate the button, unless we are creating buttons for the first time, + -- in which case we shouldn't activate it as we don't have a menu yet, + -- so we wouldn't be able to handle the associated action. + unless initialStage ( GTK.toggleButtonSetActive pgButton True ) -- | Create a file bar: tabs allowing selection of the active document. -- @@ -224,13 +237,13 @@ createFileBar documents <- STM.readTVarIO openDocumentsTVar for_ documents \ doc -> - newFileTab + newFileTab True uiElements vars ( Just doc ) LastTab void $ GTK.onButtonClicked newFileButton do - newFileTab + newFileTab False uiElements vars Nothing LastTab @@ -244,7 +257,7 @@ removeFileTab ( Variables {..} ) docUnique = do cleanupAction <- STM.atomically do -- Remove the tab. mbTab <- Map.lookup docUnique <$> STM.readTVar fileBarTabsTVar - for mbTab \ tab -> do + for mbTab \ ( tab, _ ) -> do STM.modifyTVar' openDocumentsTVar ( Map.delete docUnique ) STM.modifyTVar' fileBarTabsTVar ( Map.delete docUnique ) pure ( GTK.widgetDestroy tab ) diff --git a/src/app/MetaBrush/UI/FileBar.hs-boot b/src/app/MetaBrush/UI/FileBar.hs-boot index 11fd76f..f324080 100644 --- a/src/app/MetaBrush/UI/FileBar.hs-boot +++ b/src/app/MetaBrush/UI/FileBar.hs-boot @@ -15,8 +15,8 @@ import MetaBrush.Asset.Colours ( Colours ) import {-# SOURCE #-} MetaBrush.Context ( Variables, UIElements ) -import MetaBrush.Document - ( Document ) +import MetaBrush.Document.History + ( DocumentHistory ) import {-# SOURCE #-} MetaBrush.UI.InfoBar ( InfoBar ) import {-# SOURCE #-} MetaBrush.UI.Menu @@ -47,8 +47,9 @@ createFileBar -> IO FileBar newFileTab - :: UIElements -> Variables - -> Maybe Document -> TabLocation + :: Bool + -> UIElements -> Variables + -> Maybe DocumentHistory -> TabLocation -> IO () removeFileTab :: Variables -> Unique -> IO () diff --git a/src/app/MetaBrush/UI/InfoBar.hs b/src/app/MetaBrush/UI/InfoBar.hs index 25e7274..30b030b 100644 --- a/src/app/MetaBrush/UI/InfoBar.hs +++ b/src/app/MetaBrush/UI/InfoBar.hs @@ -33,8 +33,6 @@ import qualified GI.Cairo.Render as Cairo import qualified GI.Gtk as GTK -- stm -import qualified Control.Concurrent.STM as STM - ( atomically ) import qualified Control.Concurrent.STM.TVar as STM ( readTVarIO ) @@ -52,9 +50,7 @@ import MetaBrush.Asset.Cursor import MetaBrush.Asset.InfoBar ( drawMagnifier, drawTopLeftCornerRect ) import MetaBrush.Context - ( Variables(..) - , currentDocument - ) + ( Variables(..) ) import MetaBrush.Document ( Document(..) ) import MetaBrush.UI.Coordinates @@ -161,12 +157,11 @@ createInfoBar colours = do pure ( InfoBar {..} ) -updateInfoBar :: GTK.DrawingArea -> InfoBar -> Variables -> IO () -updateInfoBar viewportDrawingArea ( InfoBar {..} ) vars@( Variables { mousePosTVar } ) +updateInfoBar :: GTK.DrawingArea -> InfoBar -> Variables -> Maybe Document -> IO () +updateInfoBar viewportDrawingArea ( InfoBar {..} ) ( Variables { mousePosTVar } ) mbDoc = do viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea - mbDoc <- STM.atomically $ currentDocument vars case mbDoc of Nothing -> do GTK.labelSetText zoomText $ na diff --git a/src/app/MetaBrush/UI/InfoBar.hs-boot b/src/app/MetaBrush/UI/InfoBar.hs-boot index bb825d7..6b7e882 100644 --- a/src/app/MetaBrush/UI/InfoBar.hs-boot +++ b/src/app/MetaBrush/UI/InfoBar.hs-boot @@ -10,6 +10,8 @@ import MetaBrush.Asset.Colours ( Colours ) import {-# SOURCE #-} MetaBrush.Context ( Variables ) +import MetaBrush.Document + ( Document ) -------------------------------------------------------------------------------- @@ -22,4 +24,4 @@ data InfoBar createInfoBar :: Colours -> IO InfoBar -updateInfoBar :: GTK.DrawingArea -> InfoBar -> Variables -> IO () +updateInfoBar :: GTK.DrawingArea -> InfoBar -> Variables -> Maybe Document -> IO () diff --git a/src/app/MetaBrush/UI/Menu.hs b/src/app/MetaBrush/UI/Menu.hs index 28275f9..21707aa 100644 --- a/src/app/MetaBrush/UI/Menu.hs +++ b/src/app/MetaBrush/UI/Menu.hs @@ -136,7 +136,6 @@ data EditMenu ( rt :: ResourceType ) = EditMenu { undo :: !( MenuItem Undo NoSubresource rt ) , redo :: !( MenuItem Redo NoSubresource rt ) - , discardChanges :: !( MenuItem DiscardChanges NoSubresource rt ) , editSep1 :: !( Separator rt ) , cut :: !( MenuItem Cut NoSubresource rt ) , copy :: !( MenuItem Copy NoSubresource rt ) @@ -196,7 +195,6 @@ editMenuDescription = EditMenu { undo = MenuItemDescription "Undo" [ "submenuItem" ] Undo ( Just ( GDK.KEY_Z, [ Control L ] ) ) NoSubresource , redo = MenuItemDescription "Redo" [ "submenuItem" ] Redo ( Just ( GDK.KEY_Y, [ Control L ] ) ) NoSubresource - , discardChanges = MenuItemDescription "Discard changes" [ "submenuItem" ] DiscardChanges ( Just ( GDK.KEY_Z, [ Control L, Shift L ] ) ) NoSubresource , editSep1 = SeparatorDescription [ "submenuSeparator" ] , cut = MenuItemDescription "Cut" [ "submenuItem" ] Cut ( Just ( GDK.KEY_X, [ Control L ] ) ) NoSubresource , copy = MenuItemDescription "Copy" [ "submenuItem" ] Copy ( Just ( GDK.KEY_C, [ Control L ] ) ) NoSubresource diff --git a/src/app/MetaBrush/Unique.hs b/src/app/MetaBrush/Unique.hs index e4dec0b..f222382 100644 --- a/src/app/MetaBrush/Unique.hs +++ b/src/app/MetaBrush/Unique.hs @@ -28,6 +28,10 @@ import Data.Map.Strict import qualified Data.Map.Strict as Map ( fromList ) +-- deepseq +import Control.DeepSeq + ( NFData ) + -- generic-lens import Data.Generics.Product.Typed ( HasType(typed) ) @@ -52,7 +56,7 @@ import qualified Data.Text as Text newtype Unique = Unique { unique :: Int64 } deriving stock Show - deriving newtype ( Eq, Ord, Storable ) + deriving newtype ( Eq, Ord, Storable, NFData ) unsafeUnique :: Word32 -> Unique unsafeUnique i = Unique ( - fromIntegral i - 1 )