Hello everyone! In this part, we will look at using the ghcjs-dom class EventWriter

and library .

Using EventWriter

Now, in order to throw events from deeper levels, we pass them as return values. This is not always convenient, especially when you need to return something other than an event (for example, an input form can return both a button click event and data from a form at the same time). It would be much more convenient to use a mechanism that can "throw" events up automatically, without thinking about the fact that you need to constantly return them. And there is such a mechanism - EventWriter

. This class allows you to write events like a standard monad Writer

. Let's rewrite our application using EventWriter

.

Let's start by looking at the class itself EventWriter

:

class (Monad m, Semigroup w) => EventWriter t w m | m -> t w where
  tellEvent :: Event t w -> m ()

w

, Semigroup

, .. . , tellEvent

, - , - , .

, — EventWriterT

, runEventWriterT

.

. rootWidget

.

rootWidget :: MonadWidget t m => m ()
rootWidget =
  divClass "container" $ mdo
    elClass "h2" "text-center mt-3" $ text "Todos"
    (_, ev) <- runEventWriterT $ do
      todosDyn <- foldDyn appEndo mempty ev
      newTodoForm
      delimiter
      todoListWidget todosDyn
    blank

newTodoForm

, , :

newTodoForm :: (EventWriter t (Endo Todos) m, MonadWidget t m) => m ()
newTodoForm = rowWrapper $ el "form" $ divClass "input-group" $ mdo
  iEl <- inputElement $ def
    & initialAttributes .~
      (  "type" =: "text"
      <> "class" =: "form-control"
      <> "placeholder" =: "Todo" )
    & inputElementConfig_setValue .~ ("" <$ btnEv)
  let
    addNewTodo = \todo -> Endo $ \todos ->
      insert (nextKey todos) (newTodo todo) todos
    newTodoDyn = addNewTodo <$> value iEl
    btnAttr = "class" =: "btn btn-outline-secondary"
      <> "type" =: "button"
  (btnEl, _) <- divClass "input-group-append" $
    elAttr' "button" btnAttr $ text "Add new entry"
  let btnEv = domEvent Click btnEl
  tellEvent $ tagPromptlyDyn newTodoDyn $ domEvent Click btnEl

, , , EventWriter

. , , tellEvent

.

todoListWidget

.

todoListWidget
  :: (EventWriter t (Endo Todos) m, MonadWidget t m)
  => Dynamic t Todos -> m ()
todoListWidget todosDyn = rowWrapper $
  void $ listWithKey (M.fromAscList . IM.toAscList <$> todosDyn) todoWidget

, , , Event

Dynamic

.

todoWidget

. — Event t (Event t TodoEvent)

. dyn_

dyn

, , .

todoWidget
  :: (EventWriter t (Endo Todos) m, MonadWidget t m)
  => Int -> Dynamic t Todo -> m ()
todoWidget ix todoDyn' = do
  todoDyn <- holdUniqDyn todoDyn'
  dyn_ $ ffor todoDyn $ \td@Todo{..} -> case todoState of
    TodoDone         -> todoDone ix todoText
    TodoActive False -> todoActive ix todoText
    TodoActive True  -> todoEditable ix todoText

todoDone

, todoActive

todoEditable

.

todoActive
  :: (EventWriter t (Endo Todos) m, MonadWidget t m)
  => Int -> Text -> m ()
todoActive ix todoText = divClass "d-flex border-bottom" $ do
  divClass "p-2 flex-grow-1 my-auto" $
    text todoText
  divClass "p-2 btn-group" $ do
    (doneEl, _) <- elAttr' "button"
      (  "class" =: "btn btn-outline-secondary"
      <> "type" =: "button" ) $ text "Done"
    (editEl, _) <- elAttr' "button"
      (  "class" =: "btn btn-outline-secondary"
      <> "type" =: "button" ) $ text "Edit"
    (delEl, _) <- elAttr' "button"
      (  "class" =: "btn btn-outline-secondary"
      <> "type" =: "button" ) $ text "Drop"
    tellEvent $ Endo <$> leftmost
      [ update (Just . toggleTodo) ix <$ domEvent Click doneEl
      , update (Just . startEdit) ix  <$ domEvent Click editEl
      , delete ix <$ domEvent Click delEl
      ]

todoDone
  :: (EventWriter t (Endo Todos) m, MonadWidget t m)
  => Int -> Text -> m ()
todoDone ix todoText = divClass "d-flex border-bottom" $ do
  divClass "p-2 flex-grow-1 my-auto" $
    el "del" $ text todoText
  divClass "p-2 btn-group" $ do
    (doneEl, _) <- elAttr' "button"
      (  "class" =: "btn btn-outline-secondary"
      <> "type" =: "button" ) $ text "Undo"
    (delEl, _) <- elAttr' "button"
      (  "class" =: "btn btn-outline-secondary"
      <> "type" =: "button" ) $ text "Drop"
    tellEvent $ Endo <$> leftmost
      [ update (Just . toggleTodo) ix <$ domEvent Click doneEl
      , delete ix <$ domEvent Click delEl
      ]

todoEditable
  :: (EventWriter t (Endo Todos) m, MonadWidget t m)
  => Int -> Text -> m ()
todoEditable ix todoText = divClass "d-flex border-bottom" $ do
  updTodoDyn <- divClass "p-2 flex-grow-1 my-auto" $
    editTodoForm todoText
  divClass "p-2 btn-group" $ do
    (doneEl, _) <- elAttr' "button"
      (  "class" =: "btn btn-outline-secondary"
      <> "type" =: "button" ) $ text "Finish edit"
    let updTodos = \todo -> Endo $ update (Just . finishEdit todo) ix
    tellEvent $
      tagPromptlyDyn (updTodos <$> updTodoDyn) (domEvent Click doneEl)

EventWriter

.

ghcjs-dom

reflex

DOM

, JS- . , , reflex

. ghcjs-dom

. , JS API

Haskell. , JS.

JS, , :

function toClipboard(txt){
  var inpEl = document.createElement("textarea");
  document.body.appendChild(inpEl);
  inpEl.value = txt
  inpEl.focus();
  inpEl.select();
  document.execCommand('copy');
  document.body.removeChild(inpEl);
}

, , .

Haskell? , GHCJS

ghcjs

.

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MonoLocalBinds #-}
module GHCJS where

import Control.Monad
import Data.Functor (($>))
import Data.Text (Text)
import GHCJS.DOM
import GHCJS.DOM.Document
  (createElement, execCommand, getBodyUnchecked)
import GHCJS.DOM.Element as Element hiding (scroll)
import GHCJS.DOM.HTMLElement as HE (focus)
import GHCJS.DOM.HTMLInputElement as HIE (select, setValue)
import GHCJS.DOM.Node (appendChild, removeChild)
import GHCJS.DOM.Types hiding (Event, Text)
import Reflex.Dom as R

toClipboard :: MonadJSM m => Text -> m ()
toClipboard txt = do
  doc <- currentDocumentUnchecked
  body <- getBodyUnchecked doc
  inpEl <- uncheckedCastTo HTMLInputElement <$> createElement doc
    ("textarea" :: Text)
  void $ appendChild body inpEl
  HE.focus inpEl
  HIE.setValue inpEl txt
  HIE.select inpEl
  void $ execCommand doc ("copy" :: Text) False (Nothing :: Maybe Text)
  void $ removeChild body inpEl

haskell toClipboard

JS . , MonadWidget

, MonadJSM

— , ghcjs-dom

. MonadWidget

MonadJSM

. , :

copyByEvent :: MonadWidget t m => Text -> Event t () -> m ()
copyByEvent txt ev =
  void $ performEvent $ ev $> toClipboard txt

performEvent

, . PerformEvent

:

class (Reflex t, Monad (Performable m), Monad m) => PerformEvent t m | m -> t where
  type Performable m :: * -> *
  performEvent :: Event t (Performable m a) -> m (Event t a)
  performEvent_ :: Event t (Performable m ()) -> m ()

, import GHCJS

:

todoActive
  :: (EventWriter t TodoEvent m, MonadWidget t m) => Int -> Todo -> m ()
todoActive ix Todo{..} =
  divClass "d-flex border-bottom" $ do
    divClass "p-2 flex-grow-1 my-auto" $
      text todoText
    divClass "p-2 btn-group" $ do
      (copyEl, _) <- elAttr' "button"
        (  "class" =: "btn btn-outline-secondary"
        <> "type" =: "button" ) $ text "Copy"
      (doneEl, _) <- elAttr' "button"
        (  "class" =: "btn btn-outline-secondary"
        <> "type" =: "button" ) $ text "Done"
      (editEl, _) <- elAttr' "button"
        (  "class" =: "btn btn-outline-secondary"
        <> "type" =: "button" ) $ text "Edit"
      (delEl, _) <- elAttr' "button"
        (  "class" =: "btn btn-outline-secondary"
        <> "type" =: "button" ) $ text "Drop"
      copyByEvent todoText $ domEvent Click copyEl
      tellEvent $ leftmost
        [ ToggleTodo ix <$ domEvent Click doneEl
        , StartEditTodo ix <$ domEvent Click editEl
        , DeleteTodo ix <$ domEvent Click delEl
        ]

Copy

copyByEvent

. .

, , .

JSFFI (JS Foreign Function Interface).

Create a Haskell web application using Reflex. Part 3

Using EventWriter

ghcjs-dom

More articles: