Add UpdateWidgetId request, handle it in Handlers/WidgetTask

app/Main.hs

@@ -59,7 +59,16 @@ handleAppEvent
   -> AppEvent
   -> [AppEventResponse App AppEvent]
 handleAppEvent wenv model evt = case evt of
-  IncButton -> [Model (model & clickCount %~ (+1))]
+  IncButton -> [Model (model & clickCount %~ (+1)),
+    Task $ do
+      threadDelay 1000000
+      putStrLn "Done 1"
+      return Nothing,
+    Task $ do
+      threadDelay 2000000
+      putStrLn "Done 2"
+      return Nothing
+    ]
 --  PrintMessage txt -> Model (model & showAlert .~ True)
   PrintMessage txt -> [Task $ do
     print txt
@@ -107,7 +116,14 @@ handleAppEvent wenv model evt = case evt of
   _ -> []
 
 buildUI :: WidgetEnv App AppEvent -> App -> WidgetNode App AppEvent
-buildUI wenv model = trace "Creating UI" widgetTree where
+buildUI wenv model = trace "Creating UI" widgetIdChanged where
+  widgetIdChanged = vstack [
+      button "Show label" IncButton,
+      hstack $ [label "First" | model ^. clickCount > 0] ++ [
+        label "Test",
+        image_ "https://picsum.photos/600/400" [fitFill, onLoadError ImageMsg]
+      ]
+    ]
   widgetInput = vstack [
       dropdown_ dropdown1 items label label [maxHeight 200],
       hgrid [

src/Monomer/Core/Lens.hs

@@ -33,6 +33,7 @@ makeLensesWith abbreviatedFields ''WidgetEnv
 makeLensesWith abbreviatedFields ''WidgetRequest
 makeLensesWith abbreviatedFields ''WidgetResult
 makeLensesWith abbreviatedFields ''WidgetData
+makeLensesWith abbreviatedFields ''WidgetId
 makeLensesWith abbreviatedFields ''WidgetNode
 makeLensesWith abbreviatedFields ''WidgetNodeInfo
 makeLensesWith abbreviatedFields ''WidgetInstanceNode

src/Monomer/Core/WidgetTypes.hs

@@ -57,7 +57,7 @@ data WidgetData s a
 data WidgetId = WidgetId {
   _widTs :: Int,
   _widPath :: Path
-} deriving (Eq, Show)
+} deriving (Eq, Show, Ord)
 
 instance Default WidgetId where
   def = WidgetId 0 rootPath
@@ -89,9 +89,10 @@ data WidgetRequest s
   | ExitApplication Bool
   | UpdateWindow WindowRequest
   | UpdateModel (s -> s)
+  | UpdateWidgetPath WidgetId Path
   | forall i . Typeable i => SendMessage Path i
-  | forall i . Typeable i => RunTask Path (IO i)
+  | forall i . Typeable i => RunTask WidgetId Path (IO i)
-  | forall i . Typeable i => RunProducer Path ((i -> IO ()) -> IO ())
+  | forall i . Typeable i => RunProducer WidgetId Path ((i -> IO ()) -> IO ())
 
 data WidgetResult s e = WidgetResult {
   _wrNode :: WidgetNode s e,
@@ -314,6 +315,7 @@ instance Show (WidgetRequest s) where
   show ExitApplication{} = "ExitApplication"
   show (UpdateWindow req) = "UpdateWindow: " ++ show req
   show UpdateModel{} = "UpdateModel"
+  show (UpdateWidgetPath wid path) = "UpdateWidgetPath: " ++ show (wid, path)
   show SendMessage{} = "SendMessage"
   show RunTask{} = "RunTask"
   show RunProducer{} = "RunProducer"

src/Monomer/Main/Handlers.hs

@@ -13,7 +13,8 @@ module Monomer.Main.Handlers (
 ) where
 
 import Control.Concurrent.Async (async)
-import Control.Lens ((&), (^.), (.~), (%~), (.=), (?=), at, non, use)
+import Control.Lens (
+  (&), (^.), (.~), (%~), (.=), (%=), (?=), ix, at, non, use, _1)
 import Control.Monad.STM (atomically)
 import Control.Concurrent.STM.TChan (TChan, newTChanIO, writeTChan)
 import Control.Applicative ((<|>))
@@ -194,9 +195,10 @@ handleRequests reqs step = foldM handleRequest step reqs where
     ExitApplication exit -> handleExitApplication exit step
     UpdateWindow req -> handleUpdateWindow req step
     UpdateModel fn -> handleUpdateModel fn step
+    UpdateWidgetPath wid path -> handleUpdateWidgetPath wid path step
     SendMessage path msg -> handleSendMessage path msg step
-    RunTask path handler -> handleRunTask path handler step
+    RunTask wid path handler -> handleRunTask wid path handler step
-    RunProducer path handler -> handleRunProducer path handler step
+    RunProducer wid path handler -> handleRunProducer wid path handler step
 
 handleResizeWidgets
   :: (MonomerM s m)
@@ -368,6 +370,12 @@ handleUpdateModel fn (wenv, evts, root) = do
   where
     wenv2 = wenv & L.model %~ fn
 
+handleUpdateWidgetPath
+  :: (MonomerM s m) => WidgetId -> Path -> HandlerStep s e -> m (HandlerStep s e)
+handleUpdateWidgetPath wid path step = do
+  setWidgetIdPath wid path
+  return step
+
 handleSendMessage
   :: forall s e m msg . (MonomerM s m, Typeable msg)
   => Path
@@ -386,29 +394,35 @@ handleSendMessage path message (wenv, events, widgetRoot) = do
 
 handleRunTask
   :: forall s e m i . (MonomerM s m, Typeable i)
-  => Path
+  => WidgetId
+  -> Path
   -> IO i
   -> HandlerStep s e
   -> m (HandlerStep s e)
-handleRunTask path handler previousStep = do
+handleRunTask widgetId path handler previousStep = do
   asyncTask <- liftIO $ async (liftIO handler)
 
   previousTasks <- use L.widgetTasks
-  L.widgetTasks .= previousTasks |> WidgetTask path asyncTask
+  L.widgetTasks .= previousTasks |> WidgetTask widgetId asyncTask
+  addWidgetIdPath widgetId path
+
   return previousStep
 
 handleRunProducer
   :: forall s e m i . (MonomerM s m, Typeable i)
-  => Path
+  => WidgetId
+  -> Path
   -> ((i -> IO ()) -> IO ())
   -> HandlerStep s e
   -> m (HandlerStep s e)
-handleRunProducer path handler previousStep = do
+handleRunProducer widgetId path handler previousStep = do
   newChannel <- liftIO newTChanIO
   asyncTask <- liftIO $ async (liftIO $ handler (sendMessage newChannel))
 
   previousTasks <- use L.widgetTasks
-  L.widgetTasks .= previousTasks |> WidgetProducer path newChannel asyncTask
+  L.widgetTasks .= previousTasks |> WidgetProducer widgetId newChannel asyncTask
+  addWidgetIdPath widgetId path
+
   return previousStep
 
 addFocusReq
@@ -532,3 +546,11 @@ cursorToSDL CursorSizeH = SDLEnum.SDL_SYSTEM_CURSOR_SIZEWE
 cursorToSDL CursorSizeV = SDLEnum.SDL_SYSTEM_CURSOR_SIZENS
 cursorToSDL CursorDiagTL = SDLEnum.SDL_SYSTEM_CURSOR_SIZENWSE
 cursorToSDL CursorDiagTR = SDLEnum.SDL_SYSTEM_CURSOR_SIZENESW
+
+setWidgetIdPath :: (MonomerM s m) => WidgetId -> Path -> m ()
+setWidgetIdPath widgetId path =
+  L.widgetPaths . ix widgetId . _1 .= path
+
+addWidgetIdPath :: (MonomerM s m) => WidgetId -> Path -> m ()
+addWidgetIdPath widgetId path =
+  L.widgetPaths . at widgetId . non (path, 0) %= \(_, c) -> (path, c + 1)

src/Monomer/Main/Types.hs

@@ -23,6 +23,7 @@ import Monomer.Core.BasicTypes
 import Monomer.Core.Combinators
 import Monomer.Core.StyleTypes
 import Monomer.Core.ThemeTypes
+import Monomer.Core.WidgetTypes
 import Monomer.Event.Types
 import Monomer.Graphics.Types
 
@@ -35,8 +36,8 @@ data RenderSchedule = RenderSchedule {
 } deriving (Eq, Show)
 
 data WidgetTask
-  = forall i . Typeable i => WidgetTask Path (Async i)
+  = forall i . Typeable i => WidgetTask WidgetId (Async i)
-  | forall i . Typeable i => WidgetProducer Path (TChan i) (Async ())
+  | forall i . Typeable i => WidgetProducer WidgetId (TChan i) (Async ())
 
 data MonomerContext s = MonomerContext {
   _mcMainModel :: s,
@@ -51,6 +52,7 @@ data MonomerContext s = MonomerContext {
   _mcOverlayPath :: Maybe Path,
   _mcMainBtnPress :: Maybe (Path, Point),
   _mcWidgetTasks :: Seq WidgetTask,
+  _mcWidgetPaths :: Map WidgetId (Path, Int),
   _mcCursorIcons :: Map CursorIcon SDLR.Cursor,
   _mcRenderRequested :: Bool,
   _mcRenderSchedule :: Map Path RenderSchedule,

src/Monomer/Main/Util.hs

@@ -36,6 +36,7 @@ initMonomerContext model win winSize useHiDPI devicePixelRate = MonomerContext {
   _mcOverlayPath = Nothing,
   _mcMainBtnPress = Nothing,
   _mcWidgetTasks = Seq.empty,
+  _mcWidgetPaths = Map.empty,
   _mcCursorIcons = Map.empty,
   _mcRenderRequested = False,
   _mcRenderSchedule = Map.empty,

src/Monomer/Main/WidgetTask.hs

@@ -5,7 +5,7 @@ module Monomer.Main.WidgetTask (handleWidgetTasks) where
 import Control.Concurrent.Async (poll)
 import Control.Concurrent.STM.TChan (tryReadTChan)
 import Control.Exception.Base
-import Control.Lens ((&), (^.), (.=), use)
+import Control.Lens ((&), (^.), (.=), (%=), use, at, non, _1)
 import Control.Monad.Extra
 import Control.Monad.IO.Class
 import Control.Monad.STM (atomically)
@@ -19,6 +19,7 @@ import qualified Data.Sequence as Seq
 import Monomer.Core
 import Monomer.Main.Handlers
 import Monomer.Main.Lens
+import Monomer.Main.Util
 import Monomer.Main.Types
 
 import qualified Monomer.Lens as L
@@ -31,7 +32,9 @@ handleWidgetTasks wenv widgetRoot = do
   (active, finished) <- partitionM isThreadActive (toList tasks)
   widgetTasks .= Seq.fromList active
 
-  processTasks wenv widgetRoot tasks
+  result <- processTasks wenv widgetRoot tasks
+  mapM_ handleFinishedTask finished
+  return result
 
 processTasks
   :: (MonomerM s m, Traversable t)
@@ -51,41 +54,41 @@ processTask
   -> WidgetNode s e
   -> WidgetTask
   -> m (HandlerStep s e)
-processTask wenv widgetRoot (WidgetTask path task) = do
+processTask wenv widgetRoot (WidgetTask widgetId task) = do
   taskStatus <- liftIO $ poll task
 
   case taskStatus of
-    Just taskRes -> processTaskResult wenv widgetRoot path taskRes
+    Just taskRes -> processTaskResult wenv widgetRoot widgetId taskRes
     Nothing -> return (wenv, Seq.empty, widgetRoot)
-processTask model widgetRoot (WidgetProducer path channel task) = do
+processTask model widgetRoot (WidgetProducer widgetId channel task) = do
   channelStatus <- liftIO . atomically $ tryReadTChan channel
 
   case channelStatus of
-    Just taskMsg -> processTaskEvent model widgetRoot path taskMsg
+    Just taskMsg -> processTaskEvent model widgetRoot widgetId taskMsg
     Nothing -> return (model, Seq.empty, widgetRoot)
 
 processTaskResult
   :: (MonomerM s m, Typeable a)
   => WidgetEnv s e
   -> WidgetNode s e
-  -> Path
+  -> WidgetId
   -> Either SomeException a
   -> m (HandlerStep s e)
 processTaskResult wenv widgetRoot _ (Left ex) = do
   liftIO . putStrLn $ "Error processing Widget task result: " ++ show ex
   return (wenv, Seq.empty, widgetRoot)
-processTaskResult wenv widgetRoot path (Right taskResult)
+processTaskResult wenv widgetRoot widgetId (Right taskResult)
-  = processTaskEvent wenv widgetRoot path taskResult
+  = processTaskEvent wenv widgetRoot widgetId taskResult
 
 processTaskEvent
   :: (MonomerM s m, Typeable a)
   => WidgetEnv s e
   -> WidgetNode s e
-  -> Path
+  -> WidgetId
   -> a
   -> m (HandlerStep s e)
-processTaskEvent wenv widgetRoot path event = do
+processTaskEvent wenv widgetRoot widgetId event = do
-  currentFocus <- use L.focusedPath
+  path <- getWidgetIdPath widgetId
 
   let emptyResult = WidgetResult widgetRoot Seq.empty Seq.empty
   let widget = widgetRoot ^. L.widget
@@ -94,6 +97,25 @@ processTaskEvent wenv widgetRoot path event = do
 
   handleWidgetResult wenv widgetResult
 
-isThreadActive :: (MonomerM s m) => WidgetTask -> m Bool
+handleFinishedTask :: MonomerM s m => WidgetTask -> m ()
+handleFinishedTask task = delWidgetIdPath (taskWidgetId task)
+
+isThreadActive :: MonomerM s m => WidgetTask -> m Bool
 isThreadActive (WidgetTask _ task) = fmap isNothing (liftIO $ poll task)
 isThreadActive (WidgetProducer _ _ task) = fmap isNothing (liftIO $ poll task)
+
+taskWidgetId :: WidgetTask -> WidgetId
+taskWidgetId (WidgetTask widgetId _) = widgetId
+taskWidgetId (WidgetProducer widgetId _ _) = widgetId
+
+getWidgetIdPath :: (MonomerM s m) => WidgetId -> m Path
+getWidgetIdPath widgetId =
+  use $ L.widgetPaths . at widgetId . non (widgetId ^. L.path, 0) . _1
+
+delWidgetIdPath :: (MonomerM s m) => WidgetId -> m ()
+delWidgetIdPath widgetId =
+  L.widgetPaths . at widgetId %= remVal
+  where
+    remVal (Just (path, c))
+      | c > 1 = Just (path, c - 1)
+    remVal _ = Nothing

src/Monomer/Widgets/Composite.hs

@@ -283,7 +283,7 @@ compositeMerge
   -> WidgetNode sp ep
   -> WidgetNode sp ep
   -> WidgetResult sp ep
-compositeMerge comp state wenv oldComp newComp = newResult where
+compositeMerge comp state wenv oldComp newComp = result where
   oldState = widgetGetState (oldComp ^. L.widget) wenv
   validState = fromMaybe state (useState oldState)
   CompositeState oldModel oldRoot oldGlobalKeys = validState
@@ -318,6 +318,10 @@ compositeMerge comp state wenv oldComp newComp = newResult where
     | mergeRequired = reduceResult comp newState wenv styledComp tempResult
     | otherwise = resultWidget $ styledComp
         & L.widget .~ oldComp ^. L.widget
+  widgetId = newComp ^. L.info . L.widgetId
+  path = newComp ^. L.info . L.path
+  result = newResult
+    & L.requests %~ (UpdateWidgetPath widgetId path <|)
 
 -- | Dispose
 compositeDispose
@@ -535,10 +539,11 @@ reduceResult comp state wenv widgetComp widgetResult = newResult where
       reduceCompEvents _cpsGlobalKeys evtHandler cwenv evtModel evts
   WidgetResult uWidget uReqs uEvts =
     updateComposite comp state wenv _reModel evtsRoot widgetComp
-  currentPath = widgetComp ^. L.info . L.path
+  widgetId = widgetComp ^. L.info . L.widgetId
+  path = widgetComp ^. L.info . L.path
   newReqs = toParentReqs reqs
-         <> tasksToRequests currentPath _reTasks
+         <> tasksToRequests widgetId path _reTasks
-         <> producersToRequests currentPath _reProducers
+         <> producersToRequests widgetId path _reProducers
          <> uReqs
          <> toParentReqs _reRequests
          <> _reMessages
@@ -650,12 +655,21 @@ getModel
   -> s
 getModel comp wenv = widgetDataGet (_weModel wenv) (_cmpWidgetData comp)
 
-tasksToRequests :: CompositeEvent e => Path -> Seq (IO e) -> Seq (WidgetRequest sp)
+tasksToRequests
-tasksToRequests path reqs = RunTask path <$> reqs
+  :: CompositeEvent e
+  => WidgetId
+  -> Path
+  -> Seq (IO e)
+  -> Seq (WidgetRequest sp)
+tasksToRequests widgetId path reqs = RunTask widgetId path <$> reqs
 
 producersToRequests
-  :: CompositeEvent e => Path -> Seq (ProducerHandler e) -> Seq (WidgetRequest sp)
+  :: CompositeEvent e
-producersToRequests path reqs = RunProducer path <$> reqs
+  => WidgetId
+  -> Path
+  -> Seq (ProducerHandler e)
+  -> Seq (WidgetRequest sp)
+producersToRequests widgetId path reqs = RunProducer widgetId path <$> reqs
 
 toParentReqs :: Seq (WidgetRequest s) -> Seq (WidgetRequest sp)
 toParentReqs reqs = fmap fromJust $ Seq.filter isJust $ fmap toParentReq reqs
@@ -674,13 +688,14 @@ toParentReq ResetOverlay = Just ResetOverlay
 toParentReq (SetOverlay path) = Just (SetOverlay path)
 toParentReq (SetCursorIcon icon) = Just (SetCursorIcon icon)
 toParentReq (SendMessage path message) = Just (SendMessage path message)
-toParentReq (RunTask path action) = Just (RunTask path action)
+toParentReq (RunTask wid path action) = Just (RunTask wid path action)
-toParentReq (RunProducer path action) = Just (RunProducer path action)
+toParentReq (RunProducer wid path action) = Just (RunProducer wid path action)
 toParentReq RenderOnce = Just RenderOnce
 toParentReq (RenderEvery path ms) = Just (RenderEvery path ms)
 toParentReq (RenderStop path) = Just (RenderStop path)
 toParentReq (ExitApplication exit) = Just (ExitApplication exit)
 toParentReq (UpdateWindow req) = Just (UpdateWindow req)
+toParentReq (UpdateWidgetPath wid path) = Just (UpdateWidgetPath wid path)
 toParentReq (UpdateModel fn) = Nothing
 
 collectGlobalKeys

src/Monomer/Widgets/Image.hs

@@ -123,26 +123,30 @@ makeImage imgPath config state = widget where
   }
 
   init wenv node = resultReqs node reqs where
+    wid = node ^. L.info . L.widgetId
     path = node ^. L.info . L.path
-    reqs = [RunTask path $ handleImageLoad wenv imgPath]
+    reqs = [RunTask wid path $ handleImageLoad wenv imgPath]
 
   merge wenv oldState oldNode newNode = result where
     newState = fromMaybe state (useState oldState)
+    wid = newNode ^. L.info . L.widgetId
     path = newNode ^. L.info . L.path
-    newImgReqs = [ RunTask path $ do
+    widgetPathReq = UpdateWidgetPath wid path
+    newImgReqs = [ widgetPathReq, RunTask wid path $ do
         removeImage wenv imgPath
         handleImageLoad wenv imgPath
       ]
     sameImgNode = newNode
       & L.widget .~ makeImage imgPath config newState
     result
-      | isImagePath newState == imgPath = resultWidget sameImgNode
+      | isImagePath newState == imgPath = resultReqs sameImgNode [widgetPathReq]
       | otherwise = resultReqs newNode newImgReqs
 
   dispose wenv node = resultReqs node reqs where
+    wid = node ^. L.info . L.widgetId
     path = node ^. L.info . L.path
     renderer = _weRenderer wenv
-    reqs = [RunTask path $ removeImage wenv imgPath]
+    reqs = [RunTask wid path $ removeImage wenv imgPath]
 
   handleMessage wenv target message node = result where
     result = cast message >>= useImage node

tasks.md

@@ -371,6 +371,7 @@
 Maybe postponed after release?
   - Make sure WidgetTask/Node association is preserved if node location in tree changes
   - ZStack should set _weIsTopLayer based on used space
+  - Button should handle ReleaseBtn instead of Click (allow multi click)
   - Check multiple resize when opening dialogs
   - Listview is not properly changing styles
     - Label needs to rebuild its glyphs if style/renderArea changes

test/unit/Monomer/Widgets/ImageSpec.hs

@@ -23,12 +23,12 @@ initMergeWidget = describe "init/merge" $ do
     Seq.length reqs1 `shouldBe` 1
     Seq.index reqs1 0 `shouldSatisfy` isRunTask
 
-  it "should not create a task when merging to the same path" $
+  it "should not create a task when merging to the same path (UpdateWidgetPath is still added)" $
-    Seq.length reqs2 `shouldBe` 0
+    Seq.length reqs2 `shouldBe` 1
 
-  it "should create a task when merging to a different path" $ do
+  it "should create a task when merging to a different path (UpdateWidgetPath is still added)" $ do
-    Seq.length reqs3 `shouldBe` 1
+    Seq.length reqs3 `shouldBe` 2
-    Seq.index reqs3 0 `shouldSatisfy` isRunTask
+    Seq.index reqs3 1 `shouldSatisfy` isRunTask
 
   where
     wenv = mockWenv ()