From 406f10bb08cf835440ffe2332bfcbd29b1ee7773 Mon Sep 17 00:00:00 2001 From: Vladislav Date: Sat, 9 Apr 2022 19:21:10 +0400 Subject: [PATCH] simpleList using Dynamic instead of DynRef --- examples/todomvc/TodoItem.hs | 39 +++++++++++++++--------------- examples/todomvc/TodoList.hs | 45 +++++++++++++++++----------------- examples/todomvc/Utils.hs | 6 +++++ examples/todomvc/todomvc.hs | 2 +- src/HtmlT/Base.hs | 47 ++++++++++++++---------------------- src/HtmlT/Internal.hs | 5 ++-- 6 files changed, 68 insertions(+), 76 deletions(-) diff --git a/examples/todomvc/TodoItem.hs b/examples/todomvc/TodoItem.hs index 5900f85..06244cc 100644 --- a/examples/todomvc/TodoItem.hs +++ b/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 diff --git a/examples/todomvc/TodoList.hs b/examples/todomvc/TodoList.hs index 6d3927d..d5b6e01 100644 --- a/examples/todomvc/TodoList.hs +++ b/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 diff --git a/examples/todomvc/Utils.hs b/examples/todomvc/Utils.hs index 622da21..08930b0 100644 --- a/examples/todomvc/Utils.hs +++ b/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 diff --git a/examples/todomvc/todomvc.hs b/examples/todomvc/todomvc.hs index 8de3b71..c6a463e 100644 --- a/examples/todomvc/todomvc.hs +++ b/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 diff --git a/src/HtmlT/Base.hs b/src/HtmlT/Base.hs index 197bb96..c7dc37b 100644 --- a/src/HtmlT/Base.hs +++ b/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 diff --git a/src/HtmlT/Internal.hs b/src/HtmlT/Internal.hs index a260f7b..e9b659d 100644 --- a/src/HtmlT/Internal.hs +++ b/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