add very simple 'chat'

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