simpleList using Dynamic instead of DynRef

examples/todomvc/TodoItem.hs

@@ -12,10 +12,9 @@ import HtmlT
 import "this" Utils
 
 
-data TodoItemConfig s = TodoItemConfig
-  { tic_ref :: DynRef s
-  , tic_state :: Lens' s TodoItemState
-  , tic_is_hidden :: s -> Bool
+data TodoItemConfig = TodoItemConfig
+  { tic_state_ref :: DynRef TodoItemState
+  , tic_is_hidden :: Dynamic Bool
   , tic_delete_item :: Transact ()
   }
 
@@ -26,46 +25,46 @@ data TodoItemState = TodoItemState
   } deriving stock (Show, Eq, Generic)
     deriving anyclass (ToJSVal, FromJSVal)
 
-todoItemWidget :: TodoItemConfig s -> Html ()
+todoItemWidget :: TodoItemConfig -> Html ()
 todoItemWidget TodoItemConfig{..} = li_ do
   toggleClass "completed" completedDyn
   toggleClass "editing" editingDyn
   toggleClass "hidden" hiddenDyn
   div_ [class_ "view"] do
     onDecoder "dblclick" targetDecoder \targetEl -> do
-      title <- readsRef (view (tic_state . #tis_title)) tic_ref
-      modifyRef tic_ref $ tic_state . #tis_editing .~ Just title
+      title <- readsRef (view #tis_title) tic_state_ref
+      modifySync tic_state_ref $ #tis_editing .~ Just title
       liftIO $ js_todoItemInputFocus targetEl
     input_ [class_ "toggle", type_ "checkbox"] do
-      dynChecked $ view (tic_state . #tis_completed) <$> fromRef tic_ref
+      dynChecked $ view #tis_completed <$> fromRef tic_state_ref
       onDecoder "change" checkedDecoder \isChecked -> do
-        modifyRef tic_ref $ tic_state . #tis_completed .~ isChecked
-    label_ $ dynText $ view (tic_state . #tis_title) <$> fromRef tic_ref
+        modifyRef tic_state_ref $ #tis_completed .~ isChecked
+    label_ $ dynText $ view #tis_title <$> fromRef tic_state_ref
     button_ [class_ "destroy"] do
       on_ "click" $ tic_delete_item
   input_ [class_ "edit", type_ "text"] do
     dynValue valueDyn
     onDecoder "input" valueDecoder \value -> do
-      modifyRef tic_ref $ tic_state . #tis_editing .~ Just value
+      modifyRef tic_state_ref $ #tis_editing .~ Just value
     on_ "blur" commitEditing
     onDecoder "keydown" keyCodeDecoder \case
       13 -> commitEditing -- Enter
       27 -> cancelEditing -- Escape
       _  -> return ()
   where
-    completedDyn = view (tic_state . #tis_completed) <$> fromRef tic_ref
-    editingDyn = view (tic_state . #tis_editing . to isJust) <$> fromRef tic_ref
-    hiddenDyn = tic_is_hidden <$> fromRef tic_ref
-    valueDyn = view (tic_state . #tis_editing . to (fromMaybe "")) <$> fromRef tic_ref
+    completedDyn = view #tis_completed <$> fromRef tic_state_ref
+    editingDyn = view (#tis_editing . to isJust) <$> fromRef tic_state_ref
+    hiddenDyn = tic_is_hidden
+    valueDyn = view (#tis_editing . to (fromMaybe "")) <$> fromRef tic_state_ref
     commitEditing = readEditing >>= \case
       Just "" -> tic_delete_item
-      Just t -> modifySync tic_ref
-        $ (tic_state . #tis_editing .~ Nothing)
-        . (tic_state . #tis_title .~ t)
+      Just t -> modifySync tic_state_ref
+        $ (#tis_editing .~ Nothing)
+        . (#tis_title .~ t)
       Nothing -> pure ()
       where
-        readEditing = readsRef (view (tic_state . #tis_editing)) tic_ref
-    cancelEditing = modifySync tic_ref $ tic_state . #tis_editing .~ Nothing
+        readEditing = readsRef (view #tis_editing) tic_state_ref
+    cancelEditing = modifySync tic_state_ref $ #tis_editing .~ Nothing
 
 defaultItemState :: TodoItemState
 defaultItemState = TodoItemState T.empty False Nothing

examples/todomvc/TodoList.hs

@@ -12,9 +12,8 @@ import HtmlT
 import "this" TodoItem
 import "this" Utils
 
-data TodoListConfig s = TodoListConfig
-  { tlc_ref :: DynRef s
-  , tlc_state :: Lens' s TodoListState
+data TodoListConfig = TodoListConfig
+  { tlc_state_ref :: DynRef TodoListState
   }
 
 data TodoListState = TodoListState
@@ -37,7 +36,7 @@ initTodos urlHashRef = do
     modifyRef todosRef (#tls_filter .~ fromMaybe All (firstOf url2Filter urlHash))
   return todosRef
 
-todoListWidget :: TodoListConfig s -> Html ()
+todoListWidget :: TodoListConfig -> Html ()
 todoListWidget TodoListConfig{..} = do
   el "style" $ text styles
   div_ do
@@ -50,9 +49,9 @@ todoListWidget TodoListConfig{..} = do
     headerWidget = header_ [class_ "header"] do
       h1_ (text "todos")
       input_ [class_ "new-todo", placeholder_ "What needs to be done?", autofocus_ True] do
-        dynValue $ view (tlc_state . #tls_title) <$> fromRef tlc_ref
+        dynValue $ view #tls_title <$> fromRef tlc_state_ref
         onDecoder "input" valueDecoder \value ->
-          modifyRef tlc_ref (tlc_state . #tls_title .~ value)
+          modifyRef tlc_state_ref (#tls_title .~ value)
         onDecoder "keydown" keyCodeDecoder \case
           13 -> commitEditing
           _ -> return ()
@@ -64,11 +63,10 @@ todoListWidget TodoListConfig{..} = do
         attr "for" "toggle-all"
         text "Mark all as completed"
       ul_ [class_ "todo-list"] do
-        simpleList itemsRef \idx todoRef ->
+        simpleList itemsDyn \idx todoDyn ->
           todoItemWidget $ TodoItemConfig
-            { tic_ref = tlc_ref `zipRef` todoRef
-            , tic_state = _2
-            , tic_is_hidden = isTodoItemHidden
+            { tic_state_ref = DynRef todoDyn (updateItem idx)
+            , tic_is_hidden = isTodoItemHidden <$> fromRef tlc_state_ref <*> todoDyn
             , tic_delete_item = deleteTodoItem idx }
     footerWidget = footer_ [class_ "footer"] do
       toggleClass "hidden" hiddenDyn
@@ -94,23 +92,24 @@ todoListWidget TodoListConfig{..} = do
         text $ T.pack (show flt)
     commitEditing = readTitle >>= \case
       "" -> return ()
-      title -> modifyRef tlc_ref
-        $ (tlc_state . #tls_items %~ (<> [mkNewItem title]))
-        . (tlc_state . #tls_title .~ "")
+      title -> modifyRef tlc_state_ref
+        $ (#tls_items %~ (<> [mkNewItem title]))
+        . (#tls_title .~ "")
       where
-        readTitle = readsRef (view (tlc_state . #tls_title . to T.strip)) tlc_ref
+        readTitle = readsRef (view (#tls_title . to T.strip)) tlc_state_ref
         mkNewItem title = defaultItemState {tis_title = title}
-    hiddenDyn = view (tlc_state . #tls_items . to Prelude.null) <$> fromRef tlc_ref
-    itemsLeftDyn = view (tlc_state . to countItemsLeft) <$> fromRef tlc_ref
-    toggleAll check = modifyRef tlc_ref (tlc_state . #tls_items %~ fmap (#tis_completed .~ check))
-    filterSelectedDyn flt = view (tlc_state . #tls_filter . to (==flt)) <$> fromRef tlc_ref
-    itemsRef = lensMap (tlc_state . #tls_items) tlc_ref
-    clearCompleted = modifyRef tlc_ref (tlc_state . #tls_items %~ Prelude.filter (not . tis_completed))
+    hiddenDyn = view (#tls_items . to Prelude.null) <$> fromRef tlc_state_ref
+    itemsLeftDyn = countItemsLeft <$> fromRef tlc_state_ref
+    toggleAll check = modifyRef tlc_state_ref (#tls_items %~ fmap (#tis_completed .~ check))
+    filterSelectedDyn flt = view (#tls_filter . to (==flt)) <$> fromRef tlc_state_ref
+    itemsDyn = view #tls_items <$> fromRef tlc_state_ref
+    clearCompleted = modifyRef tlc_state_ref (#tls_items %~ Prelude.filter (not . tis_completed))
     countItemsLeft TodoListState{..} = foldl (\acc TodoItemState{..} ->
       if not tis_completed then acc + 1 else acc) 0 tls_items
-    deleteTodoItem idx = modifySync tlc_ref (tlc_state . #tls_items %~ deleteAt idx)
-    isTodoItemHidden (s, TodoItemState{..}) =
-      case (s ^. tlc_state . #tls_filter, tis_completed) of
+    deleteTodoItem idx = modifySync tlc_state_ref (#tls_items %~ deleteAt idx)
+    updateItem idx f = modifySync tlc_state_ref (#tls_items . ix idx %~ f)
+    isTodoItemHidden TodoListState{..} TodoItemState{..} =
+      case (tls_filter, tis_completed) of
         (Active,    True)  -> True
         (Completed, False) -> True
         _                  -> False

examples/todomvc/Utils.hs

@@ -44,6 +44,7 @@ localStorageGet = liftIO do
   where
     key = JSS.pack $ show $ typeRepFingerprint $ typeRep (Proxy @a)
 
+#ifdef ghcjs_HOST_OS
 foreign import javascript unsafe
   "setTimeout(function() {\
     var inputEl = $1.parentNode.parentNode.querySelector('input.edit');\
@@ -63,3 +64,8 @@ foreign import javascript unsafe
     return itemText ? JSON.parse(itemText) : null;\
   })($1)"
   js_getItem :: JSString -> IO (Nullable JSVal)
+#else
+js_todoItemInputFocus :: JSVal -> IO () = errorGhcjsOnly
+js_setItem :: JSString -> JSVal -> IO () = errorGhcjsOnly
+js_getItem :: JSString -> IO (Nullable JSVal) = errorGhcjsOnly
+#endif

examples/todomvc/todomvc.hs

@@ -8,4 +8,4 @@ main :: IO ()
 main = void $ attachToBody do
   urlHashRef <- mkUrlHashRef
   todosRef <- initTodos urlHashRef
-  todoListWidget $ TodoListConfig todosRef id
+  todoListWidget $ TodoListConfig todosRef

src/HtmlT/Base.hs

@@ -237,66 +237,55 @@ blank = pure ()
 -- >   on_ "click" $ modifyRef listRef ("New Item":)
 -- >   text "Append new item"
 simpleList
-  :: forall a. DynRef [a]
+  :: forall a. Dynamic [a]
   -- ^ Some dynamic data from the above scope
-  -> (Int -> DynRef a -> Html ())
+  -> (Int -> Dynamic a -> Html ())
   -- ^ Function to build children widget. Accepts the index inside the
   -- collection and dynamic data for that particular element
   -> Html ()
-simpleList dynRef h = do
+simpleList listDyn h = do
   htmlEnv <- ask
   prevValue <- liftIO $ newIORef []
   elemEnvsRef <- liftIO $ newIORef ([] :: [ElemEnv a])
   let
     reactiveEnv = html_reactive_env htmlEnv
-    setup :: Int -> [a] -> [a] -> [ElemEnv a] -> IO [ElemEnv a]
+    setup :: Int -> [a] -> [a] -> [ElemEnv a] -> Transact [ElemEnv a]
     setup idx old new refs = case (refs, old, new) of
       (_, [], []) -> return []
       ([], [], x:xs) -> do
         -- New list is longer, append new elements
-        finalizers <- newIORef []
-        elemRef <- execReactiveT reactiveEnv $ newRef x
+        finalizers <- liftIO $ newIORef []
+        elementRef <- liftIO $ execReactiveT reactiveEnv $ newRef x
+        boundary <- liftIO $ execHtmlT htmlEnv insertBoundary
         let
-          controlledRef = elemRef
-            {dynref_modifier=elemModifier idx (fromRef elemRef)
-            }
-          newEnv = htmlEnv
+          elementEnv = htmlEnv
             { html_reactive_env = reactiveEnv {renv_finalizers = finalizers}
+            , html_content_boundary = Just boundary
             }
-        boundary <- execHtmlT newEnv insertBoundary
-        execHtmlT newEnv {html_content_boundary = Just boundary} $
-          h idx controlledRef
-        let itemRef = ElemEnv newEnv (dynref_modifier elemRef) boundary
+        liftIO $ execHtmlT elementEnv $ h idx (fromRef elementRef)
+        let itemRef = ElemEnv elementEnv elementRef
         (itemRef:) <$> setup (idx + 1) [] xs []
       (r:rs, _:_, []) -> do
         -- New list is shorter, delete the elements that no longer
         -- present in the new list
-        finalizeElems (r:rs)
+        liftIO $ finalizeElems (r:rs)
         return []
       (r:rs, _:xs, y:ys) -> do
         -- Update child elements along the way
-        liftIO $ sync $ ee_modifier r \_ -> y
+        writeSync (ee_dyn_ref r) y
         (r:) <$> setup (idx + 1) xs ys rs
       (_, _, _) -> do
         error "simpleList: Incoherent internal state"
     finalizeElems = traverse_ \ElemEnv{..} -> liftIO do
-      removeBoundary ee_boundary
+      mapM_ removeBoundary $ html_content_boundary ee_html_env
       let fins = renv_finalizers $ html_reactive_env ee_html_env
       readIORef fins >>= sequence_
-    elemModifier :: Int -> Dynamic a -> (a -> a) -> Transact ()
-    elemModifier i dyn f = do
-      oldA <- readDyn dyn
-      let
-        overIx 0 (_:xs) = f oldA : xs
-        overIx n (x:xs) = x : overIx (n - 1) xs
-        overIx _ [] = []
-      dynref_modifier dynRef (overIx i)
   addFinalizer $ readIORef elemEnvsRef >>= finalizeElems
-  forDyn_ (fromRef dynRef) \new -> liftIO do
-    old <- atomicModifyIORef' prevValue (new,)
-    eenvs <- readIORef elemEnvsRef
+  forDyn_ listDyn \new -> do
+    old <- liftIO $ atomicModifyIORef' prevValue (new,)
+    eenvs <- liftIO $ readIORef elemEnvsRef
     newEenvs <- setup 0 old new eenvs
-    writeIORef elemEnvsRef newEenvs
+    liftIO $ writeIORef elemEnvsRef newEenvs
 
 -- | First build a DOM with the widget that is currently held by the
 -- given Dynamic, then rebuild it every time Dynamic's value

src/HtmlT/Internal.hs

@@ -7,11 +7,10 @@ import HtmlT.Event
 import HtmlT.Types
 import HtmlT.DOM
 
--- | Auxiliary type to help implement 'simpleList'
+-- | Auxiliary type helps to implement 'simpleList'
 data ElemEnv a = ElemEnv
   { ee_html_env :: HtmlEnv
-  , ee_modifier :: Modifier a
-  , ee_boundary :: ContentBoundary
+  , ee_dyn_ref :: DynRef a
   } deriving Generic
 
 -- | Insert given node to @html_current_element@ and run action with