Remove global/local keys, keep a single (global) kind. Restrict Container merge to local widgets only. Fix associated issues

2024-11-13 00:11:06 +03:00 · 2021-03-09 22:36:44 -03:00 · 2021-03-09 22:36:44 -03:00 · e27a6391e9
commit e27a6391e9
parent 4b543e5c86
10 changed files with 73 additions and 130 deletions
--- a/examples/todo/Main.hs
+++ b/examples/todo/Main.hs
@ -99,7 +99,7 @@ handleEvent wenv node model evt = case evt of
      & todos . ix idx .~ (model ^. activeTodo),
    setFocus wenv "todoNew"]
  TodoDeleteBegin idx todo -> [
-    Message (WidgetKeyGlobal (todoRowKey todo)) AnimationStart]
+    Message (WidgetKey (todoRowKey todo)) AnimationStart]
  TodoDelete idx todo -> [
    Model $ model
      & action .~ TodoNone
--- a/src/Monomer/Core/StyleUtil.hs
+++ b/src/Monomer/Core/StyleUtil.hs
@ -2,7 +2,6 @@

 module Monomer.Core.StyleUtil (
  key,
-  localKey,
  style,
  hover,
  focus,
@ -40,14 +39,10 @@ import Monomer.Graphics.Types
 import qualified Monomer.Lens as L

 infixl 5 `key`
-infixl 5 `localKey`
 infixl 5 `visible`

 key :: WidgetNode s e -> Text -> WidgetNode s e
-key node key = node & L.info . L.key ?~ WidgetKeyGlobal key
-
-localKey :: WidgetNode s e -> Text -> WidgetNode s e
-localKey node key = node & L.info . L.key ?~ WidgetKeyLocal key
+key node key = node & L.info . L.key ?~ WidgetKey key

 visible :: WidgetNode s e -> Bool -> WidgetNode s e
 visible node visibility = node & L.info . L.visible .~ visibility
--- a/src/Monomer/Core/Util.hs
+++ b/src/Monomer/Core/Util.hs
@ -17,11 +17,11 @@ import qualified Monomer.Lens as L

 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)
+  node = Map.lookup (WidgetKey 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)
+  node = Map.lookup (WidgetKey key) (wenv ^. L.globalKeys)

 widgetTreeDesc :: Int -> WidgetNode s e -> String
 widgetTreeDesc level node = desc where
--- a/src/Monomer/Core/WidgetTypes.hs
+++ b/src/Monomer/Core/WidgetTypes.hs
@ -32,8 +32,7 @@ type Timestamp = Int

 type WidgetEvent e = Typeable e

-type LocalKeys s e = Map WidgetKey (WidgetNode s e)
-type GlobalKeys s e = Map WidgetKey (WidgetNode s e)
+type WidgetKeysMap s e = Map WidgetKey (WidgetNode s e)

 data FocusDirection
  = FocusFwd
@ -50,11 +49,8 @@ data WindowRequest
  deriving (Eq, Show)

 newtype WidgetType
-  = WidgetType { unWidgetType :: Text }
-  deriving (Eq, Generic, Serialise)
-
-instance Show WidgetType where
-  show (WidgetType t) = T.unpack t
+  = WidgetType Text
+  deriving (Eq, Show, Generic, Serialise)

 instance IsString WidgetType where
  fromString = WidgetType . T.pack
@ -71,13 +67,12 @@ data WidgetId = WidgetId {
 instance Default WidgetId where
  def = WidgetId 0 emptyPath

-data WidgetKey
-  = WidgetKeyLocal Text
-  | WidgetKeyGlobal Text
+newtype WidgetKey
+  = WidgetKey Text
  deriving (Eq, Show, Ord, Generic, Serialise)

 instance IsString WidgetKey where
-  fromString = WidgetKeyGlobal . T.pack
+  fromString = WidgetKey . T.pack

 data WidgetState
  = forall i . (Typeable i, WidgetModel i) => WidgetState i
@ -177,7 +172,7 @@ data WidgetEnv s e = WidgetEnv {
  _weMainButton :: Button,
  _weTheme :: Theme,
  _weWindowSize :: Size,
-  _weGlobalKeys :: GlobalKeys s e,
+  _weGlobalKeys :: WidgetKeysMap s e,
  _weHoveredPath :: Maybe Path,
  _weFocusedPath :: Path,
  _weOverlayPath :: Maybe Path,
--- a/src/Monomer/Main/Util.hs
+++ b/src/Monomer/Main/Util.hs
@ -48,13 +48,13 @@ initMonomerCtx model win winSize useHiDPI devicePixelRate = MonomerCtx {
  _mcExitApplication = False
 }

-setWidgetIdPath :: (MonomerM s m) => WidgetId -> Path -> m ()
-setWidgetIdPath widgetId path = L.widgetPaths . at widgetId .= Just path
-
 getWidgetIdPath :: (MonomerM s m) => WidgetId -> m Path
 getWidgetIdPath widgetId =
  use $ L.widgetPaths . at widgetId . non (widgetId ^. L.path)

+setWidgetIdPath :: (MonomerM s m) => WidgetId -> Path -> m ()
+setWidgetIdPath widgetId path = L.widgetPaths . at widgetId .= Just path
+
 delWidgetIdPath :: (MonomerM s m) => WidgetId -> m ()
 delWidgetIdPath widgetId = L.widgetPaths . at widgetId .= Nothing

--- a/src/Monomer/Widgets/Composite.hs
+++ b/src/Monomer/Widgets/Composite.hs
@ -164,7 +164,7 @@ data Composite s e sp ep = Composite {
 data CompositeState s e = CompositeState {
  _cpsModel :: Maybe s,
  _cpsRoot :: WidgetNode s e,
-  _cpsGlobalKeys :: GlobalKeys s e
+  _cpsGlobalKeys :: WidgetKeysMap s e
 }

 instance WidgetModel s => Serialise (CompositeState s e) where
@ -733,7 +733,7 @@ mergeChild comp state wenv newModel widgetRoot widgetComp = newResult where
    & L.events <>~ Seq.fromList newEvents

 reduceCompEvents
-  :: GlobalKeys s e
+  :: WidgetKeysMap s e
  -> EventHandler s e ep
  -> WidgetEnv s e
  -> WidgetNode s e
@ -758,7 +758,7 @@ reduceCompEvents globalKeys eventHandler cwenv node model events = result where
  result = foldl' reducer initial events

 reduceEvtResponse
-  :: GlobalKeys s e
+  :: WidgetKeysMap s e
  -> ReducedEvents s e sp ep
  -> EventResponse s e ep
  -> ReducedEvents s e sp ep
@ -837,11 +837,11 @@ collectGlobalKeys keys node = newMap where
  children = node ^. L.children
  collect currKeys child = collectGlobalKeys currKeys child
  updatedMap = case node ^. L.info . L.key of
-    Just (WidgetKeyGlobal key) -> M.insert (WidgetKeyGlobal key) node keys
+    Just key -> M.insert key node keys
    _ -> keys
  newMap = foldl' collect updatedMap children

-convertWidgetEnv :: WidgetEnv sp ep -> GlobalKeys s e -> s -> WidgetEnv s e
+convertWidgetEnv :: WidgetEnv sp ep -> WidgetKeysMap s e -> s -> WidgetEnv s e
 convertWidgetEnv wenv globalKeys model = WidgetEnv {
  _weOS = _weOS wenv,
  _weRenderer = _weRenderer wenv,
--- a/src/Monomer/Widgets/Container.hs
+++ b/src/Monomer/Widgets/Container.hs
@ -412,12 +412,13 @@ mergeChildren
 mergeChildren updateCWenv wenv oldNode newNode result = newResult where
  WidgetResult uNode uReqs uEvents = result
  oldChildren = oldNode ^. L.children
-  oldCsIdx = Seq.mapWithIndex (,) oldChildren
+  oldIts = Seq.mapWithIndex (,) oldChildren
  updatedChildren = uNode ^. L.children
  mergeChild idx child = (idx, cascadeCtx wenv uNode child idx)
-  newCsIdx = Seq.mapWithIndex mergeChild updatedChildren
-  localKeys = buildLocalMap oldChildren
-  mpairs = mergeChildrenSeq updateCWenv wenv localKeys newNode oldCsIdx newCsIdx
+  newIts = Seq.mapWithIndex mergeChild updatedChildren
+  oldKeys = buildLocalMap oldChildren
+  newKeys = buildLocalMap (snd <$> newIts)
+  mpairs = mergeChildSeq updateCWenv wenv oldKeys newKeys newNode oldIts newIts
  (mergedResults, removedResults) = mpairs
  mergedChildren = fmap _wrNode mergedResults
  mergedReqs = foldMap _wrRequests mergedResults
@ -429,29 +430,32 @@ mergeChildren updateCWenv wenv oldNode newNode result = newResult where
  newEvents = uEvents <> mergedEvents <> removedEvents
  newResult = WidgetResult mergedNode newReqs newEvents

-mergeChildrenSeq
+mergeChildSeq
  :: (Int -> WidgetNode s e -> WidgetEnv s e)
  -> WidgetEnv s e
-  -> Map WidgetKey (WidgetNode s e)
+  -> WidgetKeysMap s e
+  -> WidgetKeysMap s e
  -> WidgetNode s e
  -> Seq (Int, WidgetNode s e)
  -> Seq (Int, WidgetNode s e)
  -> (Seq (WidgetResult s e), Seq (WidgetResult s e))
-mergeChildrenSeq updateCWenv wenv localKeys newNode oldItems Empty = res where
-  dispose (idx, child) = widgetDispose (child ^. L.widget) wenv child
-  removed = fmap dispose oldItems
+mergeChildSeq updateCWenv wenv oldKeys newKeys newNode oldIts Empty = res where
+  dispose (idx, child) = case flip M.member newKeys <$> child^. L.info. L.key of
+    Just True -> WidgetResult child Empty Empty
+    _ -> widgetDispose (child ^. L.widget) wenv child
+  removed = fmap dispose oldIts
  res = (Empty, removed)
-mergeChildrenSeq updateCWenv wenv localKeys newNode Empty newItems = res where
+mergeChildSeq updateCWenv wenv oldKeys newKeys newNode Empty newIts = res where
  init (idx, child) = widgetInit (child ^. L.widget) wenv child
-  merged = fmap init newItems
+  merged = fmap init newIts
  res = (merged, Empty)
-mergeChildrenSeq updateCWenv wenv localKeys newNode oldItems newItems = res where
-  (_, oldChild) :<| oldChildren = oldItems
-  (newIdx, newChild) :<| newChildren = newItems
+mergeChildSeq updateCWenv wenv oldKeys newKeys newNode oldIts newIts = res where
+  (_, oldChild) :<| oldChildren = oldIts
+  (newIdx, newChild) :<| newChildren = newIts
  globalKeys = wenv ^. L.globalKeys
  newWidget = newChild ^. L.widget
  newChildKey = newChild ^. L.info . L.key
-  oldKeyMatch = newChildKey >>= \key -> findWidgetByKey key localKeys globalKeys
+  oldKeyMatch = newChildKey >>= \key -> M.lookup key oldKeys
  oldMatch = fromJust oldKeyMatch
  cwenv = updateCWenv newIdx newChild
  mergedOld = widgetMerge newWidget cwenv oldChild newChild
@ -461,10 +465,10 @@ mergeChildrenSeq updateCWenv wenv localKeys newNode oldItems newItems = res wher
  isMergeKey = isJust oldKeyMatch && nodeMatches newChild oldMatch
  (child, oldRest)
    | nodeMatches newChild oldChild = (mergedOld, oldChildren)
-    | isMergeKey = (mergedKey, oldItems)
-    | otherwise = (initNew, oldItems)
+    | isMergeKey = (mergedKey, oldIts)
+    | otherwise = (initNew, oldIts)
  (cmerged, cremoved)
-    = mergeChildrenSeq updateCWenv wenv localKeys newNode oldRest newChildren
+    = mergeChildSeq updateCWenv wenv oldKeys newKeys newNode oldRest newChildren
  merged = child <| cmerged
  res = (merged, cremoved)

@ -959,15 +963,6 @@ cascadeCtx wenv parent child idx = newChild where
    & L.info . L.visible .~ (cInfo ^. L.visible && parentVisible)
    & L.info . L.enabled .~ (cInfo ^. L.enabled && parentEnabled)

-findWidgetByKey
-  :: WidgetKey
-  -> LocalKeys s e
-  -> GlobalKeys s e
-  -> Maybe (WidgetNode s e)
-findWidgetByKey key localMap globalMap = local <|> global where
-  local = M.lookup key localMap
-  global = M.lookup key globalMap
-
 buildLocalMap :: Seq (WidgetNode s e) -> Map WidgetKey (WidgetNode s e)
 buildLocalMap widgets = newMap where
  addWidget map widget
--- a/tasks.md
+++ b/tasks.md
@ -552,6 +552,8 @@
    - Two simple ones to start with: fade in/out and slide in/out
  - Check references to old ctx name
  - Reorganize widgets (containers/singles)
+  - Add examples
+    - Todo should use generated ids instead of indexes

 - Pending
  - Add header in all files, indicating license and documenting what the module does
@ -561,15 +563,16 @@
    - https://stackoverflow.com/questions/51275681/how-to-include-a-dependency-c-library-in-haskell-stack

 Next
-  - Review returning Maybe from event handlers
+  - Review returning Maybe from event handlers (return a single value always)
  - Add examples
    - Composite example
      - Validate nested structures update correctly when disabling/enabling parent
    - Something of generative art (OpenGL example)
-    - Todo should use generated ids instead of indexes

 Future
  - Should DuplicateRecordFields be used in internal widget types to avoid the lens prefixes (which are not used in lenses)
+  - Simplify Composite. Do not handle events directly, make them go through as a message so they are handled in order
+    - Does it make sense to merge events into requests?
  - Rename ListView -> SelectList
    - Add support for multiple selection
  - Should cascadeCtx be part of widget interface? Maybe it can be handled on init?
--- a/test/unit/Monomer/Widgets/CompositeSpec.hs
+++ b/test/unit/Monomer/Widgets/CompositeSpec.hs
@ -16,6 +16,7 @@ import Data.Typeable (cast)
 import TextShow
 import Test.Hspec

+import qualified Data.Map as Map
 import qualified Data.Sequence as Seq

 import Monomer.Core
@ -121,7 +122,6 @@ handleEvent = describe "handleEvent" $ do
  handleEventChild
  handleEventResize
  handleEventLocalKey
-  handleEventGlobalKey

 handleEventBasic :: Spec
 handleEventBasic = describe "handleEventBasic" $ do
@ -226,7 +226,12 @@ handleEventResize = describe "handleEventResize" $ do
    cvp = Rect 0 0 640 3020

 handleEventLocalKey :: Spec
-handleEventLocalKey = describe "handleEventLocalKey" $
+handleEventLocalKey = describe "handleEventLocalKey" $ do
+  handleEventLocalKeySingleState
+  handleEventLocalKeyRemoveItem
+
+handleEventLocalKeySingleState :: Spec
+handleEventLocalKeySingleState = describe "handleEventLocalKeySingleState" $
  it "should insert new text at the end, since its merged with a local key" $ do
    wenv1 ^. L.model . text1 `shouldBe` "aacc"
    wenv1 ^. L.model . text2 `shouldBe` ""
@ -234,57 +239,6 @@ handleEventLocalKey = describe "handleEventLocalKey" $
    wenv2 ^. L.model . text2 `shouldBe` ""
    newInstRoot ^? pathLens 0 `shouldBe` Just (Seq.fromList [0, 0, 0, 0])
    newInstRoot ^? pathLens 1 `shouldBe` Just (Seq.fromList [0, 0, 1, 0])
-    newInstRoot ^? widLens 0 `shouldBe` Just (WidgetId 0 (Seq.fromList [0, 0, 0, 0]))
-    newInstRoot ^? widLens 1 `shouldBe` Just (WidgetId 0 (Seq.fromList [0, 0, 1, 0]))
-
-  where
-    wenv = mockWenv def
-    handleEvent
-      :: WidgetEnv TestModel ()
-      -> WidgetNode TestModel ()
-      -> TestModel
-      -> ()
-      -> [EventResponse TestModel () ()]
-    handleEvent wenv node model evt = []
-    buildUI1 wenv model = hstack [
-        vstack [
-          textField text1 `localKey` "localTxt1"
-        ],
-        vstack [
-          textField text1 `localKey` "localTxt2"
-        ]
-      ]
-    buildUI2 wenv model = hstack [
-        vstack [
-          textField text1 `localKey` "localTxt2"
-        ],
-        vstack [
-          textField text1 `localKey` "localTxt1"
-        ]
-      ]
-    cmpNode1 = composite "main" id buildUI1 handleEvent
-    cmpNode2 = composite_ "main" id buildUI2 handleEvent [mergeRequired (\_ _ -> True)]
-    evts1 = [evtK keyTab, evtT "aacc", moveCharL, moveCharL]
-    (wenv1, root1, _, _) = fst $ nodeHandleEvents wenv WInit evts1 cmpNode1
-    cntNodeM = nodeMerge wenv1 root1 cmpNode2
-    evts2 = [evtK keyTab, evtK keyTab, evtT "bb"]
-    (wenv2, root2, _, _) = fst $ nodeHandleEvents wenv1 WNoInit evts2 cntNodeM
-    newInstRoot = widgetSave (root2 ^. L.widget) wenv1 root2
-
-handleEventGlobalKey :: Spec
-handleEventGlobalKey = describe "handleEventGlobalKey" $ do
-  handleEventGlobalKeySingleState
-  handleEventGlobalKeyRemoveItem
-
-handleEventGlobalKeySingleState :: Spec
-handleEventGlobalKeySingleState = describe "handleEventGlobalKeySingleState" $
-  it "should insert new text at the correct location, since its merged with a global key" $ do
-    wenv1 ^. L.model . text1 `shouldBe` "aacc"
-    wenv1 ^. L.model . text2 `shouldBe` ""
-    wenv2 ^. L.model . text1 `shouldBe` "aabbcc"
-    wenv2 ^. L.model . text2 `shouldBe` ""
-    newInstRoot ^? pathLens 0 `shouldBe` Just (Seq.fromList [0, 0, 0, 0])
-    newInstRoot ^? pathLens 1 `shouldBe` Just (Seq.fromList [0, 0, 1, 0])
    newInstRoot ^? widLens 0 `shouldBe` Just (WidgetId 0 (Seq.fromList [0, 0, 1, 0]))
    newInstRoot ^? widLens 1 `shouldBe` Just (WidgetId 0 (Seq.fromList [0, 0, 0, 0]))

@ -299,34 +253,35 @@ handleEventGlobalKeySingleState = describe "handleEventGlobalKeySingleState" $
    handleEvent wenv node model evt = []
    buildUI1 wenv model = hstack [
        vstack [
-          textField text1 `key` "globalTxt1"
-        ],
+          textField text1
+        ] `key` "localTxt1",
        vstack [
-          textField text2 `key` "globalTxt2"
-        ]
+          textField text1
+        ] `key` "localTxt2"
      ]
    buildUI2 wenv model = hstack [
        vstack [
-          textField text2 `key` "globalTxt2"
-        ],
+          textField text1
+        ] `key` "localTxt2",
        vstack [
-          textField text1 `key` "globalTxt1"
-        ]
+          textField text1
+        ] `key` "localTxt1"
      ]
    cmpNode1 = composite "main" id buildUI1 handleEvent
    cmpNode2 = composite_ "main" id buildUI2 handleEvent [mergeRequired (\_ _ -> True)]
-    evts1 = [evtT "aacc", moveCharL, moveCharL]
+    evts1 = [evtK keyTab, evtT "aacc", moveCharL, moveCharL]
    (wenv1, root1, _, _) = fst $ nodeHandleEvents wenv WInit evts1 cmpNode1
    cntNodeM = nodeMerge wenv1 root1 cmpNode2
    evts2 = [evtK keyTab, evtK keyTab, evtT "bb"]
    (wenv2, root2, _, _) = fst $ nodeHandleEvents wenv1 WNoInit evts2 cntNodeM
    newInstRoot = widgetSave (root2 ^. L.widget) wenv1 root2

-handleEventGlobalKeyRemoveItem :: Spec
-handleEventGlobalKeyRemoveItem = describe "handleEventGlobalKeyRemoveItem" $
+handleEventLocalKeyRemoveItem :: Spec
+handleEventLocalKeyRemoveItem = describe "handleEventLocalKeyRemoveItem" $
  it "should remove an element and keep the correct keys" $ do
    getKeys oldInstRoot `shouldBe` ["key0", "key1", "key2", "key3"]
-    getKeys newInstRoot `shouldBe` ["key0", "key1", "key3"]
+    getKeys newInstRoot `shouldBe` ["key0", "key2", "key3"]
+    length (newCtx ^. L.widgetPaths) `shouldBe` 2

  where
    initModel = def & items .~ [0..3]
@ -338,17 +293,17 @@ handleEventGlobalKeyRemoveItem = describe "handleEventGlobalKeyRemoveItem" $
      -> MainEvt
      -> [EventResponse TestModel MainEvt MainEvt]
    handleEvent wenv node model evt = case evt of
-      MainBtnClicked -> [Model $ model & items .~ [0, 1, 3]]
+      MainBtnClicked -> [Model $ model & items .~ [0, 2, 3]]
      _ -> []
    buildUI wenv model = vstack (button "Button" MainBtnClicked : (keyedLabel <$> model ^. items))
    keyedLabel idx = label "Test" `key` ("key" <> showt idx)
    node = composite "main" id buildUI handleEvent
    evts = [evtClick (Point 100 10)]
    oldNode = nodeInit wenv node
-    newRoot = nodeHandleEventRoot wenv evts node
+    ((_, newRoot, _, _), newCtx) = nodeHandleEvents wenv WInit evts node
    oldInstRoot = widgetSave (oldNode ^. L.widget) wenv oldNode
    newInstRoot = widgetSave (newRoot ^. L.widget) wenv newRoot
-    getKeys inst = inst ^.. L.children . ix 0 . L.children . folded . L.info . L.key . _Just . L._WidgetKeyGlobal
+    getKeys inst = inst ^.. L.children . ix 0 . L.children . folded . L.info . L.key . _Just . L._WidgetKey

 handleMessage :: Spec
 handleMessage = describe "handleMessage" $ do
--- a/test/unit/Monomer/Widgets/ContainerSpec.hs
+++ b/test/unit/Monomer/Widgets/ContainerSpec.hs
@ -123,12 +123,12 @@ handleEventLocalKey = describe "handleEventLocalKey" $
  where
    wenv = mockWenv (TestModel "" "")
    cntNode1 = vstack [
-        textField text1 `localKey` "txt1",
-        textField text2 `localKey` "txt2"
+        textField text1 `key` "txt1",
+        textField text2 `key` "txt2"
      ]
    cntNode2 = vstack [
-        textField text2 `localKey` "txt2",
-        textField text1 `localKey` "txt1"
+        textField text2 `key` "txt2",
+        textField text1 `key` "txt1"
      ]
    evts1 = [evtT "aacc", moveCharL, moveCharL]
    model1 = nodeHandleEventModel wenv evts1 cntNode1