Add external css example

examples/Example/App.hs

@@ -58,7 +58,8 @@ import Example.Page.State.Effects qualified as Effects
 import Example.Page.State.Query qualified as Query
 import Example.Page.State.Sessions qualified as Sessions
 import Example.Page.Test qualified as Test
-import Example.Page.Todo qualified as Todo
+import Example.Page.Todos.Todo qualified as Todo
+import Example.Page.Todos.TodoCSS qualified as TodoCSS
 import Example.Style qualified as Style
 import Example.View.Layout as Layout (example, exampleLayout, sourceLink)
 import Foreign.Store (Store (..), lookupStore, readStore, storeAction, withStore)
@@ -142,6 +143,7 @@ app config users count = do
   router Interactivity = runPage Interactivity.page
   router (Examples BigExamples) = redirect $ routeUri (Examples Todos)
   router (Examples Todos) = runPage Todo.page
+  router (Examples TodosCSS) = runPage TodoCSS.page
   router Javascript = runPage Javascript.page
   router OAuth2 = runPage OAuth2.page
   router OAuth2Authenticate = OAuth2.handleRedirect

examples/Example/AppRoute.hs

@@ -68,6 +68,7 @@ instance Route ContactRoute where
 data ExamplesRoute
   = BigExamples
   | Todos
+  | TodosCSS -- A version using the CSS from TodoMVC project
   deriving (Eq, Generic, Show)
 instance Route ExamplesRoute where
   baseRoute = Just BigExamples

examples/Example/Effects/Todos.hs

@@ -17,6 +17,7 @@ newtype AllTodos = AllTodos (Map TodoId Todo)
 
 instance Session AllTodos where
   sessionKey = "todos"
+  cookiePath = Just "/examples" -- share data between both pages
 instance Default AllTodos where
   def = AllTodos mempty
 

examples/Example/Page/Todos/Shared.hs

@@ -0,0 +1,88 @@
+{-# LANGUAGE LambdaCase #-}
+
+module Example.Page.Todos.Shared
+  ( pluralize
+  , FilterTodo (..)
+  , TodoForm (..)
+  , AllTodos (..)
+  , TodosAction (..)
+  , updateTodos
+  , TodoAction (..)
+  , updateTodo
+  ) where
+
+import Data.Text (Text)
+import Effectful
+import Example.Effects.Todos (Todo (..), Todos)
+import Example.Effects.Todos qualified as Todos
+import Web.Hyperbole as Hyperbole hiding (Action, update)
+
+data FilterTodo
+  = FilterAll
+  | Active
+  | Completed
+  deriving (Eq, Generic, ToJSON, FromJSON)
+
+data TodoForm f = TodoForm
+  { task :: Field f Text
+  }
+  deriving (Generic, FromFormF, GenFields FieldName)
+
+pluralize :: Int -> Text -> Text -> Text
+pluralize n singular plural =
+  if n == 1
+    then
+      singular
+    else
+      plural
+
+data AllTodos = AllTodos
+  deriving (Generic, ViewId)
+
+data TodosAction
+  = ClearCompleted
+  | Filter FilterTodo
+  | SubmitTodo
+  | ToggleAll FilterTodo
+  | SetCompleted FilterTodo Todo Bool
+  | Destroy FilterTodo Todo
+  deriving (Generic, ViewAction)
+
+updateTodos :: (Todos :> es, Hyperbole :> es) => TodosAction -> Eff es [Todo]
+updateTodos = \case
+  SubmitTodo -> do
+    TodoForm task <- formData @(TodoForm Identity)
+    _ <- Todos.create task
+    Todos.loadAll
+  ToggleAll filt -> do
+    todos <- filteredTodos filt
+    Todos.toggleAll todos
+  ClearCompleted -> do
+    Todos.clearCompleted
+  Filter filt -> do
+    filteredTodos filt
+  SetCompleted filt todo completed -> do
+    _ <- Todos.setCompleted completed todo
+    filteredTodos filt
+  Destroy filt todo -> do
+    Todos.clear todo
+    filteredTodos filt
+ where
+  filteredTodos filt =
+    filter (isFilter filt) <$> Todos.loadAll
+
+  isFilter filt todo =
+    case filt of
+      FilterAll -> True
+      Active -> not todo.completed
+      Completed -> todo.completed
+
+data TodoAction
+  = SubmitEdit Todo
+  deriving (Generic, ViewAction, ToJSON, FromJSON)
+
+updateTodo :: (Todos :> es, Hyperbole :> es) => TodoAction -> Eff es Todo
+updateTodo = \case
+  SubmitEdit todo -> do
+    TodoForm task <- formData @(TodoForm Identity)
+    Todos.setTask task todo

examples/Example/Page/Todo.hs → examples/Example/Page/Todos/Todo.hs

@@ -1,16 +1,17 @@
 {-# LANGUAGE DerivingVia #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE UndecidableInstances #-}
 
-module Example.Page.Todo where
+module Example.Page.Todos.Todo where
 
 import Control.Monad (forM_)
-import Data.Text (Text, pack)
+import Data.Text (pack)
 import Effectful
 import Example.AppRoute qualified as Route
 import Example.Colors
 import Example.Effects.Todos (Todo (..), TodoId, Todos, runTodosSession)
 import Example.Effects.Todos qualified as Todos
+import Example.Page.Todos.Shared (FilterTodo (Active, Completed, FilterAll), TodoForm (..))
+import Example.Page.Todos.Shared qualified as Shared
 import Example.Style qualified as Style
 import Example.View.Icon qualified as Icon
 import Example.View.Inputs (toggleCheckbox)
@@ -25,6 +26,7 @@ page = do
     example "Todos" "Example/Page/Todo.hs" $ do
       col ~ embed $ hyper AllTodos $ todosView FilterAll todos
 
+-- Keep this, it's used for documentation (+ usable via the REPL, see main below)
 simplePage :: (Todos :> es) => Eff es (Page '[AllTodos, TodoView])
 simplePage = do
   todos <- Todos.loadAll
@@ -39,49 +41,23 @@ data AllTodos = AllTodos
 instance (Todos :> es) => HyperView AllTodos es where
   type Require AllTodos = '[TodoView]
 
-  data Action AllTodos
-    = ClearCompleted
-    | Filter FilterTodo
-    | SubmitTodo
-    | ToggleAll FilterTodo
-    | SetCompleted FilterTodo Todo Bool
-    deriving (Generic, ViewAction)
-
-  update = \case
-    SubmitTodo -> do
-      TodoForm task <- formData @(TodoForm Identity)
-      _ <- Todos.create task
-      todos <- Todos.loadAll
-      pure $ todosView FilterAll todos
-    ToggleAll filt -> do
-      todos <- filteredTodos filt
-      updated <- Todos.toggleAll todos
-      pure $ todosView filt updated
-    ClearCompleted -> do
-      todos <- Todos.clearCompleted
-      pure $ todosView FilterAll todos
-    Filter filt -> do
-      todos <- filteredTodos filt
-      pure $ todosView filt todos
-    SetCompleted filt todo completed -> do
-      _ <- Todos.setCompleted completed todo
-      todos <- filteredTodos filt
-      pure $ todosView filt todos
-   where
-    filteredTodos filt =
-      filter (isFilter filt) <$> Todos.loadAll
-
-    isFilter filt todo =
-      case filt of
-        FilterAll -> True
-        Active -> not todo.completed
-        Completed -> todo.completed
-
-data FilterTodo
-  = FilterAll
-  | Active
-  | Completed
-  deriving (Eq, Generic, ToJSON, FromJSON)
+  newtype Action AllTodos = MkTodosAction Shared.TodosAction
+    deriving newtype (Generic, ViewAction)
+
+  update (MkTodosAction action) = do
+    case action of
+      Shared.ClearCompleted ->
+        todosView FilterAll <$> Shared.updateTodos Shared.ClearCompleted
+      Shared.SubmitTodo ->
+        todosView FilterAll <$> Shared.updateTodos Shared.SubmitTodo
+      Shared.Filter f ->
+        todosView f <$> Shared.updateTodos (Shared.Filter f)
+      Shared.ToggleAll f ->
+        todosView f <$> Shared.updateTodos (Shared.ToggleAll f)
+      Shared.SetCompleted f t b ->
+        todosView f <$> Shared.updateTodos (Shared.SetCompleted f t b)
+      Shared.Destroy f t ->
+        todosView f <$> Shared.updateTodos (Shared.Destroy f t)
 
 todosView :: FilterTodo -> [Todo] -> View AllTodos ()
 todosView filt todos = do
@@ -96,16 +72,11 @@ todoForm filt = do
   let f :: TodoForm FieldName = fieldNames
   row ~ border 1 $ do
     el ~ pad 8 $ do
-      button (ToggleAll filt) Icon.chevronDown ~ width 32 . hover (color Primary)
-    form SubmitTodo ~ grow $ do
+      button (MkTodosAction $ Shared.ToggleAll filt) Icon.chevronDown ~ width 32 . hover (color Primary)
+    form (MkTodosAction Shared.SubmitTodo) ~ grow $ do
       field f.task $ do
         input TextInput ~ pad 12 @ placeholder "What needs to be done?" . value ""
 
-data TodoForm f = TodoForm
-  { task :: Field f Text
-  }
-  deriving (Generic, FromFormF, GenFields FieldName)
-
 statusBar :: FilterTodo -> [Todo] -> View AllTodos ()
 statusBar filt todos = do
   row ~ pad 10 . color SecondaryLight $ do
@@ -119,10 +90,10 @@ statusBar filt todos = do
       filterButton Active "Active"
       filterButton Completed "Completed"
     space
-    button ClearCompleted ~ hover (color Primary) $ "Clear completed"
+    button (MkTodosAction Shared.ClearCompleted) ~ hover (color Primary) $ "Clear completed"
  where
   filterButton f =
-    button (Filter f) ~ selectedFilter f . pad (XY 4 0) . rounded 2
+    button (MkTodosAction $ Shared.Filter f) ~ selectedFilter f . pad (XY 4 0) . rounded 2
   selectedFilter f =
     if f == filt then border 1 else id
 
@@ -136,34 +107,45 @@ instance (Todos :> es) => HyperView TodoView es where
 
   data Action TodoView
     = Edit FilterTodo Todo
-    | SubmitEdit FilterTodo Todo
+    | MkTodoAction FilterTodo Shared.TodoAction
     deriving (Generic, ViewAction)
 
   update (Edit filt todo) = do
     pure $ todoEditView filt todo
-  update (SubmitEdit filt todo) = do
-    TodoForm task <- formData @(TodoForm Identity)
-    updated <- Todos.setTask task todo
-    pure $ todoView filt updated
+  update (MkTodoAction filt action) =
+    todoView filt <$> Shared.updateTodo action
 
 todoView :: FilterTodo -> Todo -> View TodoView ()
 todoView filt todo = do
-  row ~ border (TRBL 0 0 1 0) . pad 10 $ do
+  row ~ border (TRBL 0 0 1 0) . pad 10 . showDestroyOnHover $ do
+    target AllTodos $ do
+      toggleCheckbox (MkTodosAction . Shared.SetCompleted filt todo) todo.completed
+    el (text todo.task) @ onDblClick (Edit filt todo) ~ completed . pad (XY 18 4) . grow
     target AllTodos $ do
-      toggleCheckbox (SetCompleted filt todo) todo.completed
-    el (text todo.task) @ onDblClick (Edit filt todo) ~ completed . pad (XY 18 4)
+      button (MkTodosAction $ Shared.Destroy filt todo) "✕" ~ cls "destroy-btn" . opacity 0 . hover (color Primary) . pad 4
  where
   completed = if todo.completed then Style.strikethrough else id
+  showDestroyOnHover =
+    css
+      "todo-row"
+      ".todo-row:hover > .destroy-btn"
+      (declarations (opacity 100))
 
 todoEditView :: FilterTodo -> Todo -> View TodoView ()
 todoEditView filt todo = do
   let f = fieldNames @TodoForm
   row ~ border (TRBL 0 0 1 0) . pad 10 $ do
-    form (SubmitEdit filt todo) ~ pad (TRBL 0 0 0 46) $ do
+    form (MkTodoAction filt $ Shared.SubmitEdit todo) ~ pad (TRBL 0 0 0 46) $ do
       field f.task $ do
         input TextInput @ value todo.task . autofocus ~ pad 4
 
+{-
+You may try this in the REPL for simple tests:
+
+bash> cabal repl exe:examples lib:hyperbole
+ghci> Todo.main
+-}
 main :: IO ()
 main = do
   run 3000 $ do
-    liveApp (basicDocument "Example") (runTodosSession $ runPage page)
+    liveApp (basicDocument "Todo (simple)") (runTodosSession $ runPage simplePage)