fix time-travel issue in deletion code

src/app/MetaBrush/Document/Selection.hs

@@ -58,7 +58,7 @@ import Control.Lens
 
 -- tardis
 import Control.Monad.Trans.Tardis
-  ( Tardis, TardisT )
+  ( Tardis )
 import qualified Control.Monad.Trans.Tardis as Tardis
   ( TardisT(..)
   , getPast, getFuture, sendPast, sendFuture
@@ -68,8 +68,8 @@ import qualified Control.Monad.Trans.Tardis as Tardis
 import Control.Monad.Trans.Class
   ( lift )
 import Control.Monad.Trans.State.Strict
-  ( StateT(..)
-  , State, runState, evalState, get, put, modify'
+  ( StateT(..), State, runState, evalState
+  , get, put, modify
   )
 
 -- MetaBrush
@@ -296,15 +296,24 @@ data UpdateInfo
   deriving ( Semigroup, Monoid )
     via Generically UpdateInfo
 
-recordPointUpdate :: Unique -> StrokePoint d -> State UpdateInfo ()
-recordPointUpdate uniq ( PathPoint {} ) = modify'
-  ( over ( field' @"pathPointsAffected" ) (<>1)
-  . over ( field' @"strokesAffected" ) ( Set.insert uniq )
-  )
-recordPointUpdate uniq ( ControlPoint {} ) = modify'
+-- Update the info to record a modification.
+--
+-- Needs to be lazy in the given Boolean, to avoid time paradoxes.
+recordPointUpdate :: Monad m => Bool -> Unique -> StrokePoint d -> StateT UpdateInfo m ()
+recordPointUpdate doUpdate uniq ( PathPoint {} ) = modify $
+  if doUpdate
+  then
+    ( over ( field' @"pathPointsAffected" ) (<>1)
+    . over ( field' @"strokesAffected" ) ( Set.insert uniq )
+    )
+  else id
+recordPointUpdate doUpdate uniq ( ControlPoint {} ) = modify $
+  if doUpdate
+  then
   ( over ( field' @"controlPointsAffected" ) (<>1)
   . over ( field' @"strokesAffected" ) ( Set.insert uniq )
   )
+  else id
 
 -- | Translate all selected points by the given vector.
 --
@@ -330,7 +339,7 @@ translateSelection mode t doc =
     updateStrokePoint :: HasType FocusState pt => Unique -> StrokePoint pt -> State UpdateInfo ( StrokePoint pt )
     updateStrokePoint uniq pt
       | Selected <- view _selection pt
-      =  recordPointUpdate uniq pt
+      =  recordPointUpdate True uniq pt
       $> pt { coords = t • coords pt }
       | otherwise
       = pure pt
@@ -339,16 +348,15 @@ translateSelection mode t doc =
 --
 -- Returns the updated document, together with info about how many points were deleted.
 deleteSelected :: Mode -> Document -> ( Document, UpdateInfo )
-deleteSelected mode doc = ( newDoc, updateInfo )
+deleteSelected mode doc = deletionResult
   where
 
-    newDoc :: Document
-    updateInfo :: UpdateInfo
-    ( ( newDoc, _ ), updateInfo )
-      = runIdentity . ( `runStateT` mempty ) . ( `Tardis.runTardisT` ( False, False ) )
+    deletionResult :: ( Document, UpdateInfo )
+    deletionResult
+      = fst . runIdentity . ( `Tardis.runTardisT` ( False, False ) ) . ( `runStateT` mempty )
       $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc
 
-    updateStroke :: Stroke -> TardisT Bool Bool ( State UpdateInfo ) Stroke
+    updateStroke :: Stroke -> StateT UpdateInfo ( Tardis Bool Bool ) Stroke
     updateStroke stroke@( Stroke { strokeVisible, strokeUnique } )
       | not strokeVisible
       = pure stroke
@@ -365,24 +373,24 @@ deleteSelected mode doc = ( newDoc, updateInfo )
       :: forall pt
       .  HasType FocusState pt
       => Unique -> Seq ( StrokePoint pt )
-      -> TardisT Bool Bool ( State UpdateInfo ) ( Seq ( StrokePoint pt ) )
+      -> StateT UpdateInfo ( Tardis Bool Bool ) ( Seq ( StrokePoint pt ) )
     updateStrokePoints _    Empty = pure Empty
     updateStrokePoints uniq ( p :<| ps ) = case p of
       PathPoint {}
         | Selected <- selectionState
         -> do
-          Tardis.sendPast   True
-          Tardis.sendFuture True
-          lift ( recordPointUpdate uniq p )
+          lift ( Tardis.sendPast   True )
+          lift ( Tardis.sendFuture True )
+          recordPointUpdate True uniq p
           updateStrokePoints uniq ps
         | otherwise
         -> do
-          Tardis.sendPast   False
-          Tardis.sendFuture False
+          lift ( Tardis.sendPast   False )
+          lift ( Tardis.sendFuture False )
           ( p :<| ) <$> updateStrokePoints uniq ps
       _ -> do
-        prevPathPointDeleted <- Tardis.getPast
-        nextPathPointDeleted <- Tardis.getFuture
+        prevPathPointDeleted <- lift Tardis.getPast
+        nextPathPointDeleted <- lift Tardis.getFuture
         rest <- updateStrokePoints uniq ps
         let
           -- Control point must be deleted:
@@ -391,17 +399,13 @@ deleteSelected mode doc = ( newDoc, updateInfo )
           --  - if the next path point is going to be deleted.
           --
           -- Need to be lazy in "nextPathPointDeleted" to avoid looping.
-          res :: Seq ( StrokePoint pt )
-          stateAction :: State UpdateInfo ()
-          ( res, stateAction )
-            | selectionState == Selected
+          needsDeletion :: Bool
+          needsDeletion
+            =  selectionState == Selected
             || prevPathPointDeleted
             || nextPathPointDeleted
-            = ( rest, recordPointUpdate uniq p )
-            | otherwise
-            = ( p :<| rest, pure () )
-        lift stateAction
-        pure res
+        recordPointUpdate needsDeletion uniq p
+        pure $ if needsDeletion then rest else ( p :<| rest )
       where
         selectionState :: FocusState
         selectionState = view _selection p