proper fix for brush widget action applying to all strokes

src/metabrushes/MetaBrush/Action.hs

@@ -112,11 +112,16 @@ import MetaBrush.Document
 import MetaBrush.Document.Diff
 import MetaBrush.Hover
   ( inPointClickRange )
+import MetaBrush.Layer
+  ( Parent, WithinParent (..) )
 import MetaBrush.Records
 import MetaBrush.Stroke
 import MetaBrush.Unique
   ( Unique )
-import MetaBrush.Layer (Parent, WithinParent (..))
+
+
+import Debug.Utils
+  ( trace )
 
 --------------------------------------------------------------------------------
 -- Subdivision.
@@ -935,32 +940,32 @@ data BrushWidgetActionState brushFields
 deriving stock instance Show ( Record brushFields ) => Show ( BrushWidgetActionState brushFields )
 deriving stock instance   Eq ( Record brushFields ) => Eq   ( BrushWidgetActionState brushFields )
 
-data WidgetFwd act =
+data WidgetFwd =
   WidgetFwd
-    { mbPastAction         :: !( Maybe act )
+    { mbPastAction         :: !( Maybe ABrushWidgetActionState )
     , changeInPrevCurve    :: !Bool
     , pastActionPropagates :: !Bool
     }
 
-data WidgetBwd act =
+data WidgetBwd =
   WidgetBwd
-    { mbFuturePropagatingAction :: !( Maybe act ) }
+    { mbFuturePropagatingAction :: !( Maybe ABrushWidgetActionState ) }
 
 
-type WidgetM :: Type -> Type -> Type
-type WidgetM act = Tardis ( WidgetBwd act ) ( WidgetFwd act )
+type WidgetM :: Type -> Type
+type WidgetM = Tardis WidgetBwd WidgetFwd
 
 -- | Apply a brush widget action, e.g. rotating or scaling the brush at a particular stroke point.
 applyBrushWidgetAction :: Bool -> Bool -> ℝ 2 -> Maybe ABrushWidgetActionState -> Document -> Maybe ( Document, ABrushWidgetActionState )
 applyBrushWidgetAction pressingCtrl pressingAlt c mbPrevAction doc@( Document { documentContent, documentMetadata } ) =
   let
-    ( newStrokes, mbAct ) =
-      ( `State.runState` Nothing ) $
+    ( newStrokes, ( _bwd, WidgetFwd { mbPastAction = mbNewAction } ) ) =
+      ( `Tardis.runTardis` ( WidgetBwd Nothing, WidgetFwd mbPrevAction False False ) ) $
         forStrokeHierarchy
           ( layerMetadata documentMetadata )
           ( strokeHierarchy documentContent )
           updateStroke
-  in mbAct <&> \ act ->
+  in mbNewAction <&> \ act ->
       ( set ( field' @"documentContent" . field' @"strokeHierarchy" ) newStrokes doc
       , act
       )
@@ -968,7 +973,7 @@ applyBrushWidgetAction pressingCtrl pressingAlt c mbPrevAction doc@( Document {
 
     zoom = documentZoom $ documentMetadata
 
-    updateStroke :: WithinParent Unique -> Stroke -> StrokeMetadata -> State ( Maybe ABrushWidgetActionState ) UpdateStroke
+    updateStroke :: WithinParent Unique -> Stroke -> StrokeMetadata -> WidgetM UpdateStroke
     updateStroke ( WithinParent _ u )
       ( Stroke { strokeBrush, strokeSpline = oldSpline :: StrokeSpline clo ( Record pointFields ) } )
       ( StrokeMetadata { strokeVisible, strokeLocked } )
@@ -981,26 +986,22 @@ applyBrushWidgetAction pressingCtrl pressingAlt c mbPrevAction doc@( Document {
       , Union @pointFields' unionWith
           <- union @pointFields @brushFields
       = do
-          let ( res, ( _bwd, WidgetFwd { mbPastAction = mbAction } ) ) =
-                ( `Tardis.runTardis` ( WidgetBwd Nothing, WidgetFwd Nothing False False ) ) $ do
-                  let defaultBrushParams = MkR $ defaultParams $ brushFunction brush
-                      embedUsedParams = updateBrushParams defaultBrushParams
-                      toBrushParams = embedUsedParams . ptParamsToUsedParams
-                      noUpdatePointParams :: Record pointFields -> Record pointFields'
-                      noUpdatePointParams p = unionWith ( \ pt _ -> pt ) p defaultBrushParams
-                      updatePointParams :: Record brushFields -> Record pointFields -> Record pointFields'
-                      updatePointParams b p = unionWith ( \ _ brushParam' -> brushParam' ) p b
-                  spline' <-
-                      bitraverseSpline
-                        ( updateSplineCurve ( splineStart oldSpline ) brush toBrushParams noUpdatePointParams updatePointParams u )
-                        ( updateSplinePoint brush toBrushParams noUpdatePointParams updatePointParams u FirstPoint )
-                        oldSpline
-                  WidgetFwd { mbPastAction = mbAct } <- Tardis.getPast
-                  case mbAct of
-                    Nothing -> return PreserveStroke
-                    Just {} -> return $ UpdateStrokeTo $ Stroke { strokeBrush, strokeSpline = spline' }
-          State.put $ ABrushWidgetActionState <$> mbAction
-          return res
+          let defaultBrushParams = MkR $ defaultParams $ brushFunction brush
+              embedUsedParams = updateBrushParams defaultBrushParams
+              toBrushParams = embedUsedParams . ptParamsToUsedParams
+              noUpdatePointParams :: Record pointFields -> Record pointFields'
+              noUpdatePointParams p = unionWith ( \ pt _ -> pt ) p defaultBrushParams
+              updatePointParams :: Record brushFields -> Record pointFields -> Record pointFields'
+              updatePointParams b p = unionWith ( \ _ brushParam' -> brushParam' ) p b
+          spline' <-
+              bitraverseSpline
+                ( updateSplineCurve ( splineStart oldSpline ) brush toBrushParams noUpdatePointParams updatePointParams u )
+                ( updateSplinePoint brush toBrushParams noUpdatePointParams updatePointParams u FirstPoint )
+                oldSpline
+          WidgetFwd { mbPastAction = mbAct } <- Tardis.getPast
+          case mbAct of
+            Nothing -> return PreserveStroke
+            Just {} -> return $ UpdateStrokeTo $ Stroke { strokeBrush, strokeSpline = spline' }
       | otherwise
       = return PreserveStroke
 
@@ -1018,7 +1019,7 @@ applyBrushWidgetAction pressingCtrl pressingAlt c mbPrevAction doc@( Document {
       -> ( Record brushFields -> pointParams -> pointParams' )
       -> Unique
       -> PointData pointParams -> Curve clo' ( CurveData RealWorld ) ( PointData pointParams )
-      -> WidgetM ( BrushWidgetActionState brushFields ) ( Curve clo' ( CurveData RealWorld ) ( PointData pointParams' ) )
+      -> WidgetM ( Curve clo' ( CurveData RealWorld ) ( PointData pointParams' ) )
     updateSplineCurve _start brush toBrushParams noUpdatePointParams updatePointParams uniq _sp0 curve = do
       WidgetFwd { changeInPrevCurve } <- Tardis.getPast
       -- There are two kinds of brush widget updates:
@@ -1030,7 +1031,7 @@ applyBrushWidgetAction pressingCtrl pressingAlt c mbPrevAction doc@( Document {
       --        - we are continuing an operation, and we have the right curve index
       --   - Synchronising an update on other selected points.
       let updPt = updateSplinePoint brush toBrushParams noUpdatePointParams updatePointParams uniq
-          updDat :: CurveData RealWorld -> WidgetM ( BrushWidgetActionState brushFields )( CurveData RealWorld )
+          updDat :: CurveData RealWorld -> WidgetM ( CurveData RealWorld )
           updDat dat = do
             WidgetFwd { changeInPrevCurve = newChange } <- Tardis.getPast
             if newChange
@@ -1085,7 +1086,7 @@ applyBrushWidgetAction pressingCtrl pressingAlt c mbPrevAction doc@( Document {
       -> ( Record brushFields -> pointParams -> pointParams' )
       -> Unique -> PointIndex
       -> PointData pointParams
-      -> WidgetM ( BrushWidgetActionState brushFields ) ( PointData pointParams' )
+      -> WidgetM ( PointData pointParams' )
     updateSplinePoint brush toBrushParams noUpdatePointParams updatePointParams uniq j pt = do
       WidgetFwd
         { mbPastAction = mbPastAct
@@ -1130,7 +1131,7 @@ applyBrushWidgetAction pressingCtrl pressingAlt c mbPrevAction doc@( Document {
                     }
               Tardis.sendFuture $
                 WidgetFwd
-                  { mbPastAction         = Just newAction
+                  { mbPastAction         = Just $ ABrushWidgetActionState newAction
                   , changeInPrevCurve    = True
                   , pastActionPropagates = True -- currentPointSelected
                   }
@@ -1139,7 +1140,7 @@ applyBrushWidgetAction pressingCtrl pressingAlt c mbPrevAction doc@( Document {
                   { mbFuturePropagatingAction =
                     --if currentPointSelected
                     --then
-                      Just newAction
+                      Just $ ABrushWidgetActionState newAction
                     --else Nothing
                   }
               return $ upd newParams
@@ -1150,7 +1151,7 @@ applyBrushWidgetAction pressingCtrl pressingAlt c mbPrevAction doc@( Document {
                   <- Tardis.getFuture
               return $
                 let
-                  propagatingAct :: Maybe ( BrushWidgetActionState brushFields )
+                  propagatingAct :: Maybe ABrushWidgetActionState
                   propagatingAct
                     | Just a <- mbPastAct
                     , pastActionPropagates
@@ -1159,7 +1160,8 @@ applyBrushWidgetAction pressingCtrl pressingAlt c mbPrevAction doc@( Document {
                     = mbFutureAct
                 in
                   if
-                    | Just propAct <- propagatingAct
+                    | Just ( ABrushWidgetActionState @brushFields'' propAct ) <- propagatingAct
+                    , Just Refl <- eqT @brushFields @brushFields''
                     , BrushWidgetActionState
                         { brushWidgetAction = action
                         , brushWidgetPrevParams = params0
@@ -1200,7 +1202,7 @@ applyBrushWidgetAction pressingCtrl pressingAlt c mbPrevAction doc@( Document {
                       }
               Tardis.sendFuture $
                 WidgetFwd
-                  { mbPastAction         = Just newAction
+                  { mbPastAction         = Just $ ABrushWidgetActionState newAction
                   , changeInPrevCurve    = False
                   , pastActionPropagates = False
                   }