Add globalKeys handling

app/KeysComposite.hs

@@ -50,7 +50,7 @@ initialState = KeysCompState {
   ]
 }
 
-keysComposite :: WidgetNode KeysCompState ep
+keysComposite :: WidgetEvent ep => WidgetNode KeysCompState ep
 keysComposite = composite "keysComposite" id Nothing handleKeysCompEvent buildKeysComp
 
 handleKeysCompEvent model evt = case evt of

src/Monomer/Core/Lens.hs

@@ -36,3 +36,4 @@ makeLensesWith abbreviatedFields ''WidgetSizeReq
 makeLensesWith abbreviatedFields ''WidgetData
 makeLensesWith abbreviatedFields ''WidgetNode
 makeLensesWith abbreviatedFields ''WidgetInstance
+makeLensesWith abbreviatedFields ''WidgetInstanceNode

src/Monomer/Core/StyleUtil.hs

@@ -33,10 +33,14 @@ import Monomer.Graphics.Types
 import qualified Monomer.Lens as L
 
 infixl 5 `key`
+infixl 5 `globalKey`
 infixl 5 `visible`
 
 key :: WidgetNode s e -> Text -> WidgetNode s e
-key node key = node & L.widgetInstance . L.key ?~ WidgetKey key
+key node key = node & L.widgetInstance . L.key ?~ WidgetLocalKey key
+
+globalKey :: WidgetNode s e -> Text -> WidgetNode s e
+globalKey node key = node & L.widgetInstance . L.key ?~ WidgetGlobalKey key
 
 visible :: WidgetNode s e -> Bool -> WidgetNode s e
 visible node visibility = node & L.widgetInstance . L.visible .~ visibility

src/Monomer/Core/Util.hs

@@ -1,8 +1,13 @@
+{-# LANGUAGE FlexibleContexts #-}
+
 module Monomer.Core.Util where
 
 import Control.Lens ((&), (^.), (.~), (?~))
+import Data.List (foldl')
 import Data.Text (Text)
 
+import qualified Data.Map as Map
+
 import Monomer.Core.BasicTypes
 import Monomer.Core.Style
 import Monomer.Core.WidgetTypes
@@ -39,3 +44,12 @@ numberInBounds Nothing Nothing _ = True
 numberInBounds (Just minVal) Nothing val = val >= minVal
 numberInBounds Nothing (Just maxVal) val = val <= maxVal
 numberInBounds (Just minVal) (Just maxVal) val = val >= minVal && val <= maxVal
+
+buildGlobalKeysMap :: WidgetEnv s e -> WidgetNode s e -> GlobalKeys
+buildGlobalKeysMap wenv node = buildMap Map.empty instTree where
+  instTree = widgetGetInstanceTree (_wnWidget node) wenv node
+  buildMap map inst = newMap where
+    tempMap = case inst ^. L.inst . L.key of
+      Just (WidgetGlobalKey key) -> Map.insert (WidgetGlobalKey key) inst map
+      _ -> map
+    newMap = foldl' buildMap tempMap (inst ^. L.children)

src/Monomer/Core/WidgetTypes.hs

@@ -22,7 +22,7 @@ import Monomer.Graphics.Types
 type Timestamp = Int
 type WidgetModel s = Typeable s
 type WidgetEvent e = Typeable e
-type GlobalKeys s e = Map WidgetKey (WidgetNode s e)
+type GlobalKeys = Map WidgetKey WidgetInstanceNode
 
 data FocusDirection
   = FocusFwd
@@ -54,8 +54,9 @@ data WidgetData s a
   = WidgetValue a
   | WidgetLens (ALens' s a)
 
-newtype WidgetKey
-  = WidgetKey Text
+data WidgetKey
+  = WidgetLocalKey Text
+  | WidgetGlobalKey Text
   deriving (Eq, Ord, Show)
 
 data WidgetState
@@ -109,7 +110,7 @@ data WidgetEnv s e = WidgetEnv {
   _weRenderer :: Renderer,
   _weTheme :: Theme,
   _weAppWindowSize :: Size,
---  _weGlobalKeys :: GlobalKeys s e,
+  _weGlobalKeys :: GlobalKeys,
   _weFocusedPath :: Path,
   _weOverlayPath :: Maybe Path,
   _weCurrentCursor :: CursorIcon,

src/Monomer/Main/Core.hs

@@ -118,7 +118,7 @@ runApp window maxFps fonts theme exitEvent widgetRoot = do
     _weRenderer = renderer,
     _weTheme = theme,
     _weAppWindowSize = newWindowSize,
---    _weGlobalKeys = Map.empty,
+    _weGlobalKeys = Map.empty,
     _weCurrentCursor = CursorArrow,
     _weFocusedPath = rootPath,
     _weOverlayPath = Nothing,
@@ -168,6 +168,7 @@ mainLoop window renderer loopArgs = do
   currentCursor <- use currentCursor
   focused <- use pathFocus
   overlay <- use pathOverlay
+  currentGlobalKeys <- use globalKeys
 
   let MainLoopArgs{..} = loopArgs
   let !ts = startTicks - _mlFrameStartTs
@@ -189,7 +190,7 @@ mainLoop window renderer loopArgs = do
     _weRenderer = renderer,
     _weTheme = _mlTheme,
     _weAppWindowSize = windowSize,
---    _weGlobalKeys = Map.empty,
+    _weGlobalKeys = currentGlobalKeys,
     _weCurrentCursor = currentCursor,
     _weFocusedPath = focused,
     _weOverlayPath = overlay,

src/Monomer/Main/Handlers.hs

@@ -162,6 +162,7 @@ handleResizeWidgets reqs previousStep =
       let (wenv, events, widgetRoot) = previousStep
       let newWidgetRoot = resizeRoot wenv windowSize widgetRoot
 
+      L.globalKeys .= buildGlobalKeysMap wenv newWidgetRoot
       L.renderRequested .= True
 
       return (wenv, events, newWidgetRoot)

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
 
@@ -51,6 +52,7 @@ data MonomerContext s = MonomerContext {
   _mcPathPressed :: Maybe Path,
   _mcPathOverlay :: Maybe Path,
   _mcWidgetTasks :: Seq WidgetTask,
+  _mcGlobalKeys :: GlobalKeys,
   _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 {
   _mcPathPressed = Nothing,
   _mcPathOverlay = Nothing,
   _mcWidgetTasks = Seq.empty,
+  _mcGlobalKeys = Map.empty,
   _mcCursorIcons = Map.empty,
   _mcRenderRequested = False,
   _mcRenderSchedule = Map.empty,

src/Monomer/Widgets/Composite.hs

@@ -111,8 +111,7 @@ data Composite s e sp ep = Composite {
 
 data CompositeState s e sp = CompositeState {
   _cpsModel :: Maybe s,
-  _cpsRoot :: WidgetNode s e,
-  _cpsGlobalKeys :: GlobalKeys s e
+  _cpsRoot :: WidgetNode s e
 }
 
 data ReducedEvents s e sp ep = ReducedEvents {
@@ -198,7 +197,7 @@ compositeD_ wType wData initEvt evtHandler uiBuilder configs = newNode where
     _cmpOnChange = _cmcOnChange config,
     _cmpOnChangeReq = _cmcOnChangeReq config
   }
-  state = CompositeState Nothing widgetRoot M.empty
+  state = CompositeState Nothing widgetRoot
   widget = createComposite composite state
   newNode = defaultWidgetNode wType widget
 
@@ -234,7 +233,7 @@ compositeInit
 compositeInit comp state wenv widgetComp = newResult where
   CompositeState{..} = state
   model = getModel comp wenv
-  cwenv = convertWidgetEnv wenv _cpsGlobalKeys model
+  cwenv = convertWidgetEnv wenv model
   -- Creates UI using provided function
   builtRoot = _cmpUiBuilder comp model
   tempRoot = cascadeCtx widgetComp builtRoot
@@ -242,8 +241,7 @@ compositeInit comp state wenv widgetComp = newResult where
   newEvts = maybe evts (evts |>) (_cmpInitEvent comp)
   newState = state {
     _cpsModel = Just model,
-    _cpsRoot = root,
-    _cpsGlobalKeys = collectGlobalKeys M.empty root
+    _cpsRoot = root
   }
   tempResult = WidgetResult root reqs newEvts
   getBaseStyle wenv node = Nothing
@@ -262,12 +260,12 @@ compositeMerge
 compositeMerge comp state wenv oldComp newComp = newResult where
   oldState = widgetGetState (oldComp ^. L.widget) wenv
   validState = fromMaybe state (useState oldState)
-  CompositeState oldModel oldRoot oldGlobalKeys = validState
+  CompositeState oldModel oldRoot = validState
   model = getModel comp wenv
   -- Creates new UI using provided function
   tempRoot = cascadeCtx newComp (_cmpUiBuilder comp model)
   tempWidget = tempRoot ^. L.widget
-  cwenv = convertWidgetEnv wenv oldGlobalKeys model
+  cwenv = convertWidgetEnv wenv model
   -- Needed in case the user references something outside model when building UI
   -- The same model is provided as old since nothing else is available, but
   -- mergeRequired may be using data from a closure
@@ -281,8 +279,7 @@ compositeMerge comp state wenv oldComp newComp = newResult where
   newRoot = _wrWidget tempResult
   newState = validState {
     _cpsModel = Just model,
-    _cpsRoot = newRoot,
-    _cpsGlobalKeys = collectGlobalKeys M.empty newRoot
+    _cpsRoot = newRoot
   }
   getBaseStyle wenv node = Nothing
   styledComp = initInstanceStyle getBaseStyle wenv newComp
@@ -302,7 +299,7 @@ compositeDispose
 compositeDispose comp state wenv widgetComp = result where
   CompositeState{..} = state
   model = getModel comp wenv
-  cwenv = convertWidgetEnv wenv _cpsGlobalKeys model
+  cwenv = convertWidgetEnv wenv model
   widget = _cpsRoot ^. L.widget
   WidgetResult _ reqs evts = widgetDispose widget cwenv _cpsRoot
   tempResult = WidgetResult _cpsRoot reqs evts
@@ -322,7 +319,7 @@ compositeFindNextFocus comp state wenv dir start widgetComp = nextFocus where
   CompositeState{..} = state
   widget = _cpsRoot ^. L.widget
   model = getModel comp wenv
-  cwenv = convertWidgetEnv wenv _cpsGlobalKeys model
+  cwenv = convertWidgetEnv wenv model
   nextFocus = widgetFindNextFocus widget cwenv dir start _cpsRoot
 
 -- | Find
@@ -342,7 +339,7 @@ compositeFindByPoint comp state wenv startPath point widgetComp
     CompositeState{..} = state
     widget = _cpsRoot ^. L.widget
     model = getModel comp wenv
-    cwenv = convertWidgetEnv wenv _cpsGlobalKeys model
+    cwenv = convertWidgetEnv wenv model
     validStep = Seq.null startPath || Seq.index startPath 0 == 0
     newStartPath = Seq.drop 1 startPath
     resultPath = widgetFindByPoint widget cwenv newStartPath point _cpsRoot
@@ -361,7 +358,7 @@ compositeHandleEvent comp state wenv target evt widgetComp = result where
   CompositeState{..} = state
   widget = _cpsRoot ^. L.widget
   model = getModel comp wenv
-  cwenv = convertWidgetEnv wenv _cpsGlobalKeys model
+  cwenv = convertWidgetEnv wenv model
   rootEnabled = _cpsRoot ^. L.widgetInstance . L.enabled
   compVisible = widgetComp ^. L.widgetInstance . L.visible
   compEnabled = widgetComp ^. L.widgetInstance . L.enabled
@@ -392,7 +389,7 @@ compositeHandleMessage comp state@CompositeState{..} wenv target arg widgetComp
       processEvent = reduceResult comp state wenv widgetComp
       cmpWidget = _cpsRoot ^. L.widget
       model = getModel comp wenv
-      cwenv = convertWidgetEnv wenv _cpsGlobalKeys model
+      cwenv = convertWidgetEnv wenv model
       result = widgetHandleMessage cmpWidget cwenv target arg _cpsRoot
 
 -- Preferred size
@@ -408,7 +405,7 @@ compositeGetSizeReq comp state wenv widgetComp = newSizeReq where
   style = activeStyle wenv widgetComp
   widget = _cpsRoot ^. L.widget
   model = getModel comp wenv
-  cwenv = convertWidgetEnv wenv _cpsGlobalKeys model
+  cwenv = convertWidgetEnv wenv model
   tempChildReq = widgetGetSizeReq widget cwenv _cpsRoot
   newChildReq = sizeReqAddStyle style tempChildReq
   childRoot = newChildReq ^. L.widget
@@ -440,7 +437,7 @@ compositeResize comp state wenv viewport renderArea widgetComp = resized where
   contentArea = fromMaybe def (removeOuterBounds style renderArea)
   widget = _cpsRoot ^. L.widget
   model = getModel comp wenv
-  cwenv = convertWidgetEnv wenv _cpsGlobalKeys model
+  cwenv = convertWidgetEnv wenv model
   newRoot = widgetResize widget cwenv viewport contentArea _cpsRoot
   newState = state {
     _cpsRoot = newRoot
@@ -465,7 +462,7 @@ compositeRender comp state renderer wenv _ = action where
   CompositeState{..} = state
   widget = _cpsRoot ^. L.widget
   model = getModel comp wenv
-  cwenv = convertWidgetEnv wenv _cpsGlobalKeys model
+  cwenv = convertWidgetEnv wenv model
   action = widgetRender widget renderer cwenv _cpsRoot
 
 reduceResult
@@ -487,7 +484,8 @@ reduceResult comp state wenv widgetComp widgetResult = newResult where
   evtUpdates = getUpdateModelReqs reqs
   evtModel = foldr (.) id evtUpdates model
   evtHandler = _cmpEventHandler comp
-  ReducedEvents{..} = reduceCompEvents _cpsGlobalKeys evtHandler evtModel evts
+  globalKeys = wenv ^. L.globalKeys
+  ReducedEvents{..} = reduceCompEvents globalKeys evtHandler evtModel evts
   WidgetResult uWidget uReqs uEvts =
     updateComposite comp state wenv _reModel evtsRoot widgetComp
   currentPath = widgetComp ^. L.widgetInstance . L.path
@@ -537,7 +535,7 @@ mergeChild comp state wenv newModel widgetRoot widgetComp = newResult where
   CompositeState{..} = state
   builtRoot = cascadeCtx widgetComp (_cmpUiBuilder comp newModel)
   builtWidget = builtRoot ^. L.widget
-  cwenv = convertWidgetEnv wenv _cpsGlobalKeys newModel
+  cwenv = convertWidgetEnv wenv newModel
   mergedResult = widgetMerge builtWidget cwenv widgetRoot builtRoot
   mergedReqs = _wrRequests mergedResult
   resizeRequired = isJust (Seq.findIndexL isResizeWidgets mergedReqs)
@@ -569,7 +567,7 @@ resizeResult comp state wenv result widgetComp = resizedResult where
   viewport = widgetComp ^. L.widgetInstance . L.viewport
   renderArea = widgetComp ^. L.widgetInstance . L.renderArea
   model = getModel comp wenv
-  cwenv = convertWidgetEnv wenv _cpsGlobalKeys model
+  cwenv = convertWidgetEnv wenv model
   widgetRoot = _wrWidget result
   tempRoot = resizeWidget cwenv viewport renderArea widgetRoot
   newRoot = tempRoot
@@ -580,7 +578,7 @@ resizeResult comp state wenv result widgetComp = resizedResult where
   }
 
 reduceCompEvents
-  :: GlobalKeys s e
+  :: GlobalKeys
   -> EventHandler s e ep
   -> s
   -> Seq e
@@ -603,7 +601,7 @@ reduceCompEvents globalKeys eventHandler model events = result where
   result = foldl' reducer initial events
 
 reduceEvtResponse
-  :: GlobalKeys s e
+  :: GlobalKeys
   -> ReducedEvents s e sp ep
   -> EventResponse s e ep
   -> ReducedEvents s e sp ep
@@ -614,7 +612,7 @@ 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.widgetInstance . L.path) message
+        _reMessages = _reMessages |> SendMessage (node ^. L.inst . L.path) message
       }
     Nothing -> curr
   Task task -> curr { _reTasks = _reTasks |> task }
@@ -667,24 +665,13 @@ toParentReq (ExitApplication exit) = Just (ExitApplication exit)
 toParentReq (UpdateWindow req) = Just (UpdateWindow req)
 toParentReq (UpdateModel fn) = Nothing
 
-collectGlobalKeys
-  :: Map WidgetKey (WidgetNode s e)
-  -> WidgetNode s e
-  -> Map WidgetKey (WidgetNode s e)
-collectGlobalKeys keys node = foldl' collect updatedMap children where
-  children = node ^. L.children
-  collect currKeys child = collectGlobalKeys currKeys child
-  updatedMap = case node ^. L.widgetInstance . L.key of
-    Just key -> M.insert key node keys
-    _ -> keys
-
-convertWidgetEnv :: WidgetEnv sp ep -> GlobalKeys s e -> s -> WidgetEnv s e
-convertWidgetEnv wenv globalKeys model = WidgetEnv {
+convertWidgetEnv :: WidgetEnv sp ep -> s -> WidgetEnv s e
+convertWidgetEnv wenv model = WidgetEnv {
   _weOS = _weOS wenv,
   _weRenderer = _weRenderer wenv,
   _weTheme = _weTheme wenv,
   _weAppWindowSize = _weAppWindowSize wenv,
---  _weGlobalKeys = globalKeys,
+  _weGlobalKeys = _weGlobalKeys wenv,
   _weCurrentCursor = _weCurrentCursor wenv,
   _weFocusedPath = _weFocusedPath wenv,
   _weOverlayPath = _weOverlayPath wenv,

tasks.md

@@ -332,6 +332,7 @@ Maybe postponed after release?
       - Add method to collect tree of WidgetInstances
       - Also return map of GlobalKeys, whose value is an existential wrapping the WidgetNode
         -  This is necessary because s/e types may not match
+  - Do not request render from Composite's resize
   - Do not hover if mouse drag on different widget
   - Fix selectOnBlur for dropdown
   - Set focus on ButtonDown, not Click

test/unit/Monomer/TestUtil.hs

@@ -113,7 +113,7 @@ mockWenv model = WidgetEnv {
   _weRenderer = mockRenderer,
   _weTheme = def,
   _weAppWindowSize = testWindowSize,
---  _weGlobalKeys = M.empty,
+  _weGlobalKeys = M.empty,
   _weFocusedPath = rootPath,
   _weOverlayPath = Nothing,
   _weCurrentCursor = CursorArrow,