From af5af2a868d9f65738e3a566684ba397737b8419 Mon Sep 17 00:00:00 2001
From: Fabian Kirchner <kirchner@posteo.de>
Date: Sun, 2 Mar 2025 21:18:24 +0100
Subject: add very simple 'chat'
---
app/Main.hs | 162 +++++++++++++++++++++++++++++++-----------------------------
default.nix | 1 +
2 files changed, 85 insertions(+), 78 deletions(-)
diff --git a/app/Main.hs b/app/Main.hs
index 1b1fa25..b71fefd 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -4,6 +4,7 @@
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QualifiedDo #-}
{-# LANGUAGE RankNTypes #-}
@@ -37,7 +38,7 @@ import Halogen.IO.Util as HA
import Halogen.VDom.Driver (runUI)
#endif
-attachComponent :: IO (HalogenSocket Query Int IO)
+attachComponent :: IO (HalogenSocket Query [Chat] IO)
logStr :: Text -> IO ()
#if defined(javascript_HOST_ARCH)
@@ -64,98 +65,103 @@ forever $ do
void $ query (DecrementQ ())
-}
-data Action = Increment Int | Decrement Int | Init
+data Chat = Chat
+ { chatMessages :: [Message],
+ draft :: Text
+ }
+ deriving (Show)
+
+data Message = Message Text
+ deriving (Show)
+
+testChats =
+ [ Chat
+ [ Message "Hello",
+ Message "Hi",
+ Message "Hey"
+ ]
+ ""
+ ]
+
+data Action = NoOp | DraftChanged Int Text | DraftSubmitted Int
type Slots = ("debounced" .== H.Slot VoidF () ())
-data Query a = IncrementQ a | DecrementQ a
+data Query a = NoOpQ
-component :: forall m. (MonadDOM m, MonadUnliftIO m) => H.Component Query () Int m
+component :: forall m. (MonadDOM m, MonadUnliftIO m) => H.Component Query () [Chat] m
component =
H.mkComponent $
H.ComponentSpec
{ initialState,
render,
- eval = H.mkEval $ H.defaultEval {handleAction, handleQuery, initialize = Just Init}
+ eval = H.mkEval $ H.defaultEval {handleAction, handleQuery, initialize = Nothing}
}
where
- initialState _ = pure 0
-
- render :: (MonadDOM m, MonadUnliftIO m) => Int -> H.ComponentHTML Action Slots m
- render state =
- L.runLayoutM (defGridBagSettings {rows = 3, cols = 3}) $ L.do
- L.with (GridBagLayoutConstraints 1 1 2 2) $ L.runLayoutM Vertical $ L.do
- HH.button [HE.onClick $ const $ Decrement 1] [HH.text "-"]
- L.if_ (state > 5) $ HH.button [HE.onClick $ const $ Decrement 2] [HH.text "--"]
- HH.div_ [HH.text $ show state]
- HH.button [HE.onClick $ const $ Increment 1] [HH.text "+"]
- L.if_ (state > 5) $ HH.button [HE.onClick $ const $ Increment 2] [HH.text "++"]
- slot_ "debounced" () debComp ()
- HH.div_ [HH.text "Test sentinel element"]
- L.end
-
- L.with (GridBagLayoutConstraints 3 3 1 1) $
- HH.div [HP.style $ C.border (C.px 2) C.solid C.black] [HH.text "Banner!"]
-
+ initialState _ = pure testChats
+
+ render :: (MonadDOM m, MonadUnliftIO m) => [Chat] -> H.ComponentHTML Action Slots m
+ render chats =
+ L.runLayoutM Horizontal $ L.do
+ HH.div
+ []
+ ( Protolude.map
+ ( \(index, (Chat chatMessages draft)) ->
+ HH.div
+ []
+ [ HH.div
+ []
+ ( Protolude.map
+ ( \(Message message) ->
+ HH.text message
+ )
+ chatMessages
+ ),
+ HH.input
+ [ HP.value draft,
+ HE.onInputValueChange $ Just . (DraftChanged index),
+ HE.onClick (\_ -> DraftSubmitted index)
+ ]
+ ]
+ )
+ (zip [1 ..] chats)
+ )
L.end
handleQuery = \case
- IncrementQ cb -> do
- modify (+ 1)
- get >>= H.raise
- pure $ Just cb
- DecrementQ cb -> do
- modify (subtract 1)
- get >>= H.raise
- pure $ Just cb
+ NoOpQ -> do
+ pure Nothing
handleAction = \case
- Init ->
- lift $ do
- log "Initialized"
- _ <-
- liftIO $ xhrByteString
- ( Request
- { reqMethod = GET,
- reqURI = "http://localhost:8081/api/rest/collection/user",
- reqLogin = Nothing,
- reqHeaders = [],
- reqWithCredentials = False,
- reqData = NoData
- }
- )
- pure ()
- Increment n -> do
- modify (+ n)
+ NoOp -> do
get >>= H.raise
- Decrement n -> do
- modify (subtract n)
+ DraftChanged index draft -> do
+ modify
+ ( \chats ->
+ Protolude.map
+ ( \(indexOther, chat) ->
+ if indexOther == index
+ then
+ chat {draft = draft}
+ else chat
+ )
+ (zip [1 ..] chats)
+ )
+ get >>= H.raise
+ DraftSubmitted index -> do
+ modify
+ ( \chats ->
+ Protolude.map
+ ( \(indexOther, chat) ->
+ if indexOther == index
+ then
+ chat
+ { chatMessages =
+ chat.chatMessages
+ ++ [Message chat.draft]
+ }
+ else chat
+ )
+ (zip [1 ..] chats)
+ )
get >>= H.raise
-
----------------------------------------
-
-newtype DebChanged = DebChanged Text
-
-debComp :: (MonadDOM m, MonadUnliftIO m) => Component VoidF () () m
-debComp = unsafeMkDebouncedComponent 0.5 $ ComponentSpec {initialState, render, eval}
- where
- initialState _ = pure ""
-
- render txt = runLayoutM Vertical $ L.do
- HH.div_ [HH.text "The text below is debounced"]
- HH.div_ [HH.text $ "Input content: " <> txt]
- HH.input
- [ HP.type_ I.InputText,
- HP.value txt,
- HP.style $ C.width C.auto,
- HE.onInputValueChange $ Just . DebChanged
- ]
- L.end
-
- eval = NT $ \case
- Initialize a -> pure a
- Finalize a -> pure a
- Receive _i a -> pure a
- Action (DebChanged str) a ->
- put str $> a
- Query (Coyoneda _req _fct) _f -> panic "Void2"
diff --git a/default.nix b/default.nix
index 7daa1a8..39a3bd6 100644
--- a/default.nix
+++ b/default.nix
@@ -54,6 +54,7 @@ rec {
build-frontend
build-backend
'')
+ pkgs.python3
];
shellHook = ''
export EM_CACHE="${toString ./.}/.emcache" # nixos/nixpkgs#282509
--
cgit v1.2.3