mirror of
https://github.com/lagunoff/htmlt.git
synced 2024-10-04 02:47:08 +03:00
Refactor TodoMVC example
This commit is contained in:
Vladislav
parent
3963c1ffd4
commit
bab6b1af5a
@ -8,11 +8,10 @@ import HtmlT
|
||||
|
||||
import "this" Utils
|
||||
|
||||
|
||||
data TodoItemConfig = TodoItemConfig
|
||||
{ tic_state_ref :: DynRef TodoItemState
|
||||
, tic_is_hidden :: Dynamic Bool
|
||||
, tic_delete_item :: Step ()
|
||||
{ state_ref :: DynRef TodoItemState
|
||||
, is_hidden :: Dynamic Bool
|
||||
, ask_delete_item :: Step ()
|
||||
}
|
||||
|
||||
data TodoItemState = TodoItemState
|
||||
@ -21,54 +20,72 @@ data TodoItemState = TodoItemState
|
||||
, tis_editing :: Maybe JSString
|
||||
} deriving stock (Show, Eq, Generic)
|
||||
|
||||
todoItemWidget :: TodoItemConfig -> Html ()
|
||||
todoItemWidget TodoItemConfig{..} = li_ do
|
||||
data TodoItemAction a where
|
||||
CancelAction :: TodoItemConfig -> TodoItemAction ()
|
||||
CommitAction :: TodoItemConfig -> TodoItemAction ()
|
||||
InputAction :: TodoItemConfig -> JSString -> TodoItemAction ()
|
||||
DoubleClickAction :: TodoItemConfig -> JSVal -> TodoItemAction ()
|
||||
CheckedAction :: TodoItemConfig -> Bool -> TodoItemAction ()
|
||||
KeydownAction :: TodoItemConfig -> Int -> TodoItemAction ()
|
||||
|
||||
eval :: TodoItemAction a -> Step a
|
||||
eval = \case
|
||||
CancelAction cfg ->
|
||||
modifyRef cfg.state_ref \s -> s{tis_editing=Nothing}
|
||||
CommitAction cfg -> do
|
||||
isEditing <- (.tis_editing) <$> readRef cfg.state_ref
|
||||
case isEditing of
|
||||
Just "" ->
|
||||
cfg.ask_delete_item
|
||||
Just t ->
|
||||
modifyRef cfg.state_ref \s -> s {tis_editing=Nothing, tis_title = t}
|
||||
Nothing ->
|
||||
pure ()
|
||||
InputAction cfg newVal ->
|
||||
modifyRef cfg.state_ref \s -> s{tis_editing = Just newVal}
|
||||
DoubleClickAction cfg targetEl -> do
|
||||
modifyRef cfg.state_ref \s -> s {tis_editing = Just s.tis_title}
|
||||
liftIO $ js_todoItemInputFocus targetEl
|
||||
CheckedAction cfg isChecked -> do
|
||||
modifyRef cfg.state_ref \s -> s{tis_completed = isChecked}
|
||||
KeydownAction cfg key -> case key of
|
||||
13 {- Enter -} -> eval (CommitAction cfg)
|
||||
27 {- Escape -} -> eval (CancelAction cfg)
|
||||
_ -> return ()
|
||||
|
||||
html :: TodoItemConfig -> Html ()
|
||||
html cfg = li_ do
|
||||
let
|
||||
completedDyn =
|
||||
(.tis_completed) <$> fromRef cfg.state_ref
|
||||
editingDyn =
|
||||
isJust . (.tis_editing) <$> fromRef cfg.state_ref
|
||||
valueDyn =
|
||||
fromMaybe "" . (.tis_editing) <$> fromRef cfg.state_ref
|
||||
toggleClass "completed" completedDyn
|
||||
toggleClass "editing" editingDyn
|
||||
toggleClass "hidden" tic_is_hidden
|
||||
toggleClass "hidden" cfg.is_hidden
|
||||
div_ [class_ "view"] do
|
||||
on "dblclick" $ decodeEvent (propDecoder "target") \targetEl -> do
|
||||
title <- (.tis_title) <$> readRef tic_state_ref
|
||||
modifyRef tic_state_ref \s -> s {tis_editing = Just title}
|
||||
liftIO $ js_todoItemInputFocus targetEl
|
||||
on "dblclick" $ decodeEvent (propDecoder "target") $
|
||||
eval . DoubleClickAction cfg
|
||||
input_ [class_ "toggle", type_ "checkbox"] do
|
||||
dynChecked $ (.tis_completed) <$> fromRef tic_state_ref
|
||||
dynChecked $ (.tis_completed) <$> fromRef cfg.state_ref
|
||||
on "change" $ decodeEvent checkedDecoder $
|
||||
modifyRef tic_state_ref . (\v s -> s{tis_completed = v})
|
||||
label_ $ dynText $ (.tis_title) <$> fromRef tic_state_ref
|
||||
eval . CheckedAction cfg
|
||||
label_ $ dynText $ (.tis_title) <$> fromRef cfg.state_ref
|
||||
button_ [class_ "destroy"] do
|
||||
on_ "click" $ tic_delete_item
|
||||
on_ "click" $ cfg.ask_delete_item
|
||||
input_ [class_ "edit", type_ "text"] do
|
||||
dynValue valueDyn
|
||||
on "input" $ decodeEvent valueDecoder $
|
||||
modifyRef tic_state_ref . (\v s -> s{tis_editing = v}) . Just
|
||||
on "keydown" $ decodeEvent keyCodeDecoder \case
|
||||
13 -> commitEditing -- Enter
|
||||
27 -> cancelEditing -- Escape
|
||||
_ -> return ()
|
||||
on_ "blur" commitEditing
|
||||
where
|
||||
completedDyn =
|
||||
(.tis_completed) <$> fromRef tic_state_ref
|
||||
editingDyn =
|
||||
isJust . (.tis_editing) <$> fromRef tic_state_ref
|
||||
valueDyn =
|
||||
fromMaybe "" . (.tis_editing) <$> fromRef tic_state_ref
|
||||
commitEditing = readEditing >>= \case
|
||||
Just "" ->
|
||||
tic_delete_item
|
||||
Just t ->
|
||||
dynStep $ modifyRef tic_state_ref \s -> s
|
||||
{tis_editing=Nothing, tis_title = t}
|
||||
Nothing ->
|
||||
pure ()
|
||||
where
|
||||
readEditing = (.tis_editing) <$> readRef tic_state_ref
|
||||
cancelEditing =
|
||||
dynStep $ modifyRef tic_state_ref \s -> s{tis_editing=Nothing}
|
||||
eval . InputAction cfg
|
||||
on "keydown" $ decodeEvent keyCodeDecoder $
|
||||
eval . KeydownAction cfg
|
||||
on_ "blur" $
|
||||
eval (CommitAction cfg)
|
||||
|
||||
defaultItemState :: TodoItemState
|
||||
defaultItemState = TodoItemState "" False Nothing
|
||||
emptyTodoItemState :: TodoItemState
|
||||
emptyTodoItemState = TodoItemState "" False Nothing
|
||||
|
||||
instance ToJSVal TodoItemState where
|
||||
toJSVal s = do
|
||||
|
||||
@ -2,42 +2,89 @@ module TodoList where
|
||||
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Foldable
|
||||
import Data.List qualified as List
|
||||
import Data.Maybe
|
||||
import GHC.Generics (Generic)
|
||||
import HtmlT
|
||||
|
||||
import "this" TodoItem
|
||||
import "this" TodoItem qualified as TodoItem
|
||||
import "this" Utils
|
||||
|
||||
data TodoListConfig = TodoListConfig
|
||||
{ tlc_state_ref :: DynRef TodoListState
|
||||
{ state_ref :: DynRef TodoListState
|
||||
}
|
||||
|
||||
data TodoListState = TodoListState
|
||||
{ tls_title :: JSString
|
||||
, tls_items :: [TodoItemState]
|
||||
, tls_items :: [TodoItem.TodoItemState]
|
||||
, tls_filter :: Filter
|
||||
} deriving (Show, Eq, Generic)
|
||||
|
||||
data Filter = All | Active | Completed
|
||||
deriving (Show, Eq, Generic)
|
||||
|
||||
initTodos :: MonadReactive m => DynRef JSString -> m (DynRef TodoListState)
|
||||
initTodos urlHashRef = do
|
||||
todos <- fromMaybe [] . fmap unLocalStorageTodoItems <$> liftIO localStorageGet
|
||||
initFilter <- parseFilter' <$> readRef urlHashRef
|
||||
todosRef <- newRef $ TodoListState "" todos initFilter
|
||||
liftIO $ onBeforeUnload do
|
||||
TodoListState{tls_items} <- readRef todosRef
|
||||
localStorageSet $ LocalStorageTodoItems tls_items
|
||||
subscribe (updates (fromRef urlHashRef)) $
|
||||
modifyRef todosRef . (\v s -> s{tls_filter=v}) . parseFilter'
|
||||
return todosRef
|
||||
where
|
||||
parseFilter' = fromMaybe All . parseFilter
|
||||
newtype LocalStorageTodoItems = LocalStorageTodoItems
|
||||
{ unLocalStorageTodoItems :: [TodoItem.TodoItemState]
|
||||
} deriving newtype (ToJSVal, FromJSVal)
|
||||
|
||||
todoListWidget :: TodoListConfig -> Html ()
|
||||
todoListWidget TodoListConfig{..} = do
|
||||
data TodoListAction a where
|
||||
InitAction :: ReactiveEnv -> DynRef JSString -> TodoListAction (DynRef TodoListState)
|
||||
ToggleAllAction :: TodoListConfig -> Bool -> TodoListAction ()
|
||||
InputAction :: TodoListConfig -> JSString -> TodoListAction ()
|
||||
CommitAction :: TodoListConfig -> TodoListAction ()
|
||||
KeydownAction :: TodoListConfig -> Int -> TodoListAction ()
|
||||
DeleteItemAction :: TodoListConfig -> Int -> TodoListAction ()
|
||||
ClearCompletedAction :: TodoListConfig -> TodoListAction ()
|
||||
|
||||
eval :: TodoListAction a -> Step a
|
||||
eval = \case
|
||||
InitAction renv urlHashRef -> do
|
||||
let parseFilter' = fromMaybe All . parseFilter
|
||||
todos <- fromMaybe [] . fmap unLocalStorageTodoItems <$> liftIO localStorageGet
|
||||
initFilter <- parseFilter' <$> readRef urlHashRef
|
||||
todosRef <- execReactiveT renv do
|
||||
todosRef <- newRef $ TodoListState "" todos initFilter
|
||||
subscribe (updates (fromRef urlHashRef)) $
|
||||
modifyRef todosRef . (\v s -> s{tls_filter=v}) . parseFilter'
|
||||
return todosRef
|
||||
liftIO $ onBeforeUnload do
|
||||
TodoListState{tls_items} <- readRef todosRef
|
||||
localStorageSet $ LocalStorageTodoItems tls_items
|
||||
return todosRef
|
||||
ToggleAllAction cfg isChecked ->
|
||||
modifyRef cfg.state_ref \s -> s
|
||||
{ tls_items =
|
||||
fmap (\i -> i {TodoItem.tis_completed = isChecked}) s.tls_items
|
||||
}
|
||||
InputAction cfg newVal -> do
|
||||
modifyRef cfg.state_ref \s -> s {tls_title = newVal}
|
||||
CommitAction cfg -> do
|
||||
title <- {- JSS.strip . -} (.tls_title) <$> readRef cfg.state_ref
|
||||
case title of
|
||||
"" -> return ()
|
||||
t -> modifyRef cfg.state_ref \s -> s
|
||||
{ tls_items = s.tls_items <> [mkNewItem t]
|
||||
, tls_title = ""
|
||||
}
|
||||
KeydownAction cfg key -> case key of
|
||||
13 {- Enter -} -> eval (CommitAction cfg)
|
||||
_ -> return ()
|
||||
DeleteItemAction cfg itemIx ->
|
||||
modifyRef cfg.state_ref \s -> s {tls_items = deleteIx itemIx s.tls_items}
|
||||
ClearCompletedAction cfg ->
|
||||
modifyRef cfg.state_ref \s -> s
|
||||
{tls_items = (List.filter (not . TodoItem.tis_completed)) s.tls_items}
|
||||
where
|
||||
deleteIx :: Int -> [a] -> [a]
|
||||
deleteIx _ [] = []
|
||||
deleteIx i (a:as)
|
||||
| i == 0 = as
|
||||
| otherwise = a : deleteIx (i-1) as
|
||||
mkNewItem t =
|
||||
TodoItem.emptyTodoItemState {TodoItem.tis_title = t}
|
||||
|
||||
html :: TodoListConfig -> Html ()
|
||||
html cfg = do
|
||||
el "style" $ text styles
|
||||
div_ do
|
||||
section_ [class_ "todoapp"] do
|
||||
@ -49,25 +96,29 @@ 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 $ (.tls_title) <$> fromRef tlc_state_ref
|
||||
dynValue $ (.tls_title) <$> fromRef cfg.state_ref
|
||||
on "input" $ decodeEvent valueDecoder $
|
||||
modifyRef tlc_state_ref . (\v s -> s{tls_title=v})
|
||||
on "keydown" $ decodeEvent keyCodeDecoder \case
|
||||
13 -> commitEditing
|
||||
_ -> return ()
|
||||
eval . InputAction cfg
|
||||
on "keydown" $ decodeEvent keyCodeDecoder $
|
||||
eval . KeydownAction cfg
|
||||
mainWidget = section_ [class_ "main"] do
|
||||
toggleClass "hidden" hiddenDyn
|
||||
input_ [id_ "toggle-all", class_ "toggle-all", type_ "checkbox"] do
|
||||
on "click" $ decodeEvent checkedDecoder toggleAll
|
||||
on "click" $ decodeEvent checkedDecoder $
|
||||
eval . ToggleAllAction cfg
|
||||
label_ do
|
||||
attr "for" "toggle-all"
|
||||
text "Mark all as completed"
|
||||
ul_ [class_ "todo-list"] do
|
||||
simpleList itemsDyn \idx todoRef ->
|
||||
todoItemWidget $ TodoItemConfig
|
||||
{ tic_state_ref = todoRef {dynref_modifier = (todoItemModifier idx) todoRef.dynref_modifier}
|
||||
, tic_is_hidden = isTodoItemHidden <$> fromRef tlc_state_ref <*> fromRef todoRef
|
||||
, tic_delete_item = deleteTodoItem idx }
|
||||
TodoItem.html $ TodoItem.TodoItemConfig
|
||||
{ TodoItem.state_ref = todoRef
|
||||
{ dynref_modifier = todoItemModifier idx todoRef.dynref_modifier
|
||||
}
|
||||
, TodoItem.is_hidden =
|
||||
isTodoItemHidden <$> fromRef cfg.state_ref <*> fromRef todoRef
|
||||
, TodoItem.ask_delete_item = eval (DeleteItemAction cfg idx)
|
||||
}
|
||||
footerWidget = footer_ [class_ "footer"] do
|
||||
toggleClass "hidden" hiddenDyn
|
||||
span_ [class_ "todo-count"] do
|
||||
@ -76,7 +127,7 @@ todoListWidget TodoListConfig{..} = do
|
||||
ul_ [class_ "filters"] do
|
||||
for_ [All, Active, Completed] filterWidget
|
||||
button_ [class_ "clear-completed"] do
|
||||
on_ "click" clearCompleted
|
||||
on_ "click" $ eval (ClearCompletedAction cfg)
|
||||
text "Clear completed"
|
||||
footerInfoWidget = footer_ [class_ "info"] do
|
||||
p_ "Double-click to edit a todo"
|
||||
@ -90,34 +141,17 @@ todoListWidget TodoListConfig{..} = do
|
||||
a_ [href_ (printFilter flt)] do
|
||||
toggleClass "selected" $ filterSelectedDyn flt
|
||||
text $ fromHSString (show flt)
|
||||
commitEditing = readTitle >>= \case
|
||||
"" -> return ()
|
||||
title -> modifyRef tlc_state_ref \s -> s
|
||||
{ tls_items = s.tls_items <> [mkNewItem title]
|
||||
, tls_title = ""
|
||||
}
|
||||
where
|
||||
readTitle = {- JSS.strip . -} (.tls_title) <$> readRef tlc_state_ref
|
||||
mkNewItem title = defaultItemState {tis_title = title}
|
||||
hiddenDyn =
|
||||
Prelude.null . (.tls_items) <$> fromRef tlc_state_ref
|
||||
Prelude.null . (.tls_items) <$> fromRef cfg.state_ref
|
||||
itemsLeftDyn =
|
||||
countItemsLeft <$> fromRef tlc_state_ref
|
||||
toggleAll check =
|
||||
modifyRef tlc_state_ref \s -> s
|
||||
{tls_items = fmap (\i -> i{tis_completed=check}) s.tls_items}
|
||||
countItemsLeft <$> fromRef cfg.state_ref
|
||||
filterSelectedDyn flt =
|
||||
(==flt) . (.tls_filter) <$> fromRef tlc_state_ref
|
||||
(==flt) . (.tls_filter) <$> fromRef cfg.state_ref
|
||||
itemsDyn =
|
||||
(.tls_items) <$> fromRef tlc_state_ref
|
||||
clearCompleted =
|
||||
modifyRef tlc_state_ref \s -> s
|
||||
{tls_items = (Prelude.filter (not . tis_completed)) s.tls_items}
|
||||
(.tls_items) <$> fromRef cfg.state_ref
|
||||
countItemsLeft TodoListState{tls_items} =
|
||||
foldl (\acc TodoItemState{tis_completed} ->
|
||||
foldl (\acc TodoItem.TodoItemState{tis_completed} ->
|
||||
if not tis_completed then acc + 1 else acc) 0 tls_items
|
||||
deleteTodoItem idx =
|
||||
modifyRef tlc_state_ref \s -> s {tls_items = deleteAt idx s.tls_items}
|
||||
-- Synchronize local TodoItemState with whole list of Todo-items
|
||||
-- inside TodoListState
|
||||
todoItemModifier idx (Modifier elemMod) = Modifier \upd f -> do
|
||||
@ -128,11 +162,11 @@ todoListWidget TodoListConfig{..} = do
|
||||
-- possible to apply optimisations that would prevent whole list
|
||||
-- of items to be updated while only some particular item is
|
||||
-- changed, but they left out for the sake of simplicity
|
||||
unModifier (dynref_modifier tlc_state_ref) upd
|
||||
unModifier (dynref_modifier cfg.state_ref) upd
|
||||
((,()) . (\s -> s{tls_items = overIx idx (const new) s.tls_items}))
|
||||
return result
|
||||
isTodoItemHidden TodoListState{..} TodoItemState{..} =
|
||||
case (tls_filter, tis_completed) of
|
||||
isTodoItemHidden listState itemState =
|
||||
case (listState.tls_filter, itemState.tis_completed) of
|
||||
(Active, True) -> True
|
||||
(Completed, False) -> True
|
||||
_ -> False
|
||||
@ -158,12 +192,6 @@ printFilter = \case
|
||||
Active -> "#/active"
|
||||
Completed -> "#/completed"
|
||||
|
||||
deleteAt :: Int -> [a] -> [a]
|
||||
deleteAt _ [] = []
|
||||
deleteAt i (a:as)
|
||||
| i == 0 = as
|
||||
| otherwise = a : deleteAt (i-1) as
|
||||
|
||||
styles :: JSString
|
||||
styles = "\
|
||||
\body {\
|
||||
@ -544,6 +572,3 @@ styles = "\
|
||||
\ bottom: 10px;\
|
||||
\ }\
|
||||
\}"
|
||||
|
||||
newtype LocalStorageTodoItems = LocalStorageTodoItems {unLocalStorageTodoItems :: [TodoItemState]}
|
||||
deriving newtype (ToJSVal, FromJSVal)
|
||||
|
||||
@ -1,11 +1,13 @@
|
||||
import Control.Monad
|
||||
import Control.Monad.Reader
|
||||
import HtmlT
|
||||
|
||||
import "this" TodoList
|
||||
import "this" TodoList qualified as TodoList
|
||||
import "this" Utils
|
||||
|
||||
main :: IO ()
|
||||
main = void $ attachToBody do
|
||||
renv <- asks (.html_reactive_env)
|
||||
urlHashRef <- mkUrlHashRef
|
||||
todosRef <- initTodos urlHashRef
|
||||
todoListWidget $ TodoListConfig todosRef
|
||||
todosRef <- dynStep $ TodoList.eval (TodoList.InitAction renv urlHashRef)
|
||||
TodoList.html $ TodoList.TodoListConfig todosRef
|
||||
|
||||
@ -52,6 +52,7 @@ common htmlt-common
|
||||
GADTs
|
||||
GeneralizedNewtypeDeriving
|
||||
ImplicitParams
|
||||
ImportQualifiedPost
|
||||
LambdaCase
|
||||
NamedFieldPuns
|
||||
OverloadedLabels
|
||||
|
||||
Loading…
Reference in New Issue
Block a user