Use WidgetId in MoveFocus and SetFocus

src/Monomer/Core/Util.hs

@@ -18,6 +18,10 @@ globalKeyPath :: WidgetEnv s e -> Text -> Maybe Path
 globalKeyPath wenv key = fmap (^. L.info . L.path) node where
   node = Map.lookup (WidgetKeyGlobal key) (wenv ^. L.globalKeys)
 
+globalKeyWidgetId :: WidgetEnv s e -> Text -> Maybe WidgetId
+globalKeyWidgetId wenv key = fmap (^. L.info . L.widgetId) node where
+  node = Map.lookup (WidgetKeyGlobal key) (wenv ^. L.globalKeys)
+
 widgetTreeDesc :: Int -> WidgetNode s e -> String
 widgetTreeDesc level node = desc where
   desc = nodeDesc level node ++ "\n" ++ childDesc

src/Monomer/Core/WidgetTypes.hs

@@ -96,8 +96,8 @@ data WidgetRequest s
   = IgnoreParentEvents
   | IgnoreChildrenEvents
   | ResizeWidgets
-  | MoveFocus (Maybe Path) FocusDirection
-  | SetFocus Path
+  | MoveFocus (Maybe WidgetId) FocusDirection
+  | SetFocus WidgetId
   | GetClipboard WidgetId
   | SetClipboard ClipboardData
   | StartTextInput Rect
@@ -123,8 +123,8 @@ instance Eq (WidgetRequest s) where
   IgnoreParentEvents == IgnoreParentEvents = True
   IgnoreChildrenEvents == IgnoreChildrenEvents = True
   ResizeWidgets == ResizeWidgets = True
-  MoveFocus p1 fd1 == MoveFocus p2 fd2 = (p1, fd1) == (p2, fd2)
-  SetFocus p1 == SetFocus p2 = p1 == p2
+  MoveFocus w1 fd1 == MoveFocus w2 fd2 = (w1, fd1) == (w2, fd2)
+  SetFocus w1 == SetFocus w2 = w1 == w2
   GetClipboard w1 == GetClipboard w2 = w1 == w2
   SetClipboard c1 == SetClipboard c2 = c1 == c2
   StartTextInput r1 == StartTextInput r2 = r1 == r2

src/Monomer/Main/Handlers.hs

@@ -21,7 +21,7 @@ import Control.Monad.STM (atomically)
 import Control.Concurrent.STM.TChan (TChan, newTChanIO, writeTChan)
 import Control.Applicative ((<|>))
 import Control.Monad
-import Control.Monad.Extra(concatMapM)
+import Control.Monad.Extra (concatMapM, maybeM)
 import Control.Monad.IO.Class
 import Data.Default
 import Data.List (foldl')
@@ -290,49 +290,48 @@ handleResizeWidgets previousStep = do
 
 handleMoveFocus
   :: (MonomerM s m)
-  => Maybe Path
+  => Maybe WidgetId
   -> FocusDirection
   -> HandlerStep s e
   -> m (HandlerStep s e)
-handleMoveFocus startFrom dir (wenv, root, reqs, evts) = do
+handleMoveFocus startFromWid dir (wenv, root, reqs, evts) = do
   oldFocus <- getFocusedPath
-  let wenv0 = wenv { _weFocusedPath = emptyPath }
+  let wenv0 = wenv & L.focusedPath .~ emptyPath
   (wenv1, root1, reqs1, evts1) <- handleSystemEvent wenv0 Blur oldFocus root
   currFocus <- getFocusedPath
   currOverlay <- getOverlayPath
 
   if oldFocus == currFocus
     then do
+      startFrom <- mapM getWidgetIdPath startFromWid
       let searchFrom = fromMaybe currFocus startFrom
       let newFocusWni = findNextFocus wenv1 dir searchFrom currOverlay root1
       let newFocus = newFocusWni ^. L.path
-      let tempWenv = wenv1 { _weFocusedPath = newFocus }
+      let wenvF = wenv1 & L.focusedPath .~ newFocus
 
       L.focusedWidgetId .= newFocusWni ^. L.widgetId
       L.renderRequested .= True
-      (wenv2, root2, reqs2, evts2) <- handleSystemEvent tempWenv Focus newFocus root1
+      (wenv2, root2, reqs2, evts2) <- handleSystemEvent wenvF Focus newFocus root1
 
       return (wenv2, root2, reqs <> reqs1 <> reqs2, evts <> evts1 <> evts2)
     else
       return (wenv1, root1, reqs1, evts1)
 
 handleSetFocus
-  :: (MonomerM s m) => Path -> HandlerStep s e -> m (HandlerStep s e)
-handleSetFocus newFocus (wenv, root, reqs, evts) =  do
-  let wenv0 = wenv { _weFocusedPath = newFocus }
-
+  :: (MonomerM s m) => WidgetId -> HandlerStep s e -> m (HandlerStep s e)
+handleSetFocus newFocusWid (wenv, root, reqs, evts) = do
+  newFocus <- getWidgetIdPath newFocusWid
   oldFocus <- getFocusedPath
 
   if oldFocus /= newFocus
     then do
+      let wenv0 = wenv & L.focusedPath .~ newFocus
       (wenv1, root1, reqs1, evts1) <- handleSystemEvent wenv0 Blur oldFocus root
-      let tempWenv = wenv1 { _weFocusedPath = newFocus }
-      let widget1 = root1 ^. L.widget
-      let wni = fromMaybe def (widgetFindByPath widget1 wenv newFocus root1)
+      let wenvF = wenv1 & L.focusedPath .~ newFocus
 
-      L.focusedWidgetId .= wni ^. L.widgetId
+      L.focusedWidgetId .= newFocusWid
       L.renderRequested .= True
-      (wenv2, root2, reqs2, evts2) <- handleSystemEvent tempWenv Focus newFocus root1
+      (wenv2, root2, reqs2, evts2) <- handleSystemEvent wenvF Focus newFocus root1
 
       return (wenv2, root2, reqs <> reqs1 <> reqs2, evts <> evts1 <> evts2)
     else

src/Monomer/Widgets/Button.hs

@@ -237,7 +237,7 @@ makeButton caption config = widget where
       requests = _btnOnClickReq config
       events = _btnOnClick config
       result = resultReqsEvts node requests events
-      resultFocus = resultReqs node [SetFocus (node ^. L.info . L.path)]
+      resultFocus = resultReqs node [SetFocus (node ^. L.info . L.widgetId)]
 
   getSizeReq :: ContainerGetSizeReqHandler s e a
   getSizeReq wenv currState node children = (newReqW, newReqH) where

src/Monomer/Widgets/Confirm.hs

@@ -160,6 +160,6 @@ handleEvent wenv node model evt = case evt of
   ConfirmParentEvt pevt -> [Report pevt]
   ConfirmVisibleChanged -> catMaybes [acceptPath | nodeVisible]
   where
-    acceptPath = Request . SetFocus <$> globalKeyPath wenv "acceptBtn"
+    acceptPath = Request . SetFocus <$> globalKeyWidgetId wenv "acceptBtn"
     ownsFocus = isNodeParentOfFocused wenv node
     nodeVisible = node ^. L.info . L.visible

src/Monomer/Widgets/Dropdown.hs

@@ -324,7 +324,7 @@ makeDropdown widgetData items makeMain makeRow config state = widget where
         | otherwise = Nothing
     ButtonAction _ btn PressedBtn _
       | btn == wenv ^. L.mainButton && not isOpen -> result where
-        result = Just $ resultReqs node [SetFocus (node ^. L.info . L.path)]
+        result = Just $ resultReqs node [SetFocus (node ^. L.info . L.widgetId)]
     Click point _
       | openRequired point node -> Just $ openDropdown wenv node
       | closeRequired point node -> Just $ closeDropdown wenv node
@@ -362,11 +362,10 @@ makeDropdown widgetData items makeMain makeRow config state = widget where
     path = node ^. L.info . L.path
     widgetId = node ^. L.info . L.widgetId
     -- listView is wrapped by a scroll widget
-    lvPath = path |> listIdx |> 0
-    requests = [SetOverlay widgetId path, SetFocus lvPath]
+    lvWid = node^?! L.children. ix listIdx. L.children. ix 0. L.info. L.widgetId
+    requests = [SetOverlay widgetId path, SetFocus lvWid]
 
   closeDropdown wenv node = resultReqs newNode requests where
-    path = node ^. L.info . L.path
     widgetId = node ^. L.info . L.widgetId
     newState = state {
       _ddsOpen = False,
@@ -374,7 +373,7 @@ makeDropdown widgetData items makeMain makeRow config state = widget where
     }
     newNode = node
       & L.widget .~ makeDropdown widgetData items makeMain makeRow config newState
-    requests = [ResetOverlay widgetId, SetFocus path]
+    requests = [ResetOverlay widgetId, SetFocus widgetId]
 
   handleMessage wenv target msg node =
     cast msg >>= handleLvMsg wenv node

src/Monomer/Widgets/InputField.hs

@@ -320,7 +320,7 @@ makeInputField config state = widget where
     -- Enter regular edit mode if widget has custom drag handler
     DblClick point btn
       | dragHandleExt btn -> Just (resultReqs node reqs) where
-        focusReq = [SetFocus path | not (isNodeFocused wenv node)]
+        focusReq = [SetFocus widgetId | not (isNodeFocused wenv node)]
         reqs = SetCursorIcon widgetId CursorIBeam : focusReq
 
     -- Begin regular text selection
@@ -332,7 +332,7 @@ makeInputField config state = widget where
         newState = newTextState wenv node state currVal currText newPos Nothing
         newNode = node
           & L.widget .~ makeInputField config newState
-        newReqs = [ SetFocus path | not (isNodeFocused wenv node) ]
+        newReqs = [ SetFocus widgetId | not (isNodeFocused wenv node) ]
         result = resultReqs newNode newReqs
 
     -- Begin custom drag

src/Monomer/Widgets/ListView.hs

@@ -326,7 +326,7 @@ makeListView widgetData items makeRow config state = widget where
   handleEvent wenv target evt node = case evt of
     ButtonAction _ btn PressedBtn _
       | btn == wenv ^. L.mainButton -> result where
-        result = Just $ resultReqs node [SetFocus (node ^. L.info . L.path)]
+        result = Just $ resultReqs node [SetFocus (node ^. L.info . L.widgetId)]
     Focus -> handleFocusChange _lvcOnFocus _lvcOnFocusReq config node
     Blur -> result where
       isTabPressed = getKeyStatus (_weInputStatus wenv) keyTab == KeyPressed
@@ -366,7 +366,7 @@ makeListView widgetData items makeRow config state = widget where
     result = fmap handleSelect (cast message)
 
   handleItemClick wenv node idx = result where
-    focusReq = SetFocus $ node ^. L.info . L.path
+    focusReq = SetFocus $ node ^. L.info . L.widgetId
     tempResult = selectItem wenv node idx
     result
       | isNodeFocused wenv node = tempResult
@@ -414,8 +414,8 @@ makeListView widgetData items makeRow config state = widget where
 
   itemScrollTo wenv node idx = maybeToList (scrollToReq <$> mwid <*> vp) where
     vp = itemViewport node idx
-    mwid = wenv ^. L.findByPath $ parentPath node
-    scrollToReq wid rect = SendMessage (wid ^. L.widgetId) (ScrollTo rect)
+    mwid = findWidgetIdFromPath wenv (parentPath node)
+    scrollToReq wid rect = SendMessage wid (ScrollTo rect)
 
   itemViewport node idx = viewport where
     lookup idx node = Seq.lookup idx (node ^. L.children)

src/Monomer/Widgets/Single.hs

@@ -356,7 +356,7 @@ handleFocusRequest wenv evt oldNode mResult = newResult where
     && not (isNodeFocused wenv node)
     && isNodeTopLevel wenv node
     && isNothing (Seq.findIndexL isFocusRequest prevReqs)
-  focusReq = SetFocus (node ^. L.info . L.path)
+  focusReq = SetFocus (node ^. L.info . L.widgetId)
   newResult
     | isFocusReq && isJust mResult = (& L.requests %~ (|> focusReq)) <$> mResult
     | isFocusReq = Just $ resultReqs node [focusReq]

src/Monomer/Widgets/Util/Widget.hs

@@ -22,10 +22,11 @@ module Monomer.Widgets.Util.Widget (
   matchFailedMsg,
   infoMatches,
   nodeMatches,
-  handleWidgetIdChange
+  handleWidgetIdChange,
+  findWidgetIdFromPath
 ) where
 
-import Control.Lens ((&), (^#), (#~), (^.), (.~), (%~))
+import Control.Lens ((&), (^#), (#~), (^.), (^?), (.~), (%~), _Just)
 import Data.ByteString.Lazy (ByteString)
 import Data.Default
 import Data.Maybe
@@ -153,3 +154,7 @@ handleWidgetIdChange oldNode result = newResult where
     | oldPath /= newPath = result
         & L.requests %~ (UpdateWidgetPath widgetId newPath <|)
     | otherwise = result
+
+findWidgetIdFromPath :: WidgetEnv s e -> Path -> Maybe WidgetId
+findWidgetIdFromPath wenv path = mwni ^? _Just . L.widgetId where
+  mwni = wenv ^. L.findByPath $ path

src/Monomer/Widgets/ZStack.hs

@@ -10,7 +10,7 @@ module Monomer.Widgets.ZStack (
 
 import Codec.Serialise
 import Control.Applicative ((<|>))
-import Control.Lens ((&), (^.), (.~), (%~), (?~), at)
+import Control.Lens ((&), (^.), (^?), (.~), (%~), (?~), at, ix)
 import Control.Monad (forM_, void, when)
 import Data.Default
 import Data.Maybe
@@ -46,7 +46,7 @@ onlyTopActive active = def {
 }
 
 data ZStackState = ZStackState {
-  _zssFocusMap :: M.Map PathStep Path,
+  _zssFocusMap :: M.Map PathStep WidgetId,
   _zssTopIdx :: Int
 } deriving (Eq, Show, Generic, Serialise)
 
@@ -98,26 +98,26 @@ makeZStack config state = widget where
     ZStackState oldFocusMap oldTopIdx = oldState
     children = node ^. L.children
     focusedPath = wenv ^. L.focusedPath
+    focusedWid = findWidgetIdFromPath wenv focusedPath
     isFocusParent = isNodeParentOfPath focusedPath node
     topLevel = isNodeTopLevel wenv node
     flagsChanged = childrenFlagsChanged oldNode node
     newTopIdx = fromMaybe 0 (Seq.findIndexL (^.L.info . L.visible) children)
     focusReq = isJust $ Seq.findIndexL isFocusRequest (result ^. L.requests)
     needsFocus = isFocusParent && topLevel && flagsChanged && not focusReq
-    oldFocus = fromJust oldTopPath
-    oldTopPath = M.lookup newTopIdx oldFocusMap
-    fstTopPath = Just $ node ^. L.info . L.path |> newTopIdx
+    oldTopWid = M.lookup newTopIdx oldFocusMap
+    fstTopWid = node ^? L.children . ix newTopIdx . L.info . L.widgetId
     newState = oldState {
-      _zssFocusMap = oldFocusMap & at oldTopIdx ?~ focusedPath,
+      _zssFocusMap = oldFocusMap & at oldTopIdx .~ focusedWid,
       _zssTopIdx = newTopIdx
     }
     tmpResult = result
       & L.node . L.widget .~ makeZStack config newState
     newResult
-      | needsFocus && isJust oldTopPath = tmpResult
-          & L.requests %~ (|> SetFocus (fromJust oldTopPath))
+      | needsFocus && isJust oldTopWid = tmpResult
+          & L.requests %~ (|> SetFocus (fromJust oldTopWid))
       | needsFocus = tmpResult
-          & L.requests %~ (|> MoveFocus fstTopPath FocusFwd)
+          & L.requests %~ (|> MoveFocus fstTopWid FocusFwd)
       | isFocusParent = tmpResult
       | otherwise = result
 

tasks.md

@@ -539,6 +539,7 @@
     - TextTrim could be trimSpaces?
   - ListView's SendMessage will fail if location changes. Add SendMessageWid?
     - Added mechanism to get WidgetNodeInfo from WidgetEnv given an arbitrary path
+  - Fix books labels
 
 - Pending
   - Add header in all files, indicating license and documenting what the module does
@@ -552,13 +553,15 @@ Next
     - Composite example
       - Validate nested structures update correctly when disabling/enabling parent
     - Something of generative art (OpenGL example)
-  - Fix books labels
   - Check if using WidgetId in MoveFocus and SetFocus is possible
+  - Check _mcMainBtnPress
   - Auto scroll affects dropdown when listView is displayed
   - Send message to scroll to reset position when content changes
     - This is for listView. Maybe a config argument is needed, since this is not always desired?
 
 Future
+  - Animation widgets
+    - Two simple ones to start with: fade in/out and slide in/out
   - Rename ListView -> SelectList
     - Add support for multiple selection
   - Should cascadeCtx be part of widget interface? Maybe it can be handled on init?