Make SendMessage receive WidgetId instead of Path. Add findByPath to WidgetEnv to allow getting node information of an arbitrary path

src/Monomer/Core/WidgetTypes.hs

@@ -115,7 +115,7 @@ data WidgetRequest s
   | UpdateWindow WindowRequest
   | UpdateModel (s -> s)
   | UpdateWidgetPath WidgetId Path
-  | forall i . Typeable i => SendMessage Path i
+  | forall i . Typeable i => SendMessage WidgetId i
   | forall i . Typeable i => RunTask WidgetId Path (IO i)
   | forall i . Typeable i => RunProducer WidgetId Path ((i -> IO ()) -> IO ())
 
@@ -166,6 +166,7 @@ data LayoutDirection
 data WidgetEnv s e = WidgetEnv {
   _weOS :: Text,
   _weRenderer :: Renderer,
+  _weFindByPath :: Path -> Maybe WidgetNodeInfo,
   _weMainButton :: Button,
   _weTheme :: Theme,
   _weWindowSize :: Size,

src/Monomer/Main/Core.hs

@@ -115,6 +115,7 @@ runApp window widgetRoot config = do
   let wenv = WidgetEnv {
     _weOS = os,
     _weRenderer = renderer,
+    _weFindByPath = const Nothing,
     _weMainButton = mainBtn,
     _weTheme = theme,
     _weWindowSize = newWindowSize,
@@ -213,6 +214,7 @@ mainLoop window renderer config loopArgs = do
   let wenv = WidgetEnv {
     _weOS = _mlOS,
     _weRenderer = renderer,
+    _weFindByPath = const Nothing,
     _weMainButton = mainBtn,
     _weTheme = _mlTheme,
     _weWindowSize = windowSize,
@@ -232,7 +234,8 @@ mainLoop window renderer config loopArgs = do
     _weOffset = def
   }
   -- Exit handler
-  let exitMsgs = SendMessage (Seq.fromList [0]) <$> _mlExitEvents
+  let baseWidgetId = _mlWidgetRoot ^. L.info . L.widgetId
+  let exitMsgs = SendMessage baseWidgetId <$> _mlExitEvents
   let baseReqs
         | quit = Seq.fromList exitMsgs
         | otherwise = Seq.Empty

src/Monomer/Main/Handlers.hs

@@ -120,12 +120,14 @@ handleSystemEvents wenv baseEvents widgetRoot = nextStep where
     mainBtnPress <- use L.mainBtnPress
     inputStatus <- use L.inputStatus
 
-    let newWenv = curWenv
+    let tmpWenv = curWenv
           & L.cursor .~ curCursor
           & L.hoveredPath .~ hoveredPath
           & L.mainBtnPress .~ mainBtnPress
           & L.inputStatus .~ inputStatus
-
+    let findByPath path = widgetFindByPath curWidget tmpWenv path curRoot
+    let newWenv = tmpWenv
+          & L.findByPath .~ findByPath
     (wenv2, root2, reqs2, evts2) <- handleSystemEvent newWenv evt target curRoot
 
     when (isOnLeave evt) $ do
@@ -262,7 +264,7 @@ handleRequests reqs step = foldM handleRequest step reqs where
     UpdateWindow req -> handleUpdateWindow req step
     UpdateModel fn -> handleUpdateModel fn step
     UpdateWidgetPath wid path -> handleUpdateWidgetPath wid path step
-    SendMessage path msg -> handleSendMessage path msg step
+    SendMessage wid msg -> handleSendMessage wid msg step
     RunTask wid path handler -> handleRunTask wid path handler step
     RunProducer wid path handler -> handleRunProducer wid path handler step
 
@@ -555,11 +557,13 @@ handleUpdateWidgetPath wid path step = do
 
 handleSendMessage
   :: forall s e m msg . (MonomerM s m, Typeable msg)
-  => Path
+  => WidgetId
   -> msg
   -> HandlerStep s e
   -> m (HandlerStep s e)
-handleSendMessage path message (wenv, root, reqs, evts) = do
+handleSendMessage widgetId message (wenv, root, reqs, evts) = do
+  path <- getWidgetIdPath widgetId
+
   let emptyResult = WidgetResult root Seq.empty Seq.empty
   let widget = root ^. L.widget
   let msgResult = widgetHandleMessage widget wenv path message root

src/Monomer/Widgets/Composite.hs

@@ -769,8 +769,8 @@ reduceEvtResponse globalKeys curr@ReducedEvents{..} response = case response of
   Request req -> curr { _reRequests = _reRequests |> req }
   Message key message -> case M.lookup key globalKeys of
     Just node -> curr {
-        _reMessages = _reMessages |> SendMessage (node ^. L.info . L.path) message
-      }
+      _reMessages = _reMessages |> SendMessage (node^.L.info.L.widgetId) message
+    }
     Nothing -> curr
   Task task -> curr { _reTasks = _reTasks |> task }
   Producer producer -> curr { _reProducers = _reProducers |> producer }
@@ -844,6 +844,7 @@ convertWidgetEnv :: WidgetEnv sp ep -> GlobalKeys s e -> s -> WidgetEnv s e
 convertWidgetEnv wenv globalKeys model = WidgetEnv {
   _weOS = _weOS wenv,
   _weRenderer = _weRenderer wenv,
+  _weFindByPath = _weFindByPath wenv,
   _weMainButton = _weMainButton wenv,
   _weTheme = _weTheme wenv,
   _weWindowSize = _weWindowSize wenv,

src/Monomer/Widgets/Dropdown.hs

@@ -264,8 +264,8 @@ makeDropdown widgetData items makeMain makeRow config state = widget where
     mainStyle = collectTheme wenv L.dropdownStyle
     mainNode = makeMain selected
       & L.info . L.style .~ mainStyle
-    path = node ^. L.info . L.path
-    listViewNode = makeListView wenv widgetData items makeRow config path
+    widgetId = node ^. L.info . L.widgetId
+    listViewNode = makeListView wenv widgetData items makeRow config widgetId
     newWidget = makeDropdown widgetData items makeMain makeRow config newState
     newNode = node
       & L.widget .~ newWidget
@@ -483,17 +483,17 @@ makeListView
   -> Seq a
   -> (a -> WidgetNode s e)
   -> DropdownCfg s e a
-  -> Path
+  -> WidgetId
   -> WidgetNode s e
-makeListView wenv value items makeRow config path = listViewNode where
+makeListView wenv value items makeRow config widgetId = listViewNode where
   normalTheme = collectTheme wenv L.dropdownItemStyle
   selectedTheme = collectTheme wenv L.dropdownItemSelectedStyle
   itemStyle = fromJust (Just normalTheme <> _ddcItemStyle config)
   itemSelStyle = fromJust (Just selectedTheme <> _ddcItemSelectedStyle config)
   lvConfig = [
       selectOnBlur,
-      onBlurReq (SendMessage path OnListBlur),
-      onChangeIdxReq (SendMessage path . OnChangeMessage),
+      onBlurReq (SendMessage widgetId OnListBlur),
+      onChangeIdxReq (SendMessage widgetId . OnChangeMessage),
       itemNormalStyle itemStyle,
       itemSelectedStyle itemSelStyle
     ]

src/Monomer/Widgets/ListView.hs

@@ -267,9 +267,9 @@ makeListView widgetData items makeRow config state = widget where
   currentValue wenv = widgetDataGet (_weModel wenv) widgetData
 
   createListViewChildren wenv node = children where
-    path = node ^. L.info . L.path
+    widgetId = node ^. L.info . L.widgetId
     selected = currentValue wenv
-    itemsList = makeItemsList wenv items makeRow config path selected
+    itemsList = makeItemsList wenv items makeRow config widgetId selected
     children = Seq.singleton itemsList
 
   init wenv node = resultWidget newNode where
@@ -384,14 +384,14 @@ makeListView widgetData items makeRow config state = widget where
       & L.widget .~ makeListView widgetData items makeRow config newState
     slIdx = _slIdx state
     (newNode, resizeReq) = updateStyles wenv config state tmpNode slIdx nextIdx
-    reqs = itemScrollTo newNode nextIdx ++ resizeReq
+    reqs = itemScrollTo wenv newNode nextIdx ++ resizeReq
     result = resultReqs newNode reqs
 
   selectItem wenv node idx = result where
     selected = currentValue wenv
     value = fromMaybe selected (Seq.lookup idx items)
     valueSetReq = widgetDataSet widgetData value
-    scrollToReq = itemScrollTo node idx
+    scrollToReq = itemScrollTo wenv node idx
     events = fmap ($ value) (_lvcOnChange config)
       ++ fmap (\fn -> fn idx value) (_lvcOnChangeIdx config)
     changeReqs = _lvcOnChangeReq config
@@ -412,10 +412,10 @@ makeListView widgetData items makeRow config state = widget where
     requests = valueSetReq ++ scrollToReq ++ changeReqs ++ resizeReq
     result = resultReqsEvts newNode requests events
 
-  itemScrollTo node idx = maybeToList (fmap scrollReq viewport) where
-    viewport = itemViewport node idx
-    scrollPath =  parentPath node
-    scrollReq rect = SendMessage scrollPath (ScrollTo rect)
+  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)
 
   itemViewport node idx = viewport where
     lookup idx node = Seq.lookup idx (node ^. L.children)
@@ -515,14 +515,14 @@ makeItemsList
   -> Seq a
   -> MakeRow s e a
   -> ListViewCfg s e a
-  -> Path
+  -> WidgetId
   -> a
   -> WidgetNode s e
-makeItemsList wenv items makeRow config path selected = itemsList where
+makeItemsList wenv items makeRow config widgetId selected = itemsList where
   normalTheme = collectTheme wenv L.listViewItemStyle
   normalStyle = fromJust (Just normalTheme <> _lvcItemStyle config)
   makeItem idx item = newItem where
-    clickCfg = onClickReq $ SendMessage path (OnClickMessage idx)
+    clickCfg = onClickReq $ SendMessage widgetId (OnClickMessage idx)
     itemCfg = [expandContent, clickCfg]
     content = makeRow item
     newItem = box_ itemCfg (content & L.info . L.style .~ normalStyle)

tasks.md

@@ -534,6 +534,9 @@
     - Review dialogs after change is in place (button currently uses expandSize)
       - Remove clearExtra from dialog buttons
   - Make label default to clip text (currently ellipsis). Same for trim
+  - Think about text related combinators
+    - Is the Text/text prefix needed?
+    - TextTrim could be trimSpaces?
 
 - Pending
   - Add header in all files, indicating license and documenting what the module does
@@ -547,9 +550,6 @@ Next
     - Composite example
       - Validate nested structures update correctly when disabling/enabling parent
     - Something of generative art (OpenGL example)
-  - Think about text related combinators
-    - Is the Text/text prefix needed?
-    - TextTrim could be trimSpaces?
   - ListView's SendMessage will fail if location changes. Add SendMessageWid?
   - Auto scroll affects dropdown when listView is displayed
 

test/unit/Monomer/TestUtil.hs

@@ -128,6 +128,7 @@ mockWenv :: s -> WidgetEnv s e
 mockWenv model = WidgetEnv {
   _weOS = "Mac OS X",
   _weRenderer = mockRenderer,
+  _weFindByPath = const Nothing,
   _weMainButton = LeftBtn,
   _weTheme = def,
   _weWindowSize = testWindowSize,

test/unit/Monomer/Widgets/CompositeSpec.hs

@@ -296,7 +296,9 @@ handleMessage = describe "handleMessage" $ do
       -> MainModel
       -> MainEvt
       -> [EventResponse MainModel MainEvt ()]
-    handleEvent wenv node model evt = [Request (SendMessage path msg)]
+    handleEvent wenv node model evt = [Request (SendMessage wid msg)] where
+      wni = wenv ^. L.findByPath $ path
+      wid = maybe def (^. L.widgetId) wni
     buildUI wenv model = vstack [
         button "Start" MainBtnClicked,
         composite "child" child buildChild handleChild