Implement global keys and improve merge process

app/KeysComposite.hs

@@ -0,0 +1,72 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module KeysComposite (keysComposite) where
+
+import Debug.Trace
+
+import Control.Concurrent (threadDelay)
+import Control.Monad (forM_)
+
+import Data.Default
+import Data.Sequence (Seq(..), (|>))
+import Data.Text (Text)
+import Data.Typeable (Typeable)
+--import Lens.Micro
+import Lens.Micro.GHC
+import Lens.Micro.TH (makeLenses)
+import TextShow
+
+import qualified Data.Sequence as Seq
+
+import Monomer.Common.Style
+import Monomer.Graphics.Color
+import Monomer.Main.Util
+import Monomer.Widget.CompositeWidget
+import Monomer.Widget.Types
+import Monomer.Widget.Util
+import Monomer.Widgets
+
+data EditableItem = EditableItem {
+  _eiId :: Text,
+  _eiText :: Text
+} deriving (Show, Eq)
+
+data KeysCompState = KeysCompState {
+  _kcsItems :: Seq EditableItem
+} deriving (Show, Eq)
+
+makeLenses ''EditableItem
+makeLenses ''KeysCompState
+
+data KeysCompEvent = RotateChildren
+               deriving (Eq, Show)
+
+initialState = KeysCompState {
+  _kcsItems = Seq.fromList [
+    EditableItem "1" "Text 1",
+    EditableItem "2" "Text 2",
+    EditableItem "3" "Text 3",
+    EditableItem "4" "Text 4",
+    EditableItem "5" "Text 5"
+  ]
+}
+
+keysComposite = composite "keysComposite" initialState Nothing handleKeysCompEvent buildKeysComp
+
+handleKeysCompEvent :: KeysCompState -> KeysCompEvent -> EventResponseC KeysCompState KeysCompEvent ep
+handleKeysCompEvent app evt = case evt of
+  RotateChildren -> StateC (app & kcsItems %~ rotateSeq)
+
+buildKeysComp app = trace "Created keys composite UI" $
+  hgrid [
+    button "Add new" RotateChildren,
+    vgrid $ fmap (editableItem app) [0..(length (_kcsItems app) - 1)]
+  ]
+
+editableItem app idx = hgrid [
+    label "Enter text!",
+    textField (singular $ kcsItems . ix idx . eiText)
+  ] `key` (app ^. (singular $ kcsItems . ix idx . eiId))
+
+rotateSeq Empty = Empty
+rotateSeq (x :<| xs) = xs |> x

app/Main.hs

@@ -37,6 +37,7 @@ import Monomer.Main.Util
 import Monomer.Widget.Util
 import Monomer.Widgets
 
+import KeysComposite
 import TestComposite
 import Types
 
@@ -131,7 +132,8 @@ buildUI app = trace "Created main UI" $ widgetTree where
         button ("Increase: " <> (showt $ _clickCount app)) AppButton,
         label $ "Messages: " <> (showt $ _msgCount app)
       ],
-      testComposite
+      --testComposite
+      keysComposite
     ]
 
 buildUI2 app = widgetTree where

app/TestComposite.hs

@@ -33,7 +33,7 @@ instance Default CompState where
 
 makeLenses ''CompState
 
-data CompEvent = Initialize
+data CompEvent = InitComposite
                | MessageParent
                | CallSandbox
                | RunTask
@@ -42,11 +42,11 @@ data CompEvent = Initialize
                deriving (Eq, Show)
 
 --testComposite :: WidgetInstance sp AppEvent
-testComposite = composite "testComposite" def (Just Initialize) handleCompositeEvent buildComposite
+testComposite = composite "testComposite" def (Just InitComposite) handleCompositeEvent buildComposite
 
 --handleCompositeEvent :: CompState -> CompEvent -> EventResponseC CompState CompEvent AppEvent
 handleCompositeEvent app evt = case evt of
-  Initialize -> TaskC $ do
+  InitComposite -> TaskC $ do
     threadDelay $ 1000
     putStrLn $ "Initialized composite"
     return Nothing

package.yaml

@@ -67,6 +67,7 @@ executables:
 
     dependencies:
     - ekg
+    - microlens-ghc
     - monomer
 
 tests:

src/Monomer/Widget/BaseContainer.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
@@ -15,8 +16,9 @@ import Data.Default
 import Data.Foldable (fold)
 import Data.Maybe
 import Data.Typeable (Typeable)
-import Data.Sequence (Seq, (<|), (><))
+import Data.Sequence (Seq(..), (<|), (><))
 
+import qualified Data.Map.Strict as M
 import qualified Data.Sequence as Seq
 
 import Monomer.Common.Geometry
@@ -76,29 +78,34 @@ ignoreOldInstance app state newInstance = newInstance
 
 {-- This implementation is far from complete --}
 containerMergeTrees :: WidgetMergeHandler s e -> GlobalKeys s e -> PathContext -> s -> WidgetInstance s e -> WidgetInstance s e -> EventResult s e
-containerMergeTrees mergeWidgetState globalKeys ctx app candidateInstance oldInstance = EventResult newReqs newEvents newInstance where
-  matches = instanceMatches candidateInstance oldInstance
+containerMergeTrees mergeWidgetState globalKeys ctx app newInstance oldInstance = EventResult mergedReqs mergedEvents mergedInstance where
   oldState = _widgetGetState (_instanceWidget oldInstance) app
-  mergedInstance = (mergeWidgetState app oldState candidateInstance) {
-    _instanceChildren = newChildren
-  }
-  newInstance = if matches then mergedInstance else candidateInstance
-  {-- This should also handle changes in position and global keys --}
-  candidateChildren = _instanceChildren candidateInstance
   oldChildren = _instanceChildren oldInstance
-  newChildren = mergedChildren Seq.>< addedChildren
-  indexes = Seq.fromList [0..length candidateChildren]
-  mergedEventResults = fmap mergeChild (Seq.zip3 indexes candidateChildren oldChildren)
-  mergedChildren = fmap _eventResultNewWidget mergedEventResults
-  newReqs = concatSeq $ fmap _eventResultRequest mergedEventResults
-  newEvents = concatSeq $ fmap _eventResultUserEvents mergedEventResults
-  addedChildren = Seq.drop (Seq.length oldChildren) candidateChildren
-  mergeChild = \(idx, newChild, oldChild) -> _widgetMerge (_instanceWidget newChild) globalKeys (addToCurrent ctx idx) app newChild oldChild
+  newChildren = _instanceChildren newInstance
+  indexes = Seq.fromList [0..length newChildren]
+  newPairs = Seq.zipWith (\idx child -> (addToCurrent ctx idx, child)) indexes newChildren
+  mergedResults = mergeChildren globalKeys app newPairs oldChildren
+  mergedChildren = fmap _eventResultNewWidget mergedResults
+  mergedReqs = concatSeq $ fmap _eventResultRequest mergedResults
+  mergedEvents = concatSeq $ fmap _eventResultUserEvents mergedResults
+  mergedInstance = (mergeWidgetState app oldState newInstance) {
+    _instanceChildren = mergedChildren
+  }
 
-instanceMatches :: WidgetInstance s e -> WidgetInstance s e -> Bool
-instanceMatches newInstance oldInstance = typeMatches && keyMatches where
-  typeMatches = _instanceType oldInstance == _instanceType newInstance
-  keyMatches = _instanceKey oldInstance == _instanceKey newInstance
+mergeChildren :: GlobalKeys s e -> s -> Seq (PathContext, WidgetInstance s e) -> Seq (WidgetInstance s e) -> Seq (EventResult s e)
+mergeChildren _ _ Empty _ = Empty
+mergeChildren keys app ((ctx, newChild) :<| newChildren) Empty = child <| mergeChildren keys app newChildren Empty where
+  child = _widgetInit (_instanceWidget newChild) ctx app newChild
+mergeChildren keys app ((ctx, newChild) :<| newChildren) oldFull@(oldChild :<| oldChildren) = result where
+  newWidget = _instanceWidget newChild
+  oldKeyed = maybe Nothing (\key -> M.lookup key keys) (_instanceKey newChild)
+  mergedOld = _widgetMerge newWidget keys ctx app newChild oldChild
+  mergedKey = _widgetMerge newWidget keys ctx app newChild (snd $ fromJust oldKeyed)
+  initNew = _widgetInit newWidget ctx app newChild
+  (child, oldRest) = if | instanceMatches newChild oldChild -> (mergedOld, oldChildren)
+                        | isJust oldKeyed -> (mergedKey, oldFull)
+                        | otherwise -> (initNew, oldFull)
+  result = child <| mergeChildren keys app newChildren oldRest
 
 -- | Find next focusable item
 containerNextFocusable :: PathContext -> WidgetInstance s e -> Maybe Path

src/Monomer/Widget/BaseWidget.hs

@@ -33,7 +33,7 @@ createWidget = Widget {
 }
 
 widgetInit :: PathContext -> s -> WidgetInstance s e -> EventResult s e
-widgetInit _ _ widgetComposite = rWidget widgetComposite
+widgetInit _ _ widgetInstance = rWidget widgetInstance
 
 ignoreGetState :: s -> Maybe WidgetState
 ignoreGetState _ = Nothing

src/Monomer/Widget/CompositeWidget.hs

@@ -97,7 +97,10 @@ compositeInit comp state ctx pApp widgetComposite = result where
   CompositeState app widgetRoot initEvent _ _ = state
   EventResult reqs evts root = _widgetInit (_instanceWidget widgetRoot) (childContext ctx) app widgetRoot
   newEvts = maybe evts (evts |>) initEvent
-  result = processEventResult comp state ctx widgetComposite (EventResult reqs newEvts root)
+  newState = state {
+    _compositeGlobalKeys = collectGlobalKeys M.empty (childContext ctx) widgetRoot
+  }
+  result = processEventResult comp newState ctx widgetComposite (EventResult reqs newEvts root)
 
 compositeMerge :: (Eq s, Typeable s, Typeable e) => Composite s e ep -> CompositeState s e -> GlobalKeys sp ep -> PathContext -> sp -> WidgetInstance sp ep -> WidgetInstance sp ep -> EventResult sp ep
 compositeMerge comp state _ ctx pApp newComposite oldComposite = result where
@@ -107,9 +110,12 @@ compositeMerge comp state _ ctx pApp newComposite oldComposite = result where
   -- Duplicate widget tree creation is avoided because the widgetRoot created on _composite_ has not yet been evaluated
   newRoot = _uiBuilderC comp oldApp
   newState = validState {
-    _compositeRoot = newRoot
+    _compositeRoot = newRoot,
+    _compositeGlobalKeys = collectGlobalKeys M.empty (childContext ctx) newRoot
   }
-  eventResult = _widgetMerge (_instanceWidget newRoot) oldGlobalKeys (childContext ctx) oldApp newRoot oldRoot
+  eventResult = if instanceMatches newRoot oldRoot
+                  then _widgetMerge (_instanceWidget newRoot) oldGlobalKeys (childContext ctx) oldApp newRoot oldRoot
+                  else _widgetInit (_instanceWidget newRoot) (childContext ctx) oldApp newRoot
   result = processEventResult comp newState ctx newComposite eventResult
 
 compositeNextFocusable :: CompositeState s e -> PathContext -> WidgetInstance sp ep -> Maybe Path
@@ -226,13 +232,13 @@ compositeRender CompositeState{..} renderer ts ctx _ _ = _widgetRender (_instanc
 
 childContext :: PathContext -> PathContext
 childContext ctx = addToCurrent ctx 0
-
-collectGlobalKeys :: Map WidgetKeyValue (Path, WidgetInstance s e) -> PathContext -> WidgetInstance s e -> Map WidgetKeyValue (Path, WidgetInstance s e)
+--
+collectGlobalKeys :: Map WidgetKey (Path, WidgetInstance s e) -> PathContext -> WidgetInstance s e -> Map WidgetKey (Path, WidgetInstance s e)
 collectGlobalKeys keys ctx widgetInstance = foldl' collectFn updatedMap pairs where
   children = _instanceChildren widgetInstance
   ctxs = Seq.fromList $ fmap (addToCurrent ctx) [0..length children]
   pairs = Seq.zip ctxs children
   collectFn current (ctx, child) = collectGlobalKeys current ctx child
   updatedMap = case _instanceKey widgetInstance of
-    Just (GKey key) -> M.insert key (rootPath, widgetInstance) keys
+    Just key -> M.insert key (rootPath, widgetInstance) keys
     _ -> keys

src/Monomer/Widget/Types.hs

@@ -6,6 +6,7 @@ module Monomer.Widget.Types where
 import Data.Default
 import Data.Map.Strict (Map)
 import Data.Sequence (Seq)
+import Data.Text (Text)
 import Data.Typeable (cast, Typeable)
 
 import Monomer.Common.Geometry
@@ -18,12 +19,9 @@ import Monomer.Widget.PathContext
 type Timestamp = Int
 type WidgetType = String
 type WidgetChildren s e = Seq (WidgetInstance s e)
-type WidgetKeyValue = String
-type GlobalKeys s e = Map WidgetKeyValue (Path, WidgetInstance s e)
+type GlobalKeys s e = Map WidgetKey (Path, WidgetInstance s e)
 
-data WidgetKey = LKey WidgetKeyValue
-               | GKey WidgetKeyValue
-               deriving (Show, Eq)
+data WidgetKey = WidgetKey Text deriving (Show, Eq, Ord)
 
 data WidgetState = forall i . Typeable i => WidgetState i
 

src/Monomer/Widget/Util.hs

@@ -6,6 +6,7 @@ import Data.Default
 import Data.Maybe
 import Data.List (foldl')
 import Data.Sequence (Seq, (><))
+import Data.Text (Text)
 import Data.Typeable (cast, Typeable)
 
 import qualified Data.Sequence as Seq
@@ -31,8 +32,8 @@ defaultWidgetInstance widgetType widget = WidgetInstance {
   _instanceStyle = def
 }
 
-key :: WidgetKey -> WidgetInstance s e -> WidgetInstance s e
-key key wn = wn { _instanceKey = Just key }
+key :: WidgetInstance s e -> Text -> WidgetInstance s e
+key wn key = wn { _instanceKey = Just (WidgetKey key) }
 
 style :: WidgetInstance s e -> Style -> WidgetInstance s e
 style widgetInstance newStyle = widgetInstance { _instanceStyle = newStyle }
@@ -68,8 +69,10 @@ useState ::  Typeable i => Maybe WidgetState -> Maybe i
 useState Nothing = Nothing
 useState (Just (WidgetState state)) = cast state
 
-defaultRestoreState :: (Typeable i) => (i -> Widget s e) -> s -> Maybe WidgetState -> Maybe (Widget s e)
-defaultRestoreState makeState _ oldState = fmap makeState $ useState oldState
+instanceMatches :: WidgetInstance s e -> WidgetInstance s e -> Bool
+instanceMatches newInstance oldInstance = typeMatches && keyMatches where
+  typeMatches = _instanceType oldInstance == _instanceType newInstance
+  keyMatches = _instanceKey oldInstance == _instanceKey newInstance
 
 updateSizeReq :: SizeReq -> WidgetInstance s e -> SizeReq
 updateSizeReq sizeReq widgetInstance = newSizeReq where

src/Monomer/Widget/Widgets/TextField.hs

@@ -43,6 +43,7 @@ makeInstance widget = (defaultWidgetInstance "textField" widget) {
 
 makeTextField :: Lens' s T.Text -> TextFieldState -> Widget s e
 makeTextField userField tfs@(TextFieldState currText currPos) = createWidget {
+    _widgetInit = initTextField,
     _widgetGetState = getState,
     _widgetMerge = widgetMerge merge,
 
@@ -51,6 +52,9 @@ makeTextField userField tfs@(TextFieldState currText currPos) = createWidget {
     _widgetRender = render
   }
   where
+    initTextField ctx app widgetInstance = rWidget newInstance where
+      newState = TextFieldState (app ^. userField) 0
+      newInstance = widgetInstance { _instanceWidget = makeTextField userField newState }
     getState = makeState tfs
     merge app oldState = makeTextField userField newState where
       TextFieldState txt pos = fromMaybe emptyState (useState oldState)

tasks.md

@@ -57,16 +57,18 @@
     - Some Typeable constraints still needed, but user should not need to do anything
   - Provide a way of initializing the application
     - Probably taking a simple event that is relayed to appEventsHandler is enough?
-
-- Pending
   - Implement Global keys
   - Improve merge process
+
+- Pending
   - Add a way to get path of widget given an id, and provide a method to send a message/event (most likely, a new Request kind)
   - Should Resize be restored?
   - Can we generalize _widgetFind?
     - To find widgetInstances that need a specific kind of event (entities that need timeStep)
     - Instead of passing Point, pass WidgetQuery ADT. Currently it would support... PointQuery
     - Do we need this?
+  - Rename EventResult to something more accurate
+    - Replace resultWidget and friends with non-Maybe versions (update widgets)
   - Add _renderLast_ function to Renderer, which delays rendering until the first pass is done
     - Futher calls to _renderLast_ should not be ignored (tooltip on dropdown menu?)
     - A _handleDelayedRendering_ also needs to be added