Create a Haskell web application using Reflex. Part 4

Part 1.

Part 2.

Part 3.

Hello everyone! In the new part, we will look at using JSFFI

intro

JSFFI

Let’s add the ability to set a deadline date to our application. Let’s say you want to make not just a text input, but for it to be a drop-down datepicker. You can, of course, write your datepicker on reflex, but there are many different JS libraries that you can use. When there is already a ready-made JS code, which, for example, is too large to rewrite using GHCJS, it is possible to connect it using JSFFI (JavaScript Foreign Function Interface)… In our case, we will use flatpickr

Let’s create a new module JSFFI, let’s immediately add its import to Main… Let’s paste the following code into the created file:

{-# LANGUAGE MonoLocalBinds #-}
module JSFFI where

import Control.Monad.IO.Class
import Reflex.Dom

foreign import javascript unsafe
  "(function() { 
   flatpickr($1, { 
     enableTime: false, 
     dateFormat: "Y-m-d" 
    }); 
  })()"
  addDatePicker_js :: RawInputElement GhcjsDomSpace -> IO ()

addDatePicker :: MonadWidget t m => InputElement er GhcjsDomSpace t -> m ()
addDatePicker = liftIO . addDatePicker_js . _inputElement_raw

Also, do not forget to add to the element head required script and styles:

  elAttr "link"
    (  "rel" =: "stylesheet"
    <> "href" =: "https://cdn.jsdelivr.net/npm/flatpickr/dist/flatpickr.min.css" )
    blank
  elAttr "script"
    (  "src" =: "https://cdn.jsdelivr.net/npm/flatpickr")
    blank

We try to compile, as before, and we get the following error:

src/JSFFI.hs:(9,1)-(16,60): error:
    • The `javascript' calling convention is unsupported on this platform
    • When checking declaration:
        foreign import javascript unsafe "(function() {    flatpickr($1, {      enableTime: false,      dateFormat: "Y-m-d"    });   })()" addDatePicker_js
          :: RawInputElement GhcjsDomSpace -> IO ()
  |
9 | foreign import javascript unsafe
  |

Indeed, now we are building our application using GHCwhich has no idea what JSFFI is. Recall that now the server is starting, which, using websockets, sends the updated DOMwhen required, and JavaScript code is foreign to it. Here the conclusion suggests itself that to use our datepicker when assembling using GHC will not work. However, in production GHC will not be used for the client, we will compile to JS using GHCJS, and embed the resulting JS into our page. ghcid do not support GHCJS therefore, it makes no sense to boot into the nix shell, we will use nix immediately for building:

nix-build . -A ghcjs.todo-client -o todo-client-bin

The directory will appear in the root directory of the application todo-client-bin with the following structure:

todo-client-bin
└── bin
    ├── todo-client-bin
    └── todo-client-bin.jsexe
        ├── all.js
        ├── all.js.externs
        ├── index.html
        ├── lib.js
        ├── manifest.webapp
        ├── out.frefs.js
        ├── out.frefs.json
        ├── out.js
        ├── out.stats
        ├── rts.js
        └── runmain.js

Opening index.html in the browser, we will see our application. We put together the project with GHCJS, but for development it is still more convenient to use GHC together with ghcid, so we modify the module JSFFI as follows:

{-# LANGUAGE CPP #-}
{-# LANGUAGE MonoLocalBinds #-}

module JSFFI where

import Reflex.Dom

#ifdef ghcjs_HOST_OS

import Control.Monad.IO.Class

foreign import javascript unsafe
  "(function() {
    flatpickr($1, {
      enableTime: false,
      dateFormat: "Y-m-d"
    }); 
  })()"
  addDatePicker_js :: RawInputElement GhcjsDomSpace -> IO ()

addDatePicker :: MonadWidget t m => InputElement er GhcjsDomSpace t -> m ()
addDatePicker = liftIO . addDatePicker_js . _inputElement_raw

#else

addDatePicker :: MonadWidget t m => InputElement er GhcjsDomSpace t -> m ()
addDatePicker _ = pure ()

#endif

We added conditional compilation: depending on the platform, we will either use a JS function call or a stub.

Now you need to change the form for adding a new task by adding a date selection field there:

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)
  dEl <- inputElement $ def
    & initialAttributes .~
      (  "type" =: "text"
      <> "class" =: "form-control"
      <> "placeholder" =: "Deadline"
      <> "style" =: "max-width: 150px" )
  addDatePicker dEl
  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

Let’s compile our application, try to run it, and we still won’t see anything. If we look at the developer console in a browser, we see the following error:

uncaught exception in Haskell main thread: ReferenceError: flatpickr is not defined
rts.js:5902 ReferenceError: flatpickr is not defined
    at out.js:43493
    at h$$abX (out.js:43495)
    at h$runThreadSlice (rts.js:6847)
    at h$runThreadSliceCatch (rts.js:6814)
    at h$mainLoop (rts.js:6809)
    at rts.js:2190
    at runIfPresent (rts.js:2204)
    at onGlobalMessage (rts.js:2240)

Note that the function we need is not defined. This happens because the element script with a link is created dynamically, as well as in general all page elements. So when we use the function call flatpickr, the script containing the library with this function may not be loaded yet. It is necessary to clearly arrange the order of loading.
Let’s solve this problem with the package reflex-dom-contrib… This package contains many useful features for development. Its connection is non-trivial. The fact is that on Hackage there is an outdated version of this package, so you will have to take it directly from Github… Let’s update default.nix in the following way.

{ reflex-platform ? ((import <nixpkgs> {}).fetchFromGitHub {
    owner = "reflex-frp";
    repo = "reflex-platform";
    rev = "efc6d923c633207d18bd4d8cae3e20110a377864";
    sha256 = "121rmnkx8nwiy96ipfyyv6vrgysv0zpr2br46y70zf4d0y1h1lz5";
    })
}:
(import reflex-platform {}).project ({ pkgs, ... }:
let
  reflexDomContribSrc = builtins.fetchGit {
    url = "https://github.com/reflex-frp/reflex-dom-contrib.git";
    rev = "11db20865fd275362be9ea099ef88ded425789e7";
  };

  override = self: pkg: with pkgs.haskell.lib;
  doJailbreak (pkg.overrideAttrs
  (old: {
    buildInputs = old.buildInputs ++ [ self.doctest self.cabal-doctest ];
  }));

in {
  useWarp = true;

  overrides = self: super: with pkgs.haskell.lib; rec {
    reflex-dom-contrib = dontHaddock (override self
      (self.callCabal2nix "reflex-dom-contrib" reflexDomContribSrc { }));
  };

  packages = {
    todo-common = ./todo-common;
    todo-server = ./todo-server;
    todo-client = ./todo-client;
  };

  shells = {
    ghc = ["todo-common" "todo-server" "todo-client"];
    ghcjs = ["todo-common" "todo-client"];
  };
})

Add module import import Reflex.Dom.Contrib.Widgets.ScriptDependent and make changes to the form:

newTodoForm :: MonadWidget t m => m (Event t (Endo Todos))
newTodoForm = rowWrapper $ el "form" $ divClass "input-group" $ mdo
  iEl <- inputElement $ def
    & initialAttributes .~
      (  "type" =: "text"
      <> "class" =: "form-control"
      <> "placeholder" =: "Todo" )
    & inputElementConfig_setValue .~ ("" <$ btnEv)
  dEl <- inputElement $ def
    & initialAttributes .~
      (  "type" =: "text"
      <> "class" =: "form-control"
      <> "placeholder" =: "Deadline"
      <> "style" =: "max-width: 150px" )
  pb <- getPostBuild
  widgetHoldUntilDefined "flatpickr"
    (pb $> "https://cdn.jsdelivr.net/npm/flatpickr")
    blank
    (addDatePicker dEl)
  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
  pure $ tagPromptlyDyn newTodoDyn $ domEvent Click btnEl

We’ve taken advantage of a new feature widgetHoldUntilDefined, which will build the element passed to it in the last parameter, only at the moment when the specified script is loaded.
Now, if we load our page obtained with GHCJSwe will see the datepicker we are using.

But we did not use this field in any way. Change the type Todowithout forgetting to add import Data.Time:

data Todo = Todo
  { todoText     :: Text
  , todoDeadline :: Day
  , todoState    :: TodoState }
  deriving (Generic, Eq, Show)

newTodo :: Text -> Day -> Todo
newTodo todoText todoDeadline = Todo {todoState = TodoActive False, ..}

Now let’s change the function with the form for a new task:

...
  today <- utctDay <$> liftIO getCurrentTime
  let
    dateStrDyn = value dEl
    dateDyn = fromMaybe today . parseTimeM True
      defaultTimeLocale "%Y-%m-%d" . unpack <$> dateStrDyn
    addNewTodo = todo date -> Endo $ todos ->
      insert (nextKey todos) (newTodo todo date) todos
    newTodoDyn = addNewTodo <$> value iEl <*> dateDyn
    btnAttr = "class" =: "btn btn-outline-secondary"
      <> "type" =: "button"
...

And add the date display in the list:

todoActive
  :: (EventWriter t (Endo Todos) m, MonadWidget t m)
  => Int -> Text -> Day -> m ()
todoActive ix todoText deadline = divClass "d-flex border-bottom" $ do
  elClass "p" "p-2 flex-grow-1 my-auto" $ do
    text todoText
    elClass "span" "badge badge-secondary px-2" $
      text $ pack $ formatTime defaultTimeLocale "%F" deadline
  divClass "p-2 btn-group" $ do
  ...

The result, as always, can be viewed in our repository

In the next part, we will look at how to implement routing in a Reflex application.

Similar Posts

Leave a Reply

Your email address will not be published. Required fields are marked *