diff --git a/examples/todo/Main.hs b/examples/todo/Main.hs index 7e5b1998..b2fc75cc 100644 --- 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 diff --git a/src/Monomer/Core/StyleUtil.hs b/src/Monomer/Core/StyleUtil.hs index ccccf39e..eb42e1d1 100644 --- 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 diff --git a/src/Monomer/Core/Util.hs b/src/Monomer/Core/Util.hs index 5025372a..bfe2548f 100644 --- 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 diff --git a/src/Monomer/Core/WidgetTypes.hs b/src/Monomer/Core/WidgetTypes.hs index 9d315212..e7baf56b 100644 --- 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, diff --git a/src/Monomer/Main/Util.hs b/src/Monomer/Main/Util.hs index 9ff720a6..69a7f2ec 100644 --- 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 diff --git a/src/Monomer/Widgets/Composite.hs b/src/Monomer/Widgets/Composite.hs index b3fde80e..3dce7ee1 100644 --- 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, diff --git a/src/Monomer/Widgets/Container.hs b/src/Monomer/Widgets/Container.hs index 9b42ca34..20a4bbf5 100644 --- 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 diff --git a/tasks.md b/tasks.md index 35ebd21b..c0d3b235 100644 --- 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? diff --git a/test/unit/Monomer/Widgets/CompositeSpec.hs b/test/unit/Monomer/Widgets/CompositeSpec.hs index 173c3ba0..e201dff4 100644 --- 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 diff --git a/test/unit/Monomer/Widgets/ContainerSpec.hs b/test/unit/Monomer/Widgets/ContainerSpec.hs index 1b563b10..36db1469 100644 --- 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