Fix animation widget raising onFinished event when it is no longer re…

…levant (#252)

* fix animation bug

* update animation tests

src/Monomer/Widgets/Animation/Fade.hs

@@ -157,7 +157,7 @@ makeFade isFadeIn config state = widget where
   period = 20
   steps = fromIntegral $ duration `div` period
 
-  finishedReq node = delayedMessage node AnimationFinished duration
+  finishedReq node ts = delayedMessage node (AnimationFinished ts) duration
   renderReq wenv node = req where
     widgetId = node ^. L.info . L.widgetId
     req = RenderEvery widgetId period (Just steps)
@@ -167,7 +167,7 @@ makeFade isFadeIn config state = widget where
     newNode = node
       & L.widget .~ makeFade isFadeIn config (FadeState True ts)
     result
-      | autoStart = resultReqs newNode [finishedReq node, renderReq wenv node]
+      | autoStart = resultReqs newNode [finishedReq node ts, renderReq wenv node]
       | otherwise = resultNode node
 
   merge wenv node oldNode oldState = resultNode newNode where
@@ -181,16 +181,17 @@ makeFade isFadeIn config state = widget where
     widgetId = node ^. L.info . L.widgetId
     ts = wenv ^. L.timestamp
     startState = FadeState True ts
-    startReqs = [finishedReq node, renderReq wenv node]
+    startReqs = [finishedReq node ts, renderReq wenv node]
 
     newNode newState = node
       & L.widget .~ makeFade isFadeIn config newState
     result = case msg of
       AnimationStart -> resultReqs (newNode startState) startReqs
       AnimationStop -> resultReqs (newNode def) [RenderStop widgetId]
-      AnimationFinished
-        | _fdsRunning state -> resultEvts node (_fdcOnFinished config)
+      AnimationFinished ts'
+        | isRelevant -> resultEvts node (_fdcOnFinished config)
         | otherwise -> resultNode node
+        where isRelevant = _fdsRunning state && ts' == _fdsStartTs state
 
   render wenv node renderer = do
     saveContext renderer

src/Monomer/Widgets/Animation/Slide.hs

@@ -190,7 +190,7 @@ makeSlide isSlideIn config state = widget where
   period = 20
   steps = fromIntegral $ duration `div` period
 
-  finishedReq node = delayedMessage node AnimationFinished duration
+  finishedReq node ts = delayedMessage node (AnimationFinished ts) duration
   renderReq wenv node = req where
     widgetId = node ^. L.info . L.widgetId
     req = RenderEvery widgetId period (Just steps)
@@ -200,7 +200,7 @@ makeSlide isSlideIn config state = widget where
     newNode = node
       & L.widget .~ makeSlide isSlideIn config (SlideState True ts)
     result
-      | autoStart = resultReqs newNode [finishedReq node, renderReq wenv node]
+      | autoStart = resultReqs newNode [finishedReq node ts, renderReq wenv node]
       | otherwise = resultNode node
 
   merge wenv node oldNode oldState = resultNode newNode where
@@ -214,16 +214,17 @@ makeSlide isSlideIn config state = widget where
     widgetId = node ^. L.info . L.widgetId
     ts = wenv ^. L.timestamp
     startState = SlideState True ts
-    startReqs = [finishedReq node, renderReq wenv node]
+    startReqs = [finishedReq node ts, renderReq wenv node]
 
     newNode newState = node
       & L.widget .~ makeSlide isSlideIn config newState
     result = case msg of
       AnimationStart -> resultReqs (newNode startState) startReqs
       AnimationStop -> resultReqs (newNode def) [RenderStop widgetId]
-      AnimationFinished
-        | _slsRunning state -> resultEvts node (_slcOnFinished config)
+      AnimationFinished ts'
+        | isRelevant -> resultEvts node (_slcOnFinished config)
         | otherwise -> resultNode node
+        where isRelevant = _slsRunning state && ts' == _slsStartTs state
 
   render wenv node renderer = do
     saveContext renderer

src/Monomer/Widgets/Animation/Types.hs

@@ -10,6 +10,8 @@ Common types for animation widgets.
 -}
 module Monomer.Widgets.Animation.Types where
 
+import Monomer.Core.WidgetTypes (Millisecond)
+
 -- | Message animation widgets usually support. Controls animation state.
 data AnimationMsg
   -- | Starts the animation from the beginning, even if it's running.
@@ -20,5 +22,5 @@ data AnimationMsg
   Indicates the animation has finished. This is usually generated by the widget
   itself for clean up.
   -}
-  | AnimationFinished
+  | AnimationFinished Millisecond
   deriving (Eq, Show)

test/unit/Monomer/Widgets/Animation/FadeSpec.hs

@@ -73,7 +73,7 @@ handleMessage = describe "handleMessage" $ do
     evts AnimationStop `shouldBe` Seq.empty
 
   it "should generate an event if AnimationFinished is received" $
-    evts AnimationFinished `shouldBe` Seq.singleton OnTestFinished
+    evts (AnimationFinished 0) `shouldBe` Seq.singleton OnTestFinished
 
   where
     wenv = mockWenv ()

test/unit/Monomer/Widgets/Animation/SlideSpec.hs

@@ -73,7 +73,7 @@ handleMessage = describe "handleMessage" $ do
     evts AnimationStop `shouldBe` Seq.empty
 
   it "should generate an event if AnimationFinished is received" $
-    evts AnimationFinished `shouldBe` Seq.singleton OnTestFinished
+    evts (AnimationFinished 0) `shouldBe` Seq.singleton OnTestFinished
 
   where
     wenv = mockWenv ()