Creating a Haskell Application Using Reflex. Part 4

Part 1

Part 2

Part 3

Hi there! In our new post, we’ll take a look at how we use JSFFI.

JSFFI

Let’s make it possible to set a deadline date in our application. Suppose that we need to make not just the text input, but a dropdown datepicker. Of course, we can write our own datepicker in Reflex but there are lots of various JS libraries we could use. If there exists an off-the-shelf JS code which is, for instance, too long to be rewritten using GHCJS, it’s possible to call it using JSFFI (JavaScript Foreign Function Interface). In our case, we’ll use flatpickr.

Let’s create a new JSFFI module and immediately add its import to the Main. We insert the following code in 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

Let’s not forget to add the required script and styles to the head element too:

  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

Now we try to compile the same way as before and 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’re building our application using GHC that has no idea of what JSFFI is. Recall that now the server is being launched that sends the updated DOM when this is needed using web sockets, and the JavaScript code is alien to it. The conclusion suggests itself that our datepicker just doesn’t work when you build using GHC. Nevertheless, GHC won’t be used to build the client’s application production version; we’ll compile to JS using GHCJS and embed the JS code we’ve obtained into our page. ghcid doesn’t support GHCJS, which is why it makes no sense to run nix shell; we’ll use nix immediately for our build:

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

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

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

After opening the index.html in the browser we’ll see our application. Though we’ve built our project using GHCJS, it’s more convenient to carry out development using GHC together with ghcid, which is why we’ll modify the JSFFI module in the following way:

{-# 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’ve added conditional compilation: depending on the platform, we’ll use either the JS function call or a stub.

Now we need to change the input form for new tasks by adding the 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

We compile our application, try to run it and still see nothing. If we have a look at the developer console in the browser, we’ll 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)

Here we notice that the function we need is not defined. This is because the element script with the link, as well as every single element of the page are created dynamically. That’s why when we call the flatpickr function, the script containing the library with this function might be not loaded yet. Obviously, we need to set the loading order. Let’s solve this issue using the package reflex-dom-contrib. This package includes many functions useful for development. Adding this dependency is non-trivial. The thing is that Hackage offers an obsolete version of this package, which is why we 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"];
  };
})

We add the import of module import Reflex.Dom.Contrib.Widgets.ScriptDependent and make changes in 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 used the new function widgetHoldUntilDefined that will build the element passed to it in the last parameter only when the defined script has already been downloaded. Now, if we open our page created using GHCJS we’ll see the datepicker we use.

However, we’ve not used this field in any way. Let’s change the type Todo making sure that we’ve added the import of 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 we 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 to the list item widget:

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
  ...

As usual, the result we’ve got can be found in our repository.

In the next part, we’ll see how to use routing in a Reflex-based application.