From 954540515379448e682bbe23586903999c8b97d6 Mon Sep 17 00:00:00 2001 From: Francisco Vallarino Date: Fri, 29 May 2020 23:13:24 -0300 Subject: [PATCH] Remove unused ResizeChildren logic. Refactor handler logic to share it in Events and WidgetTask modules --- app/Main.hs | 7 +++- src/Monomer/Event/Core.hs | 8 ----- src/Monomer/Event/Types.hs | 2 -- src/Monomer/Main/Core.hs | 23 ++++++------ src/Monomer/Main/Handlers.hs | 58 +++++++++++++++++-------------- src/Monomer/Main/WidgetTask.hs | 55 +++++++++++------------------ src/Monomer/Widget/PathContext.hs | 2 +- tasks.md | 9 ++--- 8 files changed, 75 insertions(+), 89 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index ef3fa9a4..287c193f 100644 --- a/app/Main.hs +++ b/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, diff --git a/src/Monomer/Event/Core.hs b/src/Monomer/Event/Core.hs index d5ff77a6..aebdbee0 100644 --- a/src/Monomer/Event/Core.hs +++ b/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 diff --git a/src/Monomer/Event/Types.hs b/src/Monomer/Event/Types.hs index 2051cea1..73b1236c 100644 --- a/src/Monomer/Event/Types.hs +++ b/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 diff --git a/src/Monomer/Main/Core.hs b/src/Monomer/Main/Core.hs index bf93cc05..cf743ca1 100644 --- a/src/Monomer/Main/Core.hs +++ b/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 diff --git a/src/Monomer/Main/Handlers.hs b/src/Monomer/Main/Handlers.hs index 89e307d5..db25cdfd 100644 --- a/src/Monomer/Main/Handlers.hs +++ b/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 diff --git a/src/Monomer/Main/WidgetTask.hs b/src/Monomer/Main/WidgetTask.hs index bc62567b..56a193e6 100644 --- a/src/Monomer/Main/WidgetTask.hs +++ b/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 diff --git a/src/Monomer/Widget/PathContext.hs b/src/Monomer/Widget/PathContext.hs index 4e8812b2..23e4da03 100644 --- a/src/Monomer/Widget/PathContext.hs +++ b/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 diff --git a/tasks.md b/tasks.md index e332c31c..7acfff3f 100644 --- a/tasks.md +++ b/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