diff options
| -rw-r--r-- | app/Main.hs | 111 |
1 files changed, 49 insertions, 62 deletions
diff --git a/app/Main.hs b/app/Main.hs index 54a54e5..7b665ae 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -38,12 +38,12 @@ import Halogen.IO.Util as HA import Halogen.VDom.Driver (runUI) #endif -attachComponent :: IO (HalogenSocket Query [Chat] IO) +attachComponent :: IO (HalogenSocket VoidF () IO) logStr :: Text -> IO () #if defined(javascript_HOST_ARCH) attachComponent = - HA.awaitBody >>= runUI chats () + HA.awaitBody >>= runUI chats testChats logStr = log #else attachComponent = panic "This module can only be run on JavaScript" @@ -57,14 +57,6 @@ main = do void $ HS.subscribe messages $ \st -> logStr $ "State changed: " <> show st -{- -forever $ do - threadDelay 5_000_000 - void $ query (IncrementQ ()) - threadDelay 5_000_000 - void $ query (DecrementQ ()) - -} - data Chat = Chat { chatMessages :: [ChatMessage], draft :: Text @@ -74,6 +66,7 @@ data Chat = Chat data ChatMessage = ChatMessage Text deriving (Show) +testChats :: [Chat] testChats = [ Chat [ ChatMessage "Hello", @@ -83,73 +76,67 @@ testChats = "" ] -data Action = NoOp | DraftChanged Int Text | DraftSubmitted Int - -data Query a = NoOpQ +type Slots = ("chat" .== H.Slot VoidF () ()) -chats :: (MonadDOM m, MonadUnliftIO m) => H.Component Query () [Chat] m +chats :: (MonadDOM m, MonadUnliftIO m) => H.Component query [Chat] () m chats = H.mkComponent $ H.ComponentSpec { initialState, render, - eval = - H.mkEval $ - H.defaultEval - { handleAction, - handleQuery, - initialize = Nothing - } + eval } where - initialState _ = pure testChats - + initialState = pure render :: (MonadDOM m, MonadUnliftIO m) => - [Chat] -> - H.ComponentHTML Action slots m + [Chat] -> H.ComponentHTML action Slots m render chats = HH.div_ $ fmap - ( \(index, (Chat chatMessages draft)) -> - HH.div_ - [ HH.div_ - (fmap (\(ChatMessage message) -> HH.text message) chatMessages), - HH.input - [ HP.value draft, - HE.onInputValueChange $ Just . (DraftChanged index), - HE.onClick (\_ -> DraftSubmitted index) - ] - ] + ( \(index, input) -> + HH.slot_ "chat" () chat input ) (zip [1 ..] chats) + eval = H.mkEval H.defaultEval - handleQuery = \case - NoOpQ -> do - pure Nothing +data Action + = DraftChanged Text + | DraftSubmitted +chat :: (MonadDOM m, MonadUnliftIO m) => H.Component query Chat () m +chat = + H.mkComponent $ + H.ComponentSpec + { initialState, + render, + eval = + H.mkEval $ + H.defaultEval + { handleAction, + initialize = Nothing + } + } + where + initialState = pure + render (Chat chatMessages draft) = + HH.div_ + [ HH.div_ $ + fmap + (\(ChatMessage message) -> HH.text message) + chatMessages, + HH.input + [ HP.value draft, + HE.onInputValueChange $ Just . DraftChanged, + HE.onClick $ const DraftSubmitted + ] + ] handleAction = \case - NoOp -> do - get >>= H.raise - DraftChanged index draft -> do - modify $ \chats -> - fmap - ( \(indexOther, chat) -> - if indexOther == index then chat {draft = draft} else chat - ) - (zip [1 ..] chats) - get >>= H.raise - DraftSubmitted index -> do - modify $ \chats -> - fmap - ( \(indexOther, chat) -> - if indexOther == index - then - chat - { chatMessages = - chat.chatMessages ++ [ChatMessage chat.draft] - } - else chat - ) - (zip [1 ..] chats) - get >>= H.raise + DraftChanged draft -> do + modify $ \chat -> chat {draft = draft} + DraftSubmitted -> do + modify $ \chat -> + chat + { chatMessages = chat.chatMessages ++ [ChatMessage chat.draft], + draft = "" + } |