Remove unused ResizeChildren logic. Refactor handler logic to share it in Events and WidgetTask modules

app/Main.hs

@@ -127,12 +127,17 @@ handleAppEvent app evt = do
       return Nothing
     UpdateText3 txt -> State $ app & textField3 .~ txt
 
-buildUI model = widgetTree where
+buildUI app = widgetTree where
   widgetTree =
     vstack [
       label "This is label 1" `style` bgColor blue,
       label "This is label 2" `style` bgColor black,
       label "This is label 3" `style` bgColor blue,
+      hstack [
+        textField textField1,
+        button "Update state" (UpdateText3 $ app ^. textField1),
+        textField textField3
+      ],
       flip style (sheight 300) $ scroll $ vstack [
         label "This is label in scroll 01" `style` bgColor lightGray,
         label "This is label in scroll 02" `style` bgColor gray,

src/Monomer/Event/Core.hs

@@ -37,14 +37,6 @@ isIgnoreChildrenEvents :: EventRequest s -> Bool
 isIgnoreChildrenEvents IgnoreChildrenEvents = True
 isIgnoreChildrenEvents _ = False
 
-isResizeChildren :: EventRequest s -> Bool
-isResizeChildren (ResizeChildren _) = True
-isResizeChildren _ = False
-
-isResizeAll :: EventRequest s -> Bool
-isResizeAll ResizeAll = True
-isResizeAll _ = False
-
 isGetClipboard :: EventRequest s -> Bool
 isGetClipboard (GetClipboard _) = True
 isGetClipboard _ = False

src/Monomer/Event/Types.hs

@@ -21,8 +21,6 @@ data ClipboardData = ClipboardEmpty | ClipboardText T.Text deriving (Eq, Show)
 
 data EventRequest s = IgnoreParentEvents
                     | IgnoreChildrenEvents
-                    | ResizeChildren Path
-                    | ResizeAll
                     -- | SetFocus Path
                     | GetClipboard Path
                     | SetClipboard ClipboardData

src/Monomer/Main/Core.hs

@@ -27,6 +27,7 @@ import Monomer.Main.Handlers
 import Monomer.Main.Platform
 import Monomer.Main.UserTask
 import Monomer.Main.Types
+import Monomer.Main.Handlers
 import Monomer.Main.Util
 import Monomer.Main.WidgetTask
 import Monomer.Graphics.NanoVGRenderer
@@ -57,7 +58,7 @@ runWidgets window c mapp = do
   mainLoop window c renderer mapp (fromIntegral ticks) 0 0 widgetRoot
 
 mainLoop :: (MonomerM s e m) => SDL.Window -> NV.Context -> Renderer m -> MonomerApp s e m -> Int -> Int -> Int -> WidgetInstance s e m -> m ()
-mainLoop window c renderer mapp !prevTicks !tsAccum !frames widgets = do
+mainLoop window c renderer mapp !prevTicks !tsAccum !frames widgetRoot = do
   windowSize <- use windowSize
   useHiDPI <- use useHiDPI
   devicePixelRate <- use devicePixelRate
@@ -80,21 +81,21 @@ mainLoop window c renderer mapp !prevTicks !tsAccum !frames widgets = do
 
   -- Pre process events (change focus, add Enter/Leave events when Move is received, etc)
   currentApp <- use appContext
-  systemEvents <- preProcessEvents widgets baseSystemEvents
+  systemEvents <- preProcessEvents widgetRoot baseSystemEvents
   uTasksEvents <- checkUserTasks
-  (wTasksWidgets, wTasksEvents, wTasksResize) <- checkWidgetTasks mapp widgets
-  (seApp, seAppEvents, seWidgets) <- handleSystemEvents renderer mapp currentApp systemEvents wTasksWidgets
+  (wtApp, wtAppEvents, wtWidgetRoot) <- handleWidgetTasks renderer mapp currentApp widgetRoot
+  (seApp, seAppEvents, seWidgetRoot) <- handleSystemEvents renderer mapp wtApp systemEvents wtWidgetRoot
 
-  newApp <- handleAppEvents mapp seApp (seAppEvents >< (Seq.fromList uTasksEvents) >< wTasksEvents)
+  newApp <- handleAppEvents mapp seApp (seAppEvents >< (Seq.fromList uTasksEvents) >< wtAppEvents)
   mctx <- get
 
-  let updatedWidgets = if currentApp /= newApp
-                          then updateUI renderer mapp mctx seWidgets
-                          else seWidgets
-  newWidgets <- return updatedWidgets >>= bindIf (resized || wTasksResize) (resizeWindow window renderer newApp)
+  let tempWidgetRoot = if currentApp /= newApp
+                          then updateUI renderer mapp mctx seWidgetRoot
+                          else seWidgetRoot
+  newWidgetRoot <- return tempWidgetRoot >>= bindIf resized (resizeWindow window renderer newApp)
 
   currentFocus <- use focused
-  renderWidgets window c renderer (PathContext currentFocus rootPath rootPath) newApp newWidgets startTicks
+  renderWidgets window c renderer (PathContext currentFocus rootPath rootPath) newApp newWidgetRoot startTicks
 
   endTicks <- fmap fromIntegral SDL.ticks
 
@@ -104,7 +105,7 @@ mainLoop window c renderer mapp !prevTicks !tsAccum !frames widgets = do
   let nextFrameDelay = round . abs $ (frameLength - newTs * 1000)
 
   liftIO $ threadDelay nextFrameDelay
-  unless quit (mainLoop window c renderer mapp startTicks newTsAccum newFrameCount newWidgets)
+  unless quit (mainLoop window c renderer mapp startTicks newTsAccum newFrameCount newWidgetRoot)
 
 handleAppEvents :: (MonomerM s e m) => MonomerApp s e m -> s -> Seq e -> m s
 handleAppEvents mapp app events = do

src/Monomer/Main/Handlers.hs

@@ -2,6 +2,7 @@
 
 module Monomer.Main.Handlers where
 
+import Control.Concurrent.Async (async)
 import Control.Monad
 import Control.Monad.IO.Class
 import Data.Maybe
@@ -21,7 +22,6 @@ import Monomer.Event.Types
 import Monomer.Main.Internal
 import Monomer.Main.Platform
 import Monomer.Main.UserTask
-import Monomer.Main.WidgetTask
 import Monomer.Main.Types
 import Monomer.Main.Util
 import Monomer.Graphics.Renderer
@@ -65,19 +65,21 @@ handleSystemEvent renderer mapp app systemEvent currentFocus currentTarget widge
   Just ctx -> do
     let widget = _instanceWidget widgetRoot
     let emptyResult = EventResult Seq.empty Seq.empty widgetRoot
-    let EventResult eventRequests appEvents evtRoot = fromMaybe emptyResult $ _widgetHandleEvent widget ctx systemEvent app widgetRoot
-    let evtStates = getUpdateUserStates eventRequests
-    let stopProcessing = isJust $ Seq.findIndexL isIgnoreParentEvents eventRequests
-    let evtApp = compose evtStates app
+    let eventResult = fromMaybe emptyResult $ _widgetHandleEvent widget ctx systemEvent app widgetRoot
+    let stopProcessing = isJust $ Seq.findIndexL isIgnoreParentEvents (_eventResultRequest eventResult)
 
-    launchWidgetTasks eventRequests
+    handleEventResult renderer mapp ctx app eventResult
+      >>= handleFocusChange renderer mapp ctx systemEvent stopProcessing
 
-    (newApp, newAppEvents, newRoot) <- handleFocusChange renderer mapp ctx systemEvent stopProcessing (evtApp, Seq.empty, evtRoot)
-      >>= handleClipboardGet renderer mapp ctx eventRequests
-      >>= handleClipboardSet renderer eventRequests
-      >>= handleResizeChildren renderer mapp ctx eventRequests
+handleEventResult :: (MonomerM s e m) => Renderer m -> MonomerApp s e m -> PathContext -> s -> EventResult s e m -> m (HandlerStep s e m)
+handleEventResult renderer mapp ctx app (EventResult eventRequests appEvents evtRoot) = do
+  let evtStates = getUpdateUserStates eventRequests
+  let evtApp = compose evtStates app
 
-    return (newApp, appEvents >< newAppEvents, newRoot)
+  handleNewWidgetTasks eventRequests
+
+  handleClipboardGet renderer mapp ctx eventRequests (evtApp, appEvents, evtRoot)
+    >>= handleClipboardSet renderer eventRequests
 
 handleFocusChange :: (MonomerM s e m) => Renderer m -> MonomerApp s e m -> PathContext -> SystemEvent -> Bool -> (HandlerStep s e m) -> m (HandlerStep s e m)
 handleFocusChange renderer mapp ctx systemEvent stopProcessing (app, events, widgetRoot)
@@ -93,18 +95,6 @@ handleFocusChange renderer mapp ctx systemEvent stopProcessing (app, events, wid
   | otherwise = return (app, events, widgetRoot)
   where
     focusChangeRequested = not stopProcessing && isKeyPressed systemEvent keyTab
-    rotate = if isShiftPressed systemEvent then inverseRotateSeq else rotateSeq
-
-handleResizeChildren :: (MonomerM s e m) => Renderer m -> MonomerApp s e m -> PathContext -> Seq (EventRequest s) -> (HandlerStep s e m) -> m (HandlerStep s e m)
-handleResizeChildren renderer mapp ctx eventRequests (app, widgetRoot, events) =
-  case Seq.filter isResizeChildren eventRequests of
-    ResizeChildren path :<| _ -> do
-      windowSize <- use windowSize
-      --newRoot <- resizeUI renderer app windowSize widgetRoot
-      newRoot <- return widgetRoot
-
-      return (app, newRoot, events)
-    _ -> return (app, widgetRoot, events)
 
 handleClipboardGet :: (MonomerM s e m) => Renderer m -> MonomerApp s e m -> PathContext -> Seq (EventRequest s) -> (HandlerStep s e m) -> m (HandlerStep s e m)
 handleClipboardGet renderer mapp ctx eventRequests (app, events, widgetRoot) =
@@ -113,14 +103,28 @@ handleClipboardGet renderer mapp ctx eventRequests (app, events, widgetRoot) =
       hasText <- SDL.hasClipboardText
       contents <- if hasText then fmap ClipboardText SDL.getClipboardText else return ClipboardEmpty
 
-      handleSystemEvent renderer mapp app (Clipboard contents) (_pathCurrent ctx) path widgetRoot
+      (newApp2, newEvents2, newRoot2) <- handleSystemEvent renderer mapp app (Clipboard contents) (_pathCurrent ctx) path widgetRoot
+
+      return (newApp2, events >< newEvents2, newRoot2)
     _ -> return (app, events, widgetRoot)
 
 handleClipboardSet :: (MonomerM s e m) => Renderer m -> Seq (EventRequest s) -> (HandlerStep s e m) -> m (HandlerStep s e m)
-handleClipboardSet renderer eventRequests (app, events, widgetRoot) =
+handleClipboardSet renderer eventRequests previousStep =
   case Seq.filter isSetClipboard eventRequests of
     SetClipboard (ClipboardText text) :<| _ -> do
       SDL.setClipboardText text
 
-      return (app, events, widgetRoot)
-    _ -> return (app, events, widgetRoot)
+      return previousStep
+    _ -> return previousStep
+
+handleNewWidgetTasks :: (MonomerM s e m) => Seq (EventRequest s) -> m ()
+handleNewWidgetTasks eventRequests = do
+  let customHandlers = Seq.filter isCustomHandler eventRequests
+
+  tasks <- forM customHandlers $ \(RunCustom path handler) -> do
+    asyncTask <- liftIO $ async (liftIO handler)
+
+    return $ WidgetTask path asyncTask
+
+  previousTasks <- use widgetTasks
+  widgetTasks .= previousTasks >< tasks

src/Monomer/Main/WidgetTask.hs

@@ -2,7 +2,7 @@
 
 module Monomer.Main.WidgetTask where
 
-import Control.Concurrent.Async (async, poll)
+import Control.Concurrent.Async (poll)
 import Control.Exception.Base
 import Control.Monad
 import Control.Monad.Extra
@@ -21,6 +21,8 @@ import Monomer.Common.Util
 import Monomer.Common.Tree
 import Monomer.Event.Core
 import Monomer.Event.Types
+import Monomer.Graphics.Renderer
+import Monomer.Main.Handlers
 import Monomer.Main.Internal
 import Monomer.Main.Util
 import Monomer.Main.Types
@@ -28,53 +30,36 @@ import Monomer.Widget.Core
 import Monomer.Widget.PathContext
 import Monomer.Widget.Types
 
-launchWidgetTasks :: (MonomerM s e m) => Seq (EventRequest s) -> m ()
-launchWidgetTasks eventRequests = do
-  let customHandlers = Seq.filter isCustomHandler eventRequests
-
-  tasks <- forM customHandlers $ \(RunCustom path handler) -> do
-    asyncTask <- liftIO $ async (liftIO handler)
-
-    return $ WidgetTask path asyncTask
-
-  previousTasks <- use widgetTasks
-  widgetTasks .= previousTasks >< tasks
-
-checkWidgetTasks :: (MonomerM s e m) => MonomerApp s e m -> WidgetInstance s e m -> m (WidgetInstance s e m, Seq e, Bool)
-checkWidgetTasks mapp widgets = do
+handleWidgetTasks :: (MonomerM s e m) => Renderer m -> MonomerApp s e m -> s -> WidgetInstance s e m -> m (HandlerStep s e m)
+handleWidgetTasks renderer mapp app widgetRoot = do
   tasks <- use widgetTasks
   (active, finished) <- partitionM (\(WidgetTask _ task) -> fmap isNothing (liftIO $ poll task)) (toList tasks)
   widgetTasks .= Seq.fromList active
 
-  processCustomHandlers mapp widgets finished
+  processWidgetTasks renderer mapp app widgetRoot finished
 
-processCustomHandlers :: (MonomerM s e m) => MonomerApp s e m -> WidgetInstance s e m -> [WidgetTask] -> m (WidgetInstance s e m, Seq e, Bool)
-processCustomHandlers mapp widgets tasks = foldM reducer (widgets, Seq.empty, False) tasks where
-  reducer (ws, es, resize) task = do
-    (ws2, es2, resize2) <- processCustomHandler mapp ws task
-    return (ws2, es >< es2, resize || resize2)
+processWidgetTasks :: (MonomerM s e m) => Renderer m -> MonomerApp s e m -> s -> WidgetInstance s e m -> [WidgetTask] -> m (HandlerStep s e m)
+processWidgetTasks renderer mapp app widgetRoot tasks = foldM reducer (app, Seq.empty, widgetRoot) tasks where
+  reducer (wApp, wEvts, wRoot) task = do
+    (wApp2, wEvts2, wRoot2) <- processWidgetTask renderer mapp wApp wRoot task
+    return (wApp2, wEvts >< wEvts2, wRoot2)
 
-processCustomHandler :: (MonomerM s e m) => MonomerApp s e m -> WidgetInstance s e m -> WidgetTask -> m (WidgetInstance s e m, Seq e, Bool)
-processCustomHandler mapp widgets (WidgetTask path task) = do
+processWidgetTask :: (MonomerM s e m) => Renderer m -> MonomerApp s e m -> s -> WidgetInstance s e m -> WidgetTask -> m (HandlerStep s e m)
+processWidgetTask renderer mapp app widgetRoot (WidgetTask path task) = do
   app <- use appContext
   taskStatus <- liftIO $ poll task
 
   if (isJust taskStatus)
-    then processCustomHandlerResult mapp app widgets path (fromJust taskStatus)
-    else return (widgets, Seq.empty, False)
+    then processWidgetTaskResult renderer mapp app widgetRoot path (fromJust taskStatus)
+    else return (app, Seq.empty, widgetRoot)
 
-processCustomHandlerResult :: (MonomerM s e m, Typeable a) => MonomerApp s e m -> s -> WidgetInstance s e m -> Path -> Either SomeException a -> m (WidgetInstance s e m, Seq e, Bool)
-processCustomHandlerResult mapp app widgetRoot _ (Left _) = return (widgetRoot, Seq.empty, False)
-processCustomHandlerResult mapp app widgetRoot path (Right val) = do
+processWidgetTaskResult :: (MonomerM s e m, Typeable a) => Renderer m -> MonomerApp s e m -> s -> WidgetInstance s e m -> Path -> Either SomeException a -> m (HandlerStep s e m)
+processWidgetTaskResult renderer mapp app widgetRoot _ (Left _) = return (app, Seq.empty, widgetRoot)
+processWidgetTaskResult renderer mapp app widgetRoot path (Right val) = do
   currentFocus <- use focused
 
   let ctx = PathContext currentFocus path rootPath
   let emptyResult = EventResult Seq.empty Seq.empty widgetRoot
-  let EventResult eventRequests appEvents newWidgetRoot = fromMaybe emptyResult $ _widgetHandleCustom (_instanceWidget widgetRoot) ctx val app widgetRoot
-  let resizeRequested = isJust $ Seq.findIndexL isResizeChildren eventRequests
-  let newStates = getUpdateUserStates eventRequests
+  let eventResult = fromMaybe emptyResult $ _widgetHandleCustom (_instanceWidget widgetRoot) ctx val app widgetRoot
 
-  appContext %= compose newStates
-  launchWidgetTasks eventRequests
-
-  return (newWidgetRoot, appEvents, resizeRequested)
+  handleEventResult renderer mapp ctx app eventResult

src/Monomer/Widget/PathContext.hs

@@ -38,7 +38,7 @@ isTargetValid ctx children = case nextTargetStep ctx of
   Nothing -> False
 
 isTargetBeforeCurrent :: PathContext -> Bool
-isTargetBeforeCurrent ctx@PathContext{..} = targetPrefix < _pathCurrent where
+isTargetBeforeCurrent ctx@PathContext{..} = targetPrefix <= _pathCurrent where
   lenTarget = Seq.length _pathTarget
   lenCurrent = Seq.length _pathCurrent
   targetPrefix = if lenTarget > lenCurrent

tasks.md

@@ -40,20 +40,20 @@
     - + Fix issue with event handling (click makes everything disappear)
     - + Fix focus situation (remove _focusRing and replace with single focus, then use _widgetNextFocusable)
     - + Provide focus to render (needed by textField)
-    - Check if resize children still makes sense (maybe the widget itself can resize on the corresponding event?)
+    - + Check if resize children still makes sense (maybe the widget itself can resize on the corresponding event?)
+    - Handle SetFocus request
     - Check if WidgetState is really needed
     - Can we generalize _widgetFind?
     - Rethink Tree.Path import
     - Clean up Seq imports
     - Where can we use Seq? Does it make sense to use it everywhere? What about Traversable?
     - Reorganize Common Types. What do other projects do? They should be simple to import and use
-    - Handle SetFocus request
-  - Fix scroll click navigation
-  - Replace Default instances for Monoid, if possible
+  - Create composite widget, on which application itself is based
   - Improve merge process. Implement Global keys
   - Improve hstack/vstack
     - If available space is greater than requested, do not apply resizing logic
   - Does a styling engine make sense or doing something similar to Flutter is simpler?
+    - Does keeping style for some things (fixed width/height) make sense?
     - Could container handle padding and centering?
     - Implement styling engine. Think why Maybe Double instead of Maybe Dimension (to handle pixels, percent, etc)
   - Improve ergonomics
@@ -67,6 +67,7 @@
     - Related to previous, look for ways to simplify widget setup. Default instance with common values?
     - Find way of providing instance config (style, visibility, etc) before providing children (some sort of flip operator)
   - Keep sending mouse move event if mouse is away but button is still pressed
+  - Fix scroll click navigation
   - Create layer widget to handle overlays/dialog boxes/tooltips (takes care of overlays)
   - Add text selection/editing to textField
   - Create Checkbox