add document history & undo/redo

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
+      groups-generic
-          ^>= 1.4.4.0
-      , 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

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 :: Map Unique DocumentHistory
-testDocuments = uniqueMapFromList
+testDocuments = fmap newHistory $ uniqueMapFromList
-  [ ( emptyDocument "Closed" ( unsafeUnique 0 ) )
+  [ emptyDocument "Closed" ( unsafeUnique 0 )
-    { strokes =
+  & ( field' @"documentContent" . field' @"strokes" ) .~
-      [ Stroke
+    [ Stroke
-        { strokeName    = "Ellipse"
+      { strokeName    = "Ellipse"
-        , strokeVisible = True
+      , strokeVisible = True
-        , strokeUnique  = unsafeUnique 10
+      , strokeUnique  = unsafeUnique 10
-        , strokePoints  = ellipse 150 100 ( PointData Normal ( rect 30 6 $ BrushPointData Normal ) )
+      , strokePoints  = ellipse 150 100 ( PointData Normal ( rect 30 6 $ BrushPointData Normal ) )
-        }
+      }
-      ]
+    ]
-    }
+  , emptyDocument "Line" ( unsafeUnique 1 )
-  , ( emptyDocument "Line" ( unsafeUnique 1 ) )
+  & ( field' @"documentContent" . field' @"strokes" ) .~
-    { strokes =
+    [ Stroke
-      [ Stroke
+      { strokeName    = "Line"
-        { strokeName    = "Line"
+      , strokeVisible = True
-        , strokeVisible = True
+      , strokeUnique  = unsafeUnique 11
-        , strokeUnique  = unsafeUnique 11
+      , strokePoints  = linePts
-        , strokePoints  = linePts
+      }
-        }
+    ]
-      ]
+  , emptyDocument "Short line" ( unsafeUnique 2 )
-    }
+  & ( field' @"documentContent" . field' @"strokes" ) .~
-  , ( emptyDocument "Short line" ( unsafeUnique 2 ) )
+    [ Stroke
-    { strokes =
+      { strokeName    = "ShortLine"
-      [ Stroke
+      , strokeVisible = True
-        { strokeName    = "ShortLine"
+      , strokeUnique  = unsafeUnique 12
-        , strokeVisible = True
+      , strokePoints  = linePts2
-        , 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
+  activeDocumentTVar <- STM.newTVarIO @( Maybe Unique      )                       Nothing
-  openDocumentsTVar  <- STM.newTVarIO @( Map Unique Document )      testDocuments
+  openDocumentsTVar  <- STM.newTVarIO @( Map Unique DocumentHistory )              testDocuments
-  mousePosTVar       <- STM.newTVarIO @( Maybe ( Point2D Double ) ) Nothing
+  mousePosTVar       <- STM.newTVarIO @( Maybe ( Point2D Double ) )                Nothing
-  mouseHoldTVar      <- STM.newTVarIO @( Maybe HoldAction )         Nothing
+  mouseHoldTVar      <- STM.newTVarIO @( Maybe HoldAction )                        Nothing
-  modifiersTVar      <- STM.newTVarIO @( Set Modifier )             Set.empty
+  modifiersTVar      <- STM.newTVarIO @( Set Modifier )                            Set.empty
-  toolTVar           <- STM.newTVarIO @Tool                         Selection
+  toolTVar           <- STM.newTVarIO @Tool                                        Selection
-  modeTVar           <- STM.newTVarIO @Mode                         Path
+  modeTVar           <- STM.newTVarIO @Mode                                        Path
-  partialPathTVar    <- STM.newTVarIO @( Maybe PartialPath )        Nothing
+  partialPathTVar    <- STM.newTVarIO @( Maybe PartialPath )                       Nothing
-  fileBarTabsTVar    <- STM.newTVarIO @( Map Unique GTK.Box )       Map.empty
+  fileBarTabsTVar    <- STM.newTVarIO @( Map Unique ( GTK.Box, GTK.RadioButton ) ) Map.empty
-  showGuidesTVar     <- STM.newTVarIO @Bool                         True
+  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

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 
+  location: https://github.com/sheaf/gi-cairo-render
-  tag: 8727c43cdf91aeedffc9cb4c5575f56660a86399
+  tag: a53d1596e36ce7bbff517940260faf1c4d02ffcc
-  subdir: gi-cairo-render
+  subdir: gi-cairo-render gi-cairo-connector
 
 -- latest version of hmatrix
 source-repository-package

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`
 

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
+          modif :: DocumentUpdate
-          doc' = doc { unsavedChanges = False }
+          modif = if keepOpen then SaveDocument Nothing else CloseDocument
-        if keepOpen
+        pure $ UpdateDocAndThen modif ( saveDocument filePath doc )
-        then
-          pure $ UpdateDocToAndThen
-            ( Just doc' )
-            ( saveDocument filePath doc' )
-        else
-          pure $ UpdateDocToAndThen Nothing ( 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
+        modif :: DocumentUpdate
-        doc' = doc { mbFilePath = Just savePath, unsavedChanges = False }
+        modif = if keepOpen then SaveDocument ( Just savePath ) else CloseDocument
-      if keepOpen
+      pure $ UpdateDocAndThen modif ( saveDocument savePath doc )
-      then
-        pure $ UpdateDocToAndThen
-          ( Just doc' )
-          ( saveDocument savePath doc' )
-      else
-        pure $ UpdateDocToAndThen Nothing ( 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 )
+        CloseActive      -> fmap ( ( , True ) . present ) <$> STM.atomically ( activeDocument vars )
-        CloseThis unique -> Map.lookup unique <$> STM.readTVarIO openDocumentsTVar
+        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 } )
+        Just ( Document { displayName, documentUnique, documentContent }, isActiveDoc )
-          | unsavedChanges
+          | 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 :: Bool -> Unique -> IO ()
-        closeDocument unique = do
+        closeDocument isActiveDoc unique = do
           removeFileTab vars unique
-          updateTitle window title Nothing
+          when isActiveDoc do
-          updateInfoBar viewportDrawingArea infoBar vars
+            uiUpdateAction <- STM.atomically do
-          GTK.widgetQueueDraw viewportDrawingArea
+              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
+        mbHist <- Map.lookup newUnique <$> STM.readTVar openDocumentsTVar
-        newTab <- Map.lookup newUnique <$> STM.readTVar fileBarTabsTVar
+        uiUpdateAction <- updateUIAction uiElts vars
-        pure ( (,) <$> newDoc <*> newTab )
+        pure do
-      case mbNewDocAndTab of
+          uiUpdateAction
-        Nothing -> updateTitle window title Nothing
+          updateHistoryState uiElts mbHist
-        Just ( Document {..}, tab ) -> do
+      uiUpdateAction
-          updateTitle window title ( Just ( displayName, unsavedChanges ) )
-          updateInfoBar viewportDrawingArea infoBar vars
-          GTK.widgetQueueDraw tab
-      GTK.widgetQueueDraw viewportDrawingArea
 
 --------------
 -- 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
 
----------------------
+updateHistory :: ( DocumentHistory -> DocumentHistory ) -> UIElements -> Variables -> IO ()
--- Discard changes --
+updateHistory f uiElts@( UIElements {..} ) vars@( Variables {..} ) = do
----------------------
+  uiUpdateAction <- STM.atomically do
-
+    mbUnique <- STM.readTVar activeDocumentTVar
-data DiscardChanges = DiscardChanges
+    case mbUnique of
-  deriving stock Show
+      Nothing -> pure ( pure () )
-
+      Just unique -> do
--- TODO
+        mbDocHistory <- Map.lookup unique <$> STM.readTVar openDocumentsTVar
-instance HandleAction DiscardChanges where
+        case mbDocHistory of
-  handleAction _ _ _ = pure ()
+          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 ->
+            -> modifyingCurrentDocument uiElts vars \ doc -> do
-                pure ( UpdateDocTo $ Just ( deleteSelected mode doc ) )
+                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 ()
-
+        pure do
-      updateInfoBar viewportDrawingArea infoBar vars
+          updateInfoBar viewportDrawingArea infoBar vars ( Just doc )
-      GTK.widgetQueueDraw viewportDrawingArea
+          GTK.widgetQueueDraw viewportDrawingArea
-      for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
+          for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
-        GTK.widgetQueueDraw drawingArea
+            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 ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectRectangle mode selMode pos0 pos doc )
-                    _ -> pure ( UpdateDocTo $ Just $ selectAt mode selMode 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 )
+          pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc )
-        updateInfoBar viewportDrawingArea infoBar vars
 
 --------------------
 -- Keyboard press --

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
 

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' )
+  ( TVar )
-
--- text
-import Data.Text
-  ( Text )
-
--- transformers
-import Control.Monad.Trans.Class
-  ( lift )
-import Control.Monad.Trans.Maybe
-  ( MaybeT(..) )
 
 -- 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 )             )
+  , activeDocumentTVar :: !( STM.TVar ( Maybe Unique )                            )
-  , openDocumentsTVar  :: !( STM.TVar ( Map Unique Document )      )
+  , openDocumentsTVar  :: !( STM.TVar ( Map Unique DocumentHistory )              )
-  , mousePosTVar       :: !( STM.TVar ( Maybe ( Point2D Double ) ) )
+  , mousePosTVar       :: !( STM.TVar ( Maybe ( Point2D Double ) )                )
-  , mouseHoldTVar      :: !( STM.TVar ( Maybe HoldAction )         )
+  , mouseHoldTVar      :: !( STM.TVar ( Maybe HoldAction )                        )
-  , modifiersTVar      :: !( STM.TVar ( Set Modifier )             )
+  , modifiersTVar      :: !( STM.TVar ( Set Modifier )                            )
-  , toolTVar           :: !( STM.TVar Tool                         )
+  , toolTVar           :: !( STM.TVar Tool                                        )
-  , modeTVar           :: !( STM.TVar Mode                         )
+  , modeTVar           :: !( STM.TVar Mode                                        )
-  , partialPathTVar    :: !( STM.TVar ( Maybe PartialPath )        )
+  , partialPathTVar    :: !( STM.TVar ( Maybe PartialPath )                       )
-  , fileBarTabsTVar    :: !( STM.TVar ( Map Unique GTK.Box )       )
+  , fileBarTabsTVar    :: !( STM.TVar ( Map Unique ( GTK.Box, GTK.RadioButton ) ) )
-  , showGuidesTVar     :: !( STM.TVar Bool                         )
+  , showGuidesTVar     :: !( STM.TVar Bool                                        )
-  , fitParametersTVar  :: !( STM.TVar FitParameters                )
+  , 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"

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
+  { displayName     :: !Text
-    , mbFilePath     :: !( Maybe FilePath )
+  , mbFilePath      :: !( Maybe FilePath )
-    , unsavedChanges :: !Bool
+  , viewportCenter  :: !( Point2D Double )
-    , viewportCenter :: !( Point2D Double )
+  , zoomFactor      :: !Double
-    , zoomFactor     :: !Double
+  , documentUnique  :: Unique
-    , documentUnique :: Unique
+  , documentContent :: !DocumentContent
-    , strokes        :: ![ Stroke ]
+  }
-    , guides         :: !( Map Unique Guide )
+  deriving stock    ( Show, Generic )
-    }
+  deriving anyclass NFData
-  deriving stock ( Show, Generic )
+
+-- | 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
+    { displayName     = docName
-    , mbFilePath     = Nothing
+    , mbFilePath      = Nothing
-    , unsavedChanges = False
+    , viewportCenter  = Point2D 0 0
-    , viewportCenter = Point2D 0 0
+    , zoomFactor      = 1
-    , zoomFactor     = 1
+    , documentUnique  = unique
-    , documentUnique = unique
+    , documentContent =
-    , strokes        = []
+      Content
-    , guides         = Map.empty
+      { 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

src/app/MetaBrush/Document/Draw.hs

@@ -1,8 +1,9 @@
-{-# LANGUAGE DataKinds          #-}
+{-# LANGUAGE DataKinds             #-}
-{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DerivingStrategies    #-}
-{-# LANGUAGE NamedFieldPuns     #-}
+{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE NamedFieldPuns        #-}
-{-# LANGUAGE TypeApplications   #-}
+{-# 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' =
+        newDoc'
-          over ( field' @"strokes" )
+          = over ( field' @"documentContent" )
-            ( Stroke
+            ( over ( field' @"strokes" )
-              { strokeName    = "Stroke " <> uniqueText uniq
+                ( Stroke
-              , strokeVisible = True
+                  { strokeName    = "Stroke " <> uniqueText uniq
-              , strokeUnique  = uniq
+                  , strokeVisible = True
-              , strokePoints  = Seq.singleton $ PathPoint c ( PointData Normal Empty )
+                  , strokeUnique  = uniq
-              }
+                  , strokePoints  = Seq.singleton $ PathPoint c ( PointData Normal Empty )
-            : )
+                  }
-            newDoc
+                : )
-      pure ( newDoc' { unsavedChanges = True }, AnchorAtEnd uniq, c )
+            . 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 -> State ( Maybe ( ( DrawAnchor, Point2D Double ), Text ) ) Stroke
-    updateStroke stroke@( Stroke { strokeVisible, strokePoints, strokeUnique } ) = do
+    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 } )

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

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 -> Vector2D Double -> Document -> ( Document, Bool )
-translateSelection mode t
+translateSelection mode t doc =
-  | Brush <- mode
+  ( `runState` False ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc
-  = over ( field' @"strokes" . mapped . field' @"strokePoints" . mapped . field' @"pointData" . field' @"brushShape" . mapped )
+
-    updateStrokePoint
-  . set ( field' @"unsavedChanges" ) True
-  | otherwise
-  = over ( field' @"strokes" . mapped . field' @"strokePoints" . mapped )
-    updateStrokePoint
-  . set ( field' @"unsavedChanges" ) True
   where
-    updateStrokePoint :: HasType FocusState pt => StrokePoint pt -> StrokePoint pt
+    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 -> Document -> ( Document, Bool )
-deleteSelected mode doc = fst . runIdentity . ( `Tardis.runTardisT` ( False, False ) ) $ case mode of
+deleteSelected mode doc
-  Brush ->
+  = first fst . runIdentity . ( `runStateT` False ) . ( `Tardis.runTardisT` ( False, False ) )
-    ( field' @"strokes" . traverse . field' @"strokePoints" . traverse . field' @"pointData" . field' @"brushShape" )
+  $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc
-      updateStroke
-      doc'
-  _     ->
-    ( field' @"strokes" . traverse . field' @"strokePoints" )
-      updateStroke
-      doc'
   where
-    doc' :: Document
+    updateStroke :: Stroke -> TardisT Bool Bool ( State Bool ) Stroke
-    doc' = doc { unsavedChanges = True }
+    updateStroke stroke@( Stroke { strokeVisible } )
-    updateStroke
+      | 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 ) )
+      -> TardisT Bool Bool ( State Bool ) ( Seq ( StrokePoint pt ) )
-    updateStroke Empty = pure Empty
+    updateStrokePoints Empty = pure Empty
-    updateStroke ( p :<| ps ) = case p of
+    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,

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
+decodeDocumentContent :: MonadIO m => UniqueSupply -> JSON.Decoder m DocumentContent
-encodeDocument = JSON.Encoder.mapLikeObj \ ( Document { displayName, viewportCenter, zoomFactor, strokes, guides } ) ->
+decodeDocumentContent uniqueSupply = do
-    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
   let
     unsavedChanges :: Bool
     unsavedChanges = False
-  viewportCenter <- JSON.Decoder.atKey "center" ( decodePoint2D decodeDouble )
+    latestChange :: Text
-  zoomFactor     <- JSON.Decoder.atKey "zoom"   decodeDouble
+    latestChange = "Load document"
-  documentUnique <- lift ( liftIO . STM.atomically $ freshUnique uniqueSupply )
+  strokes <- JSON.Decoder.atKey "strokes" ( JSON.Decoder.list ( decodeStroke uniqueSupply ) )
-  strokes        <- JSON.Decoder.atKey "strokes" ( JSON.Decoder.list ( decodeStroke uniqueSupply ) )
+  guides  <- JSON.Decoder.atKey "guides"  ( decodeUniqueMap   ( decodeGuide  uniqueSupply ) )
-  guides         <- JSON.Decoder.atKey "guides"  ( decodeUniqueMap   ( decodeGuide  uniqueSupply ) )
+  pure ( Content { unsavedChanges, latestChange, strokes, guides } )
-  pure ( Document { displayName, mbFilePath, unsavedChanges, viewportCenter, zoomFactor, documentUnique, 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 } )

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

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

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

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 ]

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
+      Just docHist -> do pure docHist
-        pure doc
       -- 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
+    uiUpdateAction <- STM.atomically do
-      STM.modifyTVar' openDocumentsTVar  ( Map.insert newUnique newDoc )
+      STM.modifyTVar' openDocumentsTVar  ( Map.insert newUnique newDocHist )
-      STM.modifyTVar' fileBarTabsTVar    ( Map.insert newUnique tab )
+      STM.modifyTVar' fileBarTabsTVar    ( Map.insert newUnique ( tab, pgButton ) )
-      STM.writeTVar   activeDocumentTVar ( Just newUnique )
+      -- 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)
-    GTK.widgetQueueDraw viewportDrawingArea
+      if initialStage
-    updateInfoBar viewportDrawingArea infoBar vars
+      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
+        handleAction uiElts vars ( SwitchTo newUnique )
-          ( 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 )

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
+import MetaBrush.Document.History
-  ( Document )
+  ( DocumentHistory )
 import {-# SOURCE #-} MetaBrush.UI.InfoBar
   ( InfoBar )
 import {-# SOURCE #-} MetaBrush.UI.Menu
@@ -47,8 +47,9 @@ createFileBar
   -> IO FileBar
 
 newFileTab
-  :: UIElements -> Variables
+  :: Bool
-  -> Maybe Document -> TabLocation
+  -> UIElements -> Variables
+  -> Maybe DocumentHistory -> TabLocation
   -> IO ()
 
 removeFileTab :: Variables -> Unique -> IO ()

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(..)
+  ( Variables(..) )
-  , currentDocument
-  )
 import MetaBrush.Document
   ( Document(..) )
 import MetaBrush.UI.Coordinates
@@ -161,12 +157,11 @@ createInfoBar colours = do
 
   pure ( InfoBar {..} )
 
-updateInfoBar :: GTK.DrawingArea -> InfoBar -> Variables -> IO ()
+updateInfoBar :: GTK.DrawingArea -> InfoBar -> Variables -> Maybe Document -> IO ()
-updateInfoBar viewportDrawingArea ( InfoBar {..} ) vars@( Variables { mousePosTVar } )
+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

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

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

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 )