Add SetFocusOnKey/MoveFocusFromKey to Composite (#37)

* Add SetFocusOnKey/MoveFocusFromKey to Composite. This makes setting focus from user event handlers more predictable

* Bump version. Update Changelog

ChangeLog.md

@@ -7,12 +7,17 @@
 - Add `containerCreateContainerFromModel` to workaround issue when updating offset during merge.
 - Add `appDisableCompositing` to allow requesting compositing to be disabled on startup.
 - Add `optionButton` and `toggleButton` widgets.
+- Add `SetFocusOnKey` and `MoveFocusFromKey` actions in `Composite`. Deprecate `setFocusOnKey` function.
+  This function depended on information in `WidgetEnv`, which can become stale if several actions are
+  returned at once. This change reduces confusion regarding order of operations and widget tree state.
 
 ### Fixed
 
 - Keep old Composite root if model has not changed. This does not affect previous code,
   it is only relevant with new features.
 - Generate `IgnoreParentEvents` request from widgets that handle Wheel event (avoids issues with scroll widget moving the content).
+- Do not run tests which depend on SDL's video subsystem to be available unless an environment variable is defined.
+  This allows for (hopefully) running tests on Hackage and, later on, deploying to Stackage.
 
 ### Changed
 

docs/tutorials/06-composite.md

@@ -34,6 +34,10 @@ data EventResponse s e sp ep
   | Report ep
   -- Sends a Widget Request
   | Request (WidgetRequest s e)
+  -- Sets focus on the given key
+  | SetFocusOnKey WidgetKey
+  -- Moves focus forward/backward, optionally starting from the given key.
+  | MoveFocusFromKey (Maybe WidgetKey) FocusDirection
   -- Sends a message to the specified key
   | forall i . Typeable i => Message WidgetKey i
   -- Launches a Task
@@ -73,9 +77,6 @@ easier to use interface:
 `WidgetRequest`s will be explored in more detail in the custom widgets tutorial,
 but some requests can be interesting for an application or composite:
 
-- MoveFocus: Moves focus to the next focusable widget in the given direction.
-- SetFocus: Sets focus on a specific widget. We have already used this request
-  when calling `setFocusOnKey`.
 - ExitApplication: Requests to exit the application or cancel an active request
   to exit. This is useful combined with `appExitEvent`.
 - UpdateWindow: Allows making window related actions, such as setting window

examples/books/Main.hs

@@ -141,7 +141,7 @@ handleEvent
   -> BooksEvt
   -> [EventResponse BooksModel BooksEvt BooksModel ()]
 handleEvent sess wenv node model evt = case evt of
-  BooksInit -> [setFocusOnKey wenv "query"]
+  BooksInit -> [SetFocusOnKey "query"]
   BooksSearch -> [
     Model $ model & searching .~ True,
     Task $ searchBooks sess (model ^. query)

examples/generative/Main.hs

@@ -103,7 +103,7 @@ handleEvent
   -> GenerativeEvt
   -> [EventResponse GenerativeModel GenerativeEvt GenerativeModel ()]
 handleEvent wenv node model evt = case evt of
-  GenerativeInit -> [setFocusOnKey wenv "activeType"]
+  GenerativeInit -> [SetFocusOnKey "activeType"]
 
 main :: IO ()
 main = do

examples/ticker/Main.hs

@@ -130,15 +130,15 @@ handleEvent env wenv node model evt = case evt of
       & symbolPairs .~ initialList,
     Producer (startProducer env),
     Task (subscribeInitial env initialList),
-    setFocusOnKey wenv "newPair"
+    SetFocusOnKey "newPair"
     ]
 
   TickerAddClick -> [
     Model $ model
       & symbolPairs %~ (model ^. newPair <|)
       & newPair .~ "",
     Task $ subscribe env [model ^. newPair],
-    setFocusOnKey wenv "newPair"
+    SetFocusOnKey "newPair"
     ]
 
   TickerRemovePairBegin pair -> [

examples/todo/Main.hs

@@ -162,32 +162,32 @@ handleEvent
   -> TodoEvt
   -> [EventResponse TodoModel TodoEvt TodoModel ()]
 handleEvent wenv node model evt = case evt of
-  TodoInit -> [setFocusOnKey wenv "todoNew"]
+  TodoInit -> [SetFocusOnKey "todoNew"]
 
   TodoNew -> [
     Event TodoShowEdit,
     Model $ model
       & action .~ TodoAdding
       & activeTodo .~ def,
-    setFocusOnKey wenv "todoDesc"]
+    SetFocusOnKey "todoDesc"]
 
   TodoEdit idx td -> [
     Event TodoShowEdit,
     Model $ model
       & action .~ TodoEditing idx
       & activeTodo .~ td,
-    setFocusOnKey wenv "todoDesc"]
+    SetFocusOnKey "todoDesc"]
 
   TodoAdd -> [
     Event TodoHideEdit,
     Model $ addNewTodo wenv model,
-    setFocusOnKey wenv "todoNew"]
+    SetFocusOnKey "todoNew"]
 
   TodoSave idx -> [
     Event TodoHideEdit,
     Model $ model
       & todos . ix idx .~ (model ^. activeTodo),
-    setFocusOnKey wenv "todoNew"]
+    SetFocusOnKey "todoNew"]
 
   TodoDeleteBegin idx todo -> [
     Message (WidgetKey (todoRowKey todo)) AnimationStart]
@@ -196,13 +196,13 @@ handleEvent wenv node model evt = case evt of
     Model $ model
       & action .~ TodoNone
       & todos .~ remove idx (model ^. todos),
-    setFocusOnKey wenv "todoNew"]
+    SetFocusOnKey "todoNew"]
 
   TodoCancel -> [
     Event TodoHideEdit,
     Model $ model
       & activeTodo .~ def,
-    setFocusOnKey wenv "todoNew"]
+    SetFocusOnKey "todoNew"]
 
   TodoShowEdit -> [
     Message "animEditIn" AnimationStart,

examples/tutorial/Tutorial03_LifeCycle.hs

@@ -84,13 +84,14 @@ handleEvent wenv node model evt = case evt of
       Model $ model
         & newItemText .~ ""
         & items .~ newItem : model ^. items,
-      setFocusOnKey wenv "description"]
+      SetFocusOnKey "description"]
   RemoveItem idx -> [Model $ model
     & items .~ removeIdx idx (model ^. items)]
   _ -> []
   where
     newItem = ListItem (wenv ^. L.timestamp) (model ^. newItemText)
 
+removeIdx :: Int -> [a] -> [a]
 removeIdx idx lst = part1 ++ drop 1 part2 where
   (part1, part2) = splitAt idx lst
 

monomer.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           monomer
-version:        1.1.1.0
+version:        1.2.0.0
 synopsis:       A GUI library for writing native Haskell applications.
 description:    Monomer is an easy to use, cross platform, GUI library for writing native
                 Haskell applications.

package.yaml

@@ -1,5 +1,5 @@
 name: monomer
-version: 1.1.1.0
+version: 1.2.0.0
 github: fjvallarino/monomer
 license: BSD3
 author: Francisco Vallarino

src/Monomer/Main/UserUtil.hs

@@ -24,8 +24,9 @@ import Monomer.Widgets.Composite
 import qualified Monomer.Core.Lens as L
 import qualified Monomer.Main.Lens as L
 
+{-# DEPRECATED setFocusOnKey "Use SetFocusOnKey instead (wenv argument should be removed)." #-}
 {-|
-Generates a response to sets focus on the given key, provided as WidgetKey. If
+Generates a response to set focus on the given key, provided as WidgetKey. If
 the key does not exist, focus will remain on the currently focused widget.
 -}
 setFocusOnKey :: WidgetEnv s e -> WidgetKey -> EventResponse s e sp ep

src/Monomer/Widgets/Composite.hs

@@ -134,6 +134,18 @@ type ProducerHandler e = (e -> IO ()) -> IO ()
 data CompMsgUpdate
   = forall s . CompositeModel s => CompMsgUpdate (s -> s)
 
+{-|
+Delayed request. Used to account for widget tree changes in previous steps. When
+processing EventResponses that depend on WidgetKeys, resolving the key at the
+time the response is created may result in missing/no longer valid keys. The
+delayed message allows resolving the key right before the WidgetRequest is
+processed.
+-}
+data CompMsgDelayedRequest
+  = CompMsgSetFocus WidgetKey
+  | CompMsgMoveFocus (Maybe WidgetKey) FocusDirection
+  | forall i . Typeable i => CompMsgMessage WidgetKey i
+
 -- | Response options for an event handler.
 data EventResponse s e sp ep
   -- | Modifies the current model, prompting a merge.
@@ -151,6 +163,16 @@ data EventResponse s e sp ep
   -}
   | RequestParent (WidgetRequest sp ep)
   {-|
+  Generates a request to set focus on the widget with the matching key. If the
+  key does not exist, focus remains on the currently focused widget.
+  -}
+  | SetFocusOnKey WidgetKey
+  {-|
+  Generates a request to move focus forward/backward, optionally indicating the
+  key of the starting widget.
+  -}
+  | MoveFocusFromKey (Maybe WidgetKey) FocusDirection
+  {-|
   Sends a message to the given key. If the key does not exist, the message will
   not be delivered.
   -}
@@ -288,8 +310,6 @@ compositeMergeReqs fn = def {
 Generates a custom model from the current parent model and the previous
 composite model. Useful when the composite needs a more complex model than what
 the user is binding.
-
-For a usage example, see 'Monomer.Widgets.Singles.ColorPopup'.
 -}
 customModelBuilder
   :: CompositeCustomModelBuilder s sp
@@ -692,7 +712,9 @@ compositeHandleMessage comp state@CompositeState{..} !wenv !widgetComp !target a
       Just evt -> Just $ handleMsgEvent comp state wenv widgetComp evt
       Nothing -> case cast arg of
         Just (CompMsgUpdate msg) -> handleMsgUpdate comp state wenv widgetComp <$> cast msg
-        _ -> traceShow ("Failed match on Composite handleEvent", typeOf arg) Nothing
+        Nothing -> case cast arg of
+          Just req -> handleDelayedRequest comp state wenv widgetComp req
+          _ -> traceShow ("Failed match on Composite handleMessage", typeOf arg) Nothing
   | otherwise = fmap processEvent result where
       processEvent = toParentResult comp state wenv widgetComp
       cmpWidget = _cpsRoot ^. L.widget
@@ -844,19 +866,42 @@ evtResponseToRequest
   -> EventResponse s e sp ep
   -> Maybe (WidgetRequest sp ep)
 evtResponseToRequest widgetComp widgetKeys response = case response of
-  Model newModel -> Just $ sendTo widgetComp (CompMsgUpdate $ const newModel)
-  Event event -> Just $ sendTo widgetComp event
+  Model newModel -> Just $ sendMsgTo widgetComp (CompMsgUpdate $ const newModel)
+  Event event -> Just $ sendMsgTo widgetComp event
   Report report -> Just (RaiseEvent report)
   Request req -> toParentReq widgetId req
   RequestParent req -> Just req
-  Message key msg -> (`sendTo` msg) <$> M.lookup key widgetKeys
+  SetFocusOnKey key -> Just $ sendMsgTo widgetComp (CompMsgSetFocus key)
+  MoveFocusFromKey key dir -> Just $ sendMsgTo widgetComp (CompMsgMoveFocus key dir)
+  Message key msg -> Just $ sendMsgTo widgetComp (CompMsgMessage key msg)
   Task task -> Just $ RunTask widgetId path task
   Producer producer -> Just $ RunProducer widgetId path producer
   where
-    sendTo node msg = SendMessage (node ^. L.info . L.widgetId) msg
     widgetId = widgetComp ^. L.info . L.widgetId
     path = widgetComp ^. L.info . L.path
 
+handleDelayedRequest
+  :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, CompParentModel sp)
+  => Composite s e sp ep
+  -> CompositeState s e
+  -> WidgetEnv sp ep
+  -> WidgetNode sp ep
+  -> CompMsgDelayedRequest
+  -> Maybe (WidgetResult sp ep)
+handleDelayedRequest comp state wenv node req = result where
+    widgetKeys = _cpsWidgetKeyMap state
+    newReq = case req of
+      CompMsgSetFocus key -> setFocus <$> lookupNode widgetKeys "SetFocusOnKey" key
+      CompMsgMoveFocus (Just key) dir -> moveFocusFrom key dir
+      CompMsgMoveFocus _ dir -> Just $ MoveFocus Nothing dir
+      CompMsgMessage key msg -> (`sendMsgTo` msg) <$> lookupNode widgetKeys "Message" key
+    result = resultReqs node . (: []) <$> newReq
+
+    setFocus node = SetFocus (node ^. L.info . L.widgetId)
+    moveFocusFrom key dir = mwid >> Just (MoveFocus mwid dir) where
+      mnode = lookupNode widgetKeys "MoveFocusFromKey" key
+      mwid = (^. L.info . L.widgetId) <$> mnode
+
 mergeChild
   :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, CompParentModel sp)
   => Composite s e sp ep
@@ -988,3 +1033,11 @@ cascadeCtx wenv parent child = newChild where
     & L.info . L.path .~ newPath
     & L.info . L.visible .~ (cVisible && pVisible)
     & L.info . L.enabled .~ (cEnabled && pEnabled)
+
+lookupNode :: WidgetKeyMap s e -> String -> WidgetKey -> Maybe (WidgetNode s e)
+lookupNode widgetKeys desc key = case M.lookup key widgetKeys of
+  Nothing -> trace ("Key " ++ show key ++ " not found for " ++ desc) Nothing
+  res -> res
+
+sendMsgTo :: Typeable i => WidgetNode s e -> i -> WidgetRequest sp ep
+sendMsgTo node msg = SendMessage (node ^. L.info . L.widgetId) msg