Note

Some of the information here is outdated. Follow the installation instructions in the README. Using a virtual machine is no longer recommended and the ghcjs-build repository is no longer maintained.

Updated examples can be found in the ghcjs-examples repository, or click the source link. The safety specifications in the JavaScript foreign function interface have been changed slightly, see GHCJS.Foreign for more information. In particular, you need "interruptible" instead of "safe" for asynchronous imports.

Introduction

Since the last post we have made a number of changes to GHCJS. Dan Frumin, who is using GHCJS for his Google Summer of Code project, has contributed an improved build script. Hamish Mackenzie has ported an initial version of ghcjs-dom to our new code generator. Ghcjs-dom contains generated bindings for the DOM API that allow you to write applications that run in the browser with GHCJS, but also as native code, with a webkit frame.

I have added travis support to the repository, so our test suite will be run for every commit and pull request to the GHCJS and shims repositories. I have also updated the prebuilt vagrant virtual machine image to incorporate the latest bugfixes and updates to ByteArray# and pointers.

This time we are going to be looking at functional reactive programming for the web. Since GHCJS has a full-featured Haskell runtime, with support for threading, async exceptions and STM, any existing FRP library should work. We will be using sodium for the examples. If you have trouble getting your favourite FRP library to work with GHCJS, you can contact us on IRC (#ghcjs on freenode), the mailing list, or file a bug report.

Quick start

Since GHCJS depends on GHC HEAD and Cabal, with a few patches that have not yet been merged, the easiest way to get started is with a vagrant virtual machine:

$ git clone https://github.com/ghcjs/ghcjs-build.git
$ cd ghcjs-build
$ git checkout prebuilt
$ vagrant up

Log into the virtual machine with:

$ vagrant ssh

You can find the examples in /home/vagrant/ghcjs-examples/weblog. To view the result in the browser, start the preinstalled warp web server on the virtual machine with

$ vagrant ssh -c warp

and go to http://localhost:3030/ghcjs-examples/weblog/ (Warp listens on port 3000, Vagrant is configured to forward port 3030 of the host machine to that).

For more information and other installation options, see the GHCJS introduction post on this weblog.

Events and behaviours

Functional reactive programming is based on two composable abstractions: behaviours (time-varying values) and events (happening at discrete points in time). Sodium is a simple push-based library that implements these abstractions: Everything is driven by something pushing a new value to a behaviour or firing a new event.

Note that sodium depends on weak references to clean up unused events. If you want to customize GHCJS’ memory management, do not disable the heap scanner completely if you often create new behaviours and events.

Let’s get started with a simple example. First we create a button that fires an event every time it’s clicked. We count the number of events using sodium’s built-in count behaviour. Finally, we listen to the values in this behaviour and update the text in counterDiv after a change:

-- run code: http://hdiff.luite.com/ghcjs/examples/counter/
-- full source: https://github.com/ghcjs/ghcjs-examples/blob/master/weblog/counter/counter.hs
{-# LANGUAGE OverloadedStrings #-}

module Main where

import           Control.Monad
import           Control.Monad.IO.Class
import           Data.Default
import           Data.Text (Text)
import qualified Data.Text as T

import           JavaScript.JQuery hiding (Event)

import           FRP.Sodium

main :: IO ()
main = do
  body <- select "body"
  buttonEvent <- reactiveButton "Click Me!" body
  counterDiv <- select "<div />"
  appendJQuery counterDiv body
  sync $ do
    counter <- count buttonEvent
    listen (values counter) (\n -> void $
            setText (T.pack . show $ n) counterDiv)
  return ()

reactiveButton :: Text -> JQuery -> IO (Event ())
reactiveButton label parent = do
  (evt, a) <- sync newEvent
  button <- select "<button />"
  setText label button
  appendJQuery button parent
  let handler _ = sync (a ())
  on handler "click" def button
  return evt

Since we use ghcjs-jquery to add the user interface elements, we need to load the jQuery library in our HTML file, also we need some CSS for the examples:

<!DOCTYPE html>
<html>
  <head>
    <script language="javascript" src="//ajax.googleapis.com/ajax/libs/jquery/1.10.1/jquery.min.js"></script>
    <script language="javascript" src="lib.js"></script>
    <script language="javascript" src="rts.js"></script>
    <script language="javascript" src="lib1.js"></script>
    <script language="javascript" src="out.js"></script>
    <style type="text/css"> html, body { width: 100%; height: 100%; margin: 0; padding: 0; }</style>
  </head>
  <body>
  </body>
  <script language="javascript">

h$main(h$mainZCMainzimain);

  </script>
</html>

We will use the same HTML throughout this weblog post.

Button clicks are a typical Event, since they happen at discrete points in time, but many user interface elements have values that change over time. These are better modeled with a Behaviour. The next example uses text input fields and a select menu as reactive elements:

-- run code: http://hdiff.luite.com/ghcjs/examples/calculator/
-- full source: https://github.com/ghcjs/ghcjs-examples/blob/master/weblog/calculator/calculator.hs
-- begin collapse
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables      #-}

module Main where

import           Control.Applicative
import           Control.Monad
import           Data.Default
import           Data.Text (Text)
import qualified Data.Text as T
import           Text.Read

import           JavaScript.JQuery

import           FRP.Sodium
-- end collapse

main :: IO ()
main = do
  body <-       select "body"
  [op1, op2] <- replicateM 2 $
     fmap (fmap (readMaybe . T.unpack)) (reactiveTextInput "0" body)
  let items = [ ("add"     , arithBehaviour op1 op2 (+))
              , ("multiply", arithBehaviour op1 op2 (*))
              ]
  sel <- reactiveSelect items body
  output <- select "<div />"
  appendJQuery output body
  sync $ do
    result <- switch sel
    listen (values result) $ \v -> void $
      setText (maybe "invalid input" (T.pack.show) v) output
  return ()

arithBehaviour :: Behaviour (Maybe Integer)
               -> Behaviour (Maybe Integer)
               -> (Integer -> Integer -> Integer)
               -> Behaviour (Maybe Integer)
arithBehaviour op1 op2 f = liftA2 f <$> op1 <*> op2

reactiveTextInput :: Text -> JQuery -> IO (Behaviour Text)
reactiveTextInput value parent = do
-- begin collapse
  (b, a) <- sync (newBehaviour value)
  input <- select "<input type='text' />"
  setVal value input
  appendJQuery input parent
  let handler _ = sync . a =<< getVal input
  on handler "keyup change" def input
  return b
-- end collapse

reactiveSelect :: [(Text,a)] -> JQuery -> IO (Behaviour a)
reactiveSelect items parent = do
-- begin collapse
  (b, a) <- sync (newBehaviour . snd . head $ items)
  sel <- select "<select />"
  forM_ (zip [(0::Int)..] items) $ \(n,(name,_)) -> do
    opt <- select "<option />"
    setAttr "value" (T.pack . show $ n) opt
    when (n == 0) $ void (setAttr "selected" "true" opt)
    setText name opt
    appendJQuery opt sel
  appendJQuery sel parent
  let handler _ = sync . a =<< snd.(items !!).read.T.unpack <$> getVal sel
  on handler "change" def sel
  return b
-- end collapse

The text input field is of type Behaviour Text, it has a time-dependent text value, which gets updated by handling the keyup and change JavaScript events on the HTML input element with jQuery.

The select menu is polymorphic: Every menu item has a label an a value of type a. The values can themselves be Behaviours: In the example, every value is a Behaviour (Maybe Integer). We use sodium’s switch function to create a new Behaviour that dynamically switches between multiplying and adding the numbers.

Beside sodium’s built-in primitives, the most important way to work with Behaviours is their Applicative instance. We use this in the example to combine the values of the two operands into a new Behaviour (Actually we use Applicative twice! One more time to lift the operator from Integer -> Integer -> Integer to Maybe Integer -> Maybe Integer -> Maybe Integer).

Handling mouse input

Not only form elements can be a behaviour. In the next example, we have the current mouse pointer position as a Behaviour (Double, Double), indicating the distance in pixels from the top left corner of the document.

Open the example and move your mouse pointer over the page. The changes of the mouse Behaviour automatically trigger updates of the position of the objects. Again we use the Applicative instance for Behaviour to combine two inputs: The time (derived from the mouse position) and the position of the parent object.

-- run code: http://hdiff.luite.com/ghcjs/examples/mouse/
-- full source: https://github.com/ghcjs/ghcjs-examples/blob/master/weblog/mouse/mouse.hs
-- begin collapse
{-# LANGUAGE CPP, JavaScriptFFI, ForeignFunctionInterface,
             EmptyDataDecls, OverloadedStrings,
             ScopedTypeVariables
  #-}
module Main where

import           Control.Applicative
import           Data.Default
import           Data.Text (Text)
import qualified Data.Text as T

import           GHCJS.Types
import           GHCJS.Foreign
import           GHCJS.Marshal
import           JavaScript.JQuery

import           FRP.Sodium

#ifdef __GHCJS__
-- create an element in the SVG namespace
foreign import javascript unsafe "document.createElementNS('http://www.w3.org/2000/svg',$1)"
   createSvg :: JSString -> IO Element
foreign import javascript unsafe "document.getElementsByTagName($1)"
   getElementsByTagName :: JSString -> IO (JSArray a)
foreign import javascript unsafe "$3.setAttribute($1,$2)"
   setAttribute :: JSString -> JSRef a -> JSRef b -> IO ()
foreign import javascript unsafe "$2.appendChild($1)"
   appendChild :: Element -> Element -> IO ()
#else
createSvg = undefined
appendChild = undefined
getElementsByTagName = undefined
setAttribute = undefined
#endif

setAttribute' :: ToJSRef a => JSString -> a -> JSRef b -> IO ()
setAttribute' a v o = toJSRef v >>= \v' -> setAttribute a v' o
-- end collapse

main = do
  body <- indexArray 0 =<< getElementsByTagName "body"
  svg <- createSvg "svg"
  appendChild svg body
  setAttribute' "width" (400::Int) svg >> setAttribute' "height" (400::Int) svg
  t <- fmap ((*5) . fst) <$> mousePosition body
  let sun   = pure (200, 200)
      earth = object (1/365) 150 sun   t
      moon  = object (1/30)  25  earth t
  drawObject svg "yellow" 20 sun
  drawObject svg "blue"   8  earth
  drawObject svg "grey"   3  moon

object :: Double
       -> Double
       -> Behaviour (Double, Double)
       -> Behaviour Double
       -> (Behaviour (Double, Double))
object speed r center time =
   (,) <$> liftA2 xpos center time <*> liftA2 ypos center time
     where
       xpos (x,_) t = x + r * cos (speed * t)
       ypos (_,y) t = y + r * sin (speed * t)

drawObject :: Element -> Text -> Double -> Behaviour (Double, Double) -> IO ()
drawObject parent color r x = do
  putStrLn (T.unpack color)
  circle <- createSvg "circle"
  let p .= v = setAttribute' p v circle
  "fill" .= color >> "r" .= r
  appendChild circle parent
  sync $ listen (values x) $
    \(x,y) -> "cx" .= x >> "cy" .= y
  return ()

mousePosition :: Element -> IO (Behaviour (Double, Double))
mousePosition elem = do
  (b, push) <- sync $ newBehaviour (0,0)
  let handler ev = do
        x <- pageX ev
        y <- pageY ev
        sync $ push (x,y)
  on handler "mousemove" def =<< selectElement elem
  return b

Timers and animation

So far, all events we have seen were caused directly by user input from the keyboard or mouse. In the next example we will see an external (timer) event source and behaviours with an internal state to do a simple (mostly incorrect) physics simulation of balls being attracted to your mouse pointer.

If you compile the example yourself, you need to have ball.png in your executable directory, in addition to the index.html listed above.

Main creates 10 balls, displayed as absolutely positioned image elements. After that, it enters a main loop, which repeatedly fires a stepper event that contains the time elapsed since the last event. The event is combined with the current mouse position and browser window size, using the snapshotWith primitive, which samples the current value of a behaviour at the time an event fires.

After each stepper update, the loop calls threadDelay 1, which lets the Haskell scheduler yield briefly (since we don’t have any other runnable Haskell threads), to let the browser redraw the window and process new mouse events.

The balls themselves use sodium’s collectE primitive to listen for timestep events, updating the postion and velocity of the ball’s internal state by doing a simple numerical integration step. Externally, only the position is visible.

The number of steps per second depends on the browser and the machine it runs on, therefore the update function uses the time value in the event, the number of milliseconds since the last event, to determine the step size, making the acceleration and velocity of the balls mostly independent of the machine and browser (faster updates, and thus smaller steps, still result in a slightly more accurate simulation).

-- run code: http://hdiff.luite.com/ghcjs/examples/balls1/
-- full source: https://github.com/ghcjs/ghcjs-examples/blob/master/weblog/balls1/balls1.hs
-- begin collapse
{-# LANGUAGE CPP, OverloadedStrings, TypeFamilies, JavaScriptFFI #-}

module Main where

import           Control.Applicative
import           Control.Concurrent
import           Control.Monad
import           Data.Default
import           Data.VectorSpace
import           System.Random

import           FRP.Sodium

import           JavaScript.JQuery hiding (Event)
import           GHCJS.Types
import           GHCJS.Foreign

#ifdef __GHCJS__
foreign import javascript unsafe "Date.now()"
  now :: IO Double
foreign import javascript unsafe "$3.css($1,$2+'px')"
  setCssPx :: JSString -> Double -> JQuery -> IO ()
#else
now            = return 0
setCssPx _ _ _ = undefined
#endif

data R2 = R2 { _x :: Double, _y :: Double }
  deriving (Show, Eq, Ord)

instance AdditiveGroup R2 where
  zeroV = R2 0 0
  R2 x1 y1 ^+^ R2 x2 y2 = R2 (x1+x2) (y1+y2)
  negateV (R2 x y) = R2 (negate x) (negate y)

instance VectorSpace R2 where
  type Scalar R2 = Double
  s *^ (R2 x y) = R2 (s*x) (s*y)

instance InnerSpace R2 where
  (R2 x1 y1) <.> (R2 x2 y2) = (x1*x2)+(y1*y2)
-- end collapse

main :: IO ()
main = do
  body <- select "body"
  bodySize <- size body
  mouse <- mousePosition body
  startSize <- sync (sample bodySize)
  (stepper, pushStepper) <- sync newEvent
  let stepper' = snapshotWith (,) stepper ((,) <$> mouse <*> bodySize)
  replicateM_ 10 (startPos bodySize >>= \start -> ball body start stepper')
  let step t0 = do
        t1 <- now
        sync (pushStepper $ t1-t0)
        threadDelay 1
        step t1
  step =<< now

startPos :: Behaviour R2 -> IO R2
startPos size = do
  R2 mx my <- sync (sample size)
  R2 <$> randomRIO (0,mx) <*> randomRIO (0,my)

ball :: JQuery
     -> R2
     -> Event (Double, (R2, R2))
     -> IO (Behaviour R2)
ball parent startPos step = do
  b <- select "<img src='ball.png' width='25' height='25' />"
  setCss "position" "absolute" b
  appendJQuery b parent
  let updCss prop f x = void (setCssPx prop (f x) b)
  pos <- sync (hold startPos =<< collectE upd initial step)
  sync (listen (values pos) $ \x -> updCss "left" _x x >> updCss "top" _y x)
  return pos
    where
      initial = (startPos, R2 0 0)
      upd (dt,(m,s)) (x,v) =
        let r          = m ^-^ x
            a          = (5 * recip (300 + magnitudeSq r)) *^ normalized r
            t@(x', v') = clamp s 25 (x ^+^ (dt *^ v)) ((0.9995 ** dt) *^ (v ^+^ (dt *^ a)))
        in  (x',t)

clamp :: R2 -> Double -> R2 -> R2 -> (R2, R2)
clamp size objSize x v = (R2 xx xy, R2 vx vy)
  where
    (xx, vx) = clamp' _x
    (xy, vy) = clamp' _y
    clamp' f
      | x' < 0    = (-x', abs v')
      | x' > m    = (2 * m - x', negate (abs v'))
      | otherwise = (x', v')
      where
        x' = f x
        v' = f v
        m  = f size - objSize

-- size of the element, in pixels
size :: JQuery -> IO (Behaviour R2)
size elem = do
-- begin collapse
  (b, push) <- sync . newBehaviour =<< dims
  let handler _ = sync . push =<< dims
  on handler "resize" def elem
  return b
    where
      dims = R2 <$> getWidth elem
                <*> getHeight elem
-- end collapse

-- the mouse position, in pixels from the top-left corner
mousePosition :: JQuery -> IO (Behaviour R2)
mousePosition elem = do
-- begin collapse
  (b, push) <- sync $ newBehaviour (R2 0 0)
  let handler ev = do
        x <- pageX ev
        y <- pageY ev
        sync $ push (R2 x y)
  on handler "mousemove" def elem
  return b
-- end collapse

Note that we use some foreign imports, getting the current time as a Double, and updating the CSS position of an element through jQuery. In both cases, we could have used existing functions like Data.Time.Clock.getCurrentTime and JavaScript.JQuery.setCss with the Show instance for Double to get the same result.

These functions are both supported but go through a lot of code: getCurrentTime uses emulation for the POSIX gettimeofday call, instance Show Double decodes the floating point to a significand and exponent, using Integer under the hood.

Since we run this from the animation loop, this affects the performance of our program. Fortunately, importing the lighter weight JavaScript alternatives can be done in just a few lines of code.

Smoother animation with requestAnimationFrame

The above example uses a loop in Haskell to trigger each animation step, calling threadDelay every iteration. While this works, it does not always result in a smooth animation: The updates are not synchronized with browser redraws, and the GHCJS scheduler uses JavaScript’s setTimeout function to reschedule itself, which can be a bit unpredictable in the time it takes for this.

Modern browsers support a better alternative: The window.requestAnimationFrame method (unfortunately the name is not standardized across browsers, so we have to test for a few different names) lets the browser run a JavaScript function just before the window is repainted. We can use this function to call back into Haskell and let sodium run one animation step.

GHCJS has two different ways to let JavaScript call back into Haskell code. Asynchronous callbacks (run directly with h$run or create from Haskell with GHCJS.Foreign.asyncCallback) start a regular Haskell thread in the background. The callback itself returns immediately.

For the animation here, we don’t want an asynchronous callback: The function used with requestAnimationFrame should perform an animation step immediately, updating all objects before returning. The other option, a synchronous callback, does exactly that. Synchronous code is more limited than asynchronous code: The callback will return immediately when the Haskell code tries to do an operation that would block (for example taking an empty MVar, or doing an asynchronous blocking FFI operation).

In the example below, it is possible that the thread blocks when trying run sync, since sodium uses an MVar lock internally. We can choose what happens when a synchronous thread blocks: Either the thread is aborted immediately, or it continues running asynchronously. Here we choose to abort the thread: The animation frame is simply dropped when something is holding the FRP lock.

-- run code: http://hdiff.luite.com/ghcjs/examples/balls2/
-- full source: https://github.com/ghcjs/ghcjs-examples/blob/master/weblog/balls2/balls2.hs
-- begin collapse
{-# LANGUAGE CPP, OverloadedStrings, TypeFamilies, JavaScriptFFI #-}

module Main where

import           Control.Applicative
import           Control.Monad
import           Data.Default
import           Data.IORef
import           Data.VectorSpace
import           System.Random

import           FRP.Sodium

import           JavaScript.JQuery hiding (Event)
import           GHCJS.Types
import           GHCJS.Foreign

#ifdef __GHCJS__
foreign import javascript unsafe "Date.now()" now :: IO Double
foreign import javascript unsafe "$3.css($1,$2+'px')"
  setCssPx :: JSString -> Double -> JQuery -> IO ()
-- end collapse
foreign import javascript unsafe
  "var req = window.requestAnimationFrame ||\
             window.mozRequestAnimationFrame ||\
             window.webkitRequestAnimationFrame ||\
             window.msRequestAnimationFrame;\
   var f = function() { $1(); req(f); };\
   req(f);" -- fixstr "
  animate :: JSFun (IO ()) -> IO ()
-- begin collapse
#else
now            = return 0
setCssPx _ _ _ = undefined
animate _      = undefined
#endif

data R2 = R2 { _x :: Double, _y :: Double }
  deriving (Show, Eq, Ord)

instance AdditiveGroup R2 where
  zeroV = R2 0 0
  R2 x1 y1 ^+^ R2 x2 y2 = R2 (x1+x2) (y1+y2)
  negateV (R2 x y) = R2 (negate x) (negate y)

instance VectorSpace R2 where
  type Scalar R2 = Double
  s *^ (R2 x y) = R2 (s*x) (s*y)

instance InnerSpace R2 where
  (R2 x1 y1) <.> (R2 x2 y2) = (x1*x2)+(y1*y2)
-- end collapse

main :: IO ()
main = do
  body <- select "body"
  bodySize <- size body
  mouse <- mousePosition body
  startSize <- sync (sample bodySize)
  (stepper, pushStepper) <- sync newEvent
  let stepper' = snapshotWith (,) stepper ((,) <$> mouse <*> bodySize)
  replicateM_ 10 (startPos bodySize >>= \start -> ball body start stepper')
  t <- newIORef =<< now
  let step = do
        t0 <- readIORef t
        t1 <- now
        sync (pushStepper $ t1-t0)
        writeIORef t t1
  animate =<< syncCallback False step

-- begin collapse
startPos :: Behaviour R2 -> IO R2
startPos size = do
  R2 mx my <- sync (sample size)
  R2 <$> randomRIO (0,mx) <*> randomRIO (0,my)

ball :: JQuery
     -> R2
     -> Event (Double, (R2, R2))
     -> IO (Behaviour R2)
ball parent startPos step = do
  b <- select "<img src='ball.png' width='25' height='25' />"
  setCss "position" "absolute" b
  appendJQuery b parent
  let updCss prop f x = void (setCssPx prop (f x) b)
  pos <- sync (hold startPos =<< collectE upd initial step)
  sync (listen (values pos) $ \x -> updCss "left" _x x >> updCss "top" _y x)
  return pos
    where
      initial = (startPos, R2 0 0)
      upd (dt,(m,s)) (x,v) =
        let r          = m ^-^ x
            a          = (5 * recip (300 + magnitudeSq r)) *^ normalized r
            t@(x', v') = clamp s 25 (x ^+^ (dt *^ v)) ((0.9995 ** dt) *^ (v ^+^ (dt *^ a)))
        in  (x',t)

clamp :: R2 -> Double -> R2 -> R2 -> (R2, R2)
clamp size objSize x v = (R2 xx xy, R2 vx vy)
  where
    (xx, vx) = clamp' _x
    (xy, vy) = clamp' _y
    clamp' f
      | x' < 0    = (-x', abs v')
      | x' > m    = (2 * m - x', negate (abs v'))
      | otherwise = (x', v')
      where
        x' = f x
        v' = f v
        m  = f size - objSize

-- size of the element, in pixels
size :: JQuery -> IO (Behaviour R2)
size elem = do
  (b, push) <- sync . newBehaviour =<< dims
  let handler _ = sync . push =<< dims
  on handler "resize" def elem
  return b
    where
      dims = R2 <$> getWidth elem
                <*> getHeight elem

-- the mouse position, in pixels from the top-left corner
mousePosition :: JQuery -> IO (Behaviour R2)
mousePosition elem = do
  (b, push) <- sync $ newBehaviour (R2 0 0)
  let handler ev = do
        x <- pageX ev
        y <- pageY ev
        sync $ push (R2 x y)
  on handler "mousemove" def elem
  return b
-- end collapse

Conclusion

We have seen several examples of functional reactive programming with GHCJS, handling user input and doing animations. Unfortunately for all of the examples we had to do some low-level work ourselves: Setting up mouse event handlers, adding HTML elements to the document. Even though Haskell and GHCJS make these steps relatively easy, we would really like to build a functional reactive user interface library that does this for us, with a collection of ready-made reactive widgets and a declarative way to set up the user interface.

If you have ideas on how to structure such a library, or are interested in helping, please comment, post to the mailing list, or join us on IRC in #ghcjs on freenode.