Posted on June 22, 2021 by Nikita Anisimov

Creating a Haskell Application Using Reflex. Part 4

In this post, we discuss using JSFFI (JS Foreign Function Interface)

Part 1

Part 2

Part 3

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

Widget preview

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.

Recommended

You may also like

Want to know more?
Get in touch with us!
Contact Us

Privacy policy

Last updated: 1 September 2021

Typeable OU ("us", "we", or "our") operates https://typeable.io (the "Site"). This page informs you of our policies regarding the collection, use and disclosure of Personal Information we receive from users of the Site.

We use your Personal Information only for providing and improving the Site. By using the Site, you agree to the collection and use of information in accordance with this policy.

Information Collection And Use

While using our Site, we may ask you to provide us with certain personally identifiable information that can be used to contact or identify you. Personally identifiable information may include, but is not limited to your name ("Personal Information").

Log Data

Like many site operators, we collect information that your browser sends whenever you visit our Site ("Log Data").

This Log Data may include information such as your computer's Internet Protocol ("IP") address, browser type, browser version, the pages of our Site that you visit, the time and date of your visit, the time spent on those pages and other statistics.

In addition, we may use third party services such as Google Analytics that collect, monitor and analyze this ...

Cookies

Cookies are files with small amount of data, which may include an anonymous unique identifier. Cookies are sent to your browser from a web site and stored on your computer's hard drive.

Like many sites, we use "cookies" to collect information. You can instruct your browser to refuse all cookies or to indicate when a cookie is being sent. However, if you do not accept cookies, you may not be able to use some portions of our Site.

Security

The security of your Personal Information is important to us, so we don't store any personal information and use third-party GDPR-compliant services to store contact data supplied with a "Contact Us" form and job applications data, suplied via "Careers" page.

Changes To This Privacy Policy

This Privacy Policy is effective as of @@privacePolicyDate​ and will remain in effect except with respect to any changes in its provisions in the future, which will be in effect immediately after being posted on this page.

We reserve the right to update or change our Privacy Policy at any time and you should check this Privacy Policy periodically. Your continued use of the Service after we post any modifications to the Privacy Policy on this page will constitute your acknowledgment of the modifications and your consent to abide and be bound by the modified Privacy Policy.

If we make any material changes to this Privacy Policy, we will notify you either through the email address you have provided us, or by placing a prominent notice on our website.

Contact Us

If you have any questions about this Privacy Policy, please contact us.