geraldus commented 10 years ago

Rewritten at 2nd of March, 2014

Authors preface

This is first the edition of my tutorial. Please excuse me my poor English. I'll be happy if you can help make my text more readable. Also the code itself could be affected by imperative style. Please leave your comments and recommendations if you want.

This tutorial shows:

how to use Sodium's merge and switch primitives;
how to listen "external" javascript events using GHCJS;
how to combine GHCJS and Sodium to create functional reactive ui in browser.
Overview

We'll see a simple web application, which consist of single HTML page. There are page header, some content, hidden popup window and triggers which opens that popup.

2014-02-23 19 24 24

When you click a trigger popup appears. There are duplicated triggers and close button inside popup.

2014-02-23 19 31 06

To design UI logics we'll use Sodium. The idea adopted from Sodium's presentation:

2014-02-23 19 40 51 2014-02-23 19 41 04 2014-02-23 19 41 25

In our case javascript click events on triggers represent button events, selected tabs represent channels and closed popup represents the fuzz.

Data Types

Let's design data types:

data DomElement_ = DomElement_
type DomElement  = JSRef DomElement_

data PopupTab    = PopupTab { exTrigger :: DomElement
                            , inTrigger :: DomElement
                            , content   :: DomElement
                            }

data PopupWidget = PopupWidget { window :: DomElement
                               , closeB :: DomElement
                               , tabs   :: [PopupTab]
                               }

PopupTab consist of external trigger (which is outside the popup window), internal trigger and element with content. PopupWidget is consist of window which is widget itself, closeB which is just a quick reference to button that closes popup, and tabs which is a quick reference to widget tabs.

Here is HTML code of widget:

<div id="popup" class="Dn Pos-A Plate">
     <div id="ppp-close" class="trigger">Close</div>

     <div id="ppp-nav">
          <div id="item-about" class="trigger">About Us</div>
          <div id="item-contacts" class="trigger">Contacts</div>
          <div id="item-service" class="trigger">Centers of Service</div>
          <div id="item-book-measure" class="trigger">Book Measure</div>
     </div>

     <div id="ppp-content">
          <div id="content-about" class="content">Lorem ipsum dolor sit amet.</div>
          <div id="content-contacts" class="content">
               Tel: +1-234-567-890
               </br>
           Address: Ap.01, Reactive Street, UI Town, Sodium.
          </div>
          <div id="content-service" class="content">Aliquam tortor dolor, sodales sed suscipit eget, porta non nulla.</div>
          <div id="content-book-measure" class="content">Donec sodales tortor quis ante mattis, at aliquet magna pretium.</div>
     </div>
</div>

Thus, we need a list of evens with pushing functions, a list of behaviors of PopupTab and our fuzz analogue. We'll use Maybe PopupTab type to represent our channels and fuzz, e.g. for closed popup window the value would be Nothing and for selected tab it will be Just value with concrete tab inside.

We'll split our final goal into four tasks:

design reactive logic;
find DOM elements on the page;
bind handlers to real javascript click events;
render changes.
Reactive Logic

To separate reactive code from IO let's design a function which takes a list of events, its pushing functions and popup widget and which returns a behavior of type Behavior (Maybe PopupTab). Then we'll listen value of that behavior and render our UI depending on its value. Sodium's newEvent function returns an event paired with it's pushing function it's so we'll use one list of pairs, e.g. [(Event a, a -> Reactive ())]. Here is our reactive code (please read comments):

mkEvents :: Int -> IO [(Event a, a -> Reactive ())]
mkEvents n = sync $ replicateM n newEvent

mkReactiveUi :: PopupWidget
               -> [(Event a, a -> Reactive ())]
               -> Reactive (Behavior (Maybe PopupTab))
mkReactiveUi pppw es = do
    let closeBhv = pure (Nothing :: Maybe PopupTab)
    items' <- mapM (\t -> newBehavior (Just t) >>= return . fst) $ tabs pppw

    -- `items` is a list of behaviors which constantly holds Maybe values for hidden state
    -- of popup and all states when concrete tab is selected. 
    let items = closeBhv:items'

    -- Fetching only events itself from pairs. They are click events.
    events <- mapM (return . fst) es

    -- Now we map each state to events (clicks).
    -- The result is events of type `Event (Bahavior (Maybe PopupTab))`.
    -- These are state events.
    -- When we'll push new value to concrete stream of click events we'll have
    -- a new value in resulting stream of state events holding corresponding behavior. 
    let eItems = zipWith (\i e -> fmap (const i) e) items events

    -- Then we creating a new behavior which will hold concrete state of our widget.
    -- We'll use special event stream for this behavior, which is merged streams
    -- of state events.
    -- This means that when we have a new value in any of state streams of
    -- merged stream immediately gets this value too.
    sel <- hold closeBhv $ mergeFold eItems

    -- Now we have a Behavior of Behavior, and all we need is to unwrap the last one!
    -- Let's name it "selector".
    ui <- switch sel
    return ui
  where mergeFold :: [Event a] -> Event a
        mergeFold es = foldl1 merge es

So, we have a click events (of type Event ()). Our reactive logic will work this way:

When javascript registers click on the trigger it pushes new value to corresponding click stream. Corresponding state stream reacts to new click event occurrence, and new event with corresponding state behavior occurs in state stream (this behavior constantly holds value of Maybe PopupTab). As mentioned in comments merged event stream reacts on that occurrence, actually pushing new behavior to selector (namely sel). When all this will happen our UI behavior will get new value, which is current state.

Great! Now we have the first piece!

Finding DOM Elements

This task is quite easy, and I think detailed explanations are unnecessarily. (However if you'll ask I can explain it a bit.) The code is quite obvious itself:

foreign import javascript unsafe "document.getElementById($1)"
    js_getElementById :: JSString -> IO DomElement
getElementById :: String -> IO DomElement
getElementById = js_getElementById . toJSString

foreign import javascript unsafe "$1.getElementsByClassName($2)"
    js_getChilrenByClass :: DomElement -> JSString -> IO (JSArray DomElement_)
getChildrenByClass :: DomElement -> String -> IO (JSArray DomElement_)
getChildrenByClass e c = js_getChilrenByClass e $ toJSString c

foreign import javascript unsafe "$1.getAttribute('id')"
    js_elId :: DomElement -> IO JSString
elId :: DomElement -> IO String
elId e = js_elId e >>= return . fromJSString

bldWidget :: IO PopupWidget
bldWidget = do
    pppWnd <- getElementById "popup"
    pppCls <- getElementById "ppp-close"
    tabs   <- pppWnd `getChildrenByClass` "content" >>= fromArray
    pppTbs <- gatherTabs tabs
    return $ PopupWidget pppWnd pppCls pppTbs
    where gatherTabs :: [DomElement] -> IO [PopupTab]
          gatherTabs tbs
                     | null tbs = return [] 
                     | otherwise = mapM (\t -> elId t >>= bldTab . (drop 8)) tbs
                                                                 -- ^ cut "content-" from id
          bldTab eId = do
              exT <- getEl' "ppp-show-" eId
              inT <- getEl' "item-"     eId
              cnt <- getEl' "content-"  eId
              return $ PopupTab exT inT cnt
          getEl' prefix idStr = getElementById $ prefix ++ idStr

One thing I should mention about is that we are ignoring possible failures when searching elements on page, assuming that all target elements are presented on page for sure (for sake of simplicity of example).

Javascript Events Handling

So, now we have two tasks remaining: to bind actual clicks with reactive logic and render changes. There are few techniques to handle javascript events. Each technique requires to import foreign javascript function, which actually can bind some handler function to event occurrences, the difference is in what to use as a handler and how to use it. Let's take a quick look at each of them.

First possibility: using GHCJS' javascript callback primitives. The idea is to send to javascript as a handler Haskell function of type JSFun a, which is Haskell IO code wrapped by JSFun. We can create such functions using following GHCJS primitives:

asyncCallback
asyncCallback1
asyncCallback2
syncCallback
syncCallback1
syncCallback2

These functions names are pretty self explaining, functions without a tailing number in name are functions that take no arguments; tailing 1 means that functions take one argument and 2 means functions that take 2 arguments. Sync callbacks takes two boolean arguments and Haskell function which should return a value of type IO a, and async callbacks takes one boolean argument and Haskell function. For now I can't explain what these boolean arguments mean.

Here is an example:

foreign import javascript unsafe "$1.addEventListener($2, $3);"
    js_JSFunListener :: DomElement -> JSString -> (JSFun (IO ())) -> IO ()
jsFunListener :: DomElement -> String -> (JSFun (IO ())) -> IO ()
jsFunListener el et cb = do
    js_JSFunListener el (toJSString et) cb
-- ...
-- pushClose is a function which pushes values to stream of close button click events.
callback <- asyncCallback False (sync $ pushClose ())
         -- syncCallback True False (sync $ pushClose())
jsFunListener (closeB w) "click" callback

The second opportunity is to use GHCJS shim, which provides us javascript function h$makeMVarListener(). This functions takes 4 arguments, first is a reference to MVar, last three are to configure event's propagation, event's immediate propagation and event's default behavior (you can look at its source code yourself). This technique is used in GHCJS-JQuery.

In this case instead of passing Haskell code directly to javascript, we creating an MVar first, which will hold javascript events. h$makeMVarListener produces function, which are bound as a handler to event occurrences. When event will happen javascript will write new event value to MVar. All we need is to monitor that MVar and read values when they arrives. This could be done using forkIO. Here is an example:

foreign import javascript unsafe "$1.addEventListener($2, h$makeMVarListener($3, false, false, false));"
    js_MVarListener :: DomElement -> JSString -> JSObject (MVar JSEvent) -> IO ()
mvarListener :: DomElement
             -> String
             -> (JSEvent -> IO())
             -> IO ()
mvarListener el et hnd = do
    mv <- newEmptyMVar :: IO (MVar JSEvent)
    forkIO (forever $ takeMVar mv >>= hnd)
    js_MVarListener el (toJSString et) (mvarRef mv)
-- ...
mvarListener (closeB w) "click" (\_ -> sync $ pushClose ())

And the last opportunity is combination of previous techniques:

create an MVar or Chan holder for event values,
create a Haskell function which will write values in holder,
bind this function as javascript event handler,
fork a new thread to read new values.

Here is an example with Chan:

foreign import javascript unsafe "$1.addEventListener($2, $3);"
    js_JSFunListener1 :: DomElement -> JSString -> (JSFun (JSEvent -> IO ())) -> IO ()

chanListener :: DomElement -> String -> (JSEvent -> IO ()) -> IO ()
chanListener el et cb = do
    ch <- newChan :: IO (Chan JSEvent)
    forkIO (forever $ readChan ch >>= cb)
    callback <- syncCallback1 False True (\e -> writeChan ch e)
    js_JSFunListener1 el (toJSString et) callback

-- ...
chanListener (closeB w) "click" (\_ -> sync $ pushClose ())

In our final code we'll use the second technique.

Rendering Changes

So, we have a reactive behavior of type Behavior (Maybe PopupTab) which we will listen for values. Remember that Just values represent opened tab and Nothing value represents closed popup window. When tab is selected both its triggers should be marked. We'll mark them by class .hold. We should make popup window and corresponding div block to be visible. We'll control visibility by changing display property. Thus, if value is Nothing we should remove all marks from triggers and make popup hidden, in all other cases we should make popup visible, mark corresponding triggers, and make proper content to be visible.

Here is the code:

foreign import javascript unsafe "$1 == $2"
    js_eq_elements :: DomElement -> DomElement -> IO Bool

foreign import javascript unsafe "$1.classList.add($2);"
    js_classListAdd :: DomElement -> JSString -> IO ()
addClass :: DomElement -> String -> IO ()
addClass el cl = js_classListAdd el $ toJSString cl

foreign import javascript unsafe "$1.classList.remove($2);"
    js_classListRemove :: DomElement -> JSString -> IO ()
removeClass :: DomElement -> String -> IO ()
removeClass el cl = js_classListRemove el $ toJSString cl

render :: PopupWidget -> Maybe PopupTab -> IO ()
render w Nothing  = (popupClose w) >> (releaseTabs w)
render w (Just t) = (popupOpen w) >> (renderTabs w t)

popupClose :: PopupWidget -> IO ()
popupClose w = window w `addClass` "Dn"

popupOpen  :: PopupWidget -> IO ()
popupOpen  w = window w `removeClass` "Dn"

releaseTabs :: PopupWidget -> IO ()
releaseTabs w = mapM_ (\t -> do
                          (exTrigger t) `removeClass` "hold"
                          (inTrigger t) `removeClass` "hold"
                          ) (tabs w)

renderTabs :: PopupWidget -> PopupTab -> IO ()
renderTabs w t = mapM_ (\t' -> do 
                            eq <- js_eq_elements (content t') (content t)
                            elId (content t') >>= putStrLn
                            print eq
                            elId (content t)  >>= putStrLn
                            if eq
                               then do
                                 (content t') `removeClass` "Dn"
                                 (exTrigger t') `addClass`  "hold"
                                 (inTrigger t') `addClass`  "hold"
                               else do
                                 (content t') `addClass`      "Dn"
                                 (exTrigger t') `removeClass` "hold"
                                 (inTrigger t') `removeClass` "hold"
                               ) (tabs w)

Great! Looks like have all pieces of puzzle now!

Full Code

Here is the final Haskell code:

{-# LANGUAGE JavaScriptFFI #-}

module Main where

import Control.Applicative( pure )
import Control.Concurrent( forkIO )
import Control.Concurrent.Chan
import Control.Concurrent.MVar
import Control.Monad( foldM, forever, liftM, mapM, replicateM, when )

import GHCJS.Foreign
import GHCJS.Types
import FRP.Sodium

data DomElement_ = DomElement_
type DomElement  = JSRef DomElement_

data JSEvent_ = JSEvent_
type JSEvent  = JSRef JSEvent_

data PopupTab    = PopupTab { exTrigger :: DomElement
                            , inTrigger :: DomElement
                            , content   :: DomElement
                            }

data PopupWidget = PopupWidget { window :: DomElement
                               , closeB :: DomElement
                               , tabs   :: [PopupTab]
                               }

-- | Assert presence of ui elements.
asserted :: IO Bool
asserted = return True

foreign import javascript unsafe "document.getElementById($1)"
    js_getElementById :: JSString -> IO DomElement
getElementById :: String -> IO DomElement
getElementById = js_getElementById . toJSString

foreign import javascript unsafe "$1.getElementsByClassName($2)"
    js_getChilrenByClass :: DomElement -> JSString -> IO (JSArray DomElement_)
getChildrenByClass :: DomElement -> String -> IO (JSArray DomElement_)
getChildrenByClass e c = js_getChilrenByClass e $ toJSString c

foreign import javascript unsafe "$1.getAttribute('id')"
    js_elId :: DomElement -> IO JSString
elId :: DomElement -> IO String
elId e = js_elId e >>= return . fromJSString

foreign import javascript unsafe "$1 == $2"
    js_eq_elements :: DomElement -> DomElement -> IO Bool

foreign import javascript unsafe "$1.classList.add($2);"
    js_classListAdd :: DomElement -> JSString -> IO ()
addClass :: DomElement -> String -> IO ()
addClass el cl = js_classListAdd el $ toJSString cl

foreign import javascript unsafe "$1.classList.remove($2);"
    js_classListRemove :: DomElement -> JSString -> IO ()
removeClass :: DomElement -> String -> IO ()
removeClass el cl = js_classListRemove el $ toJSString cl

foreign import javascript unsafe "$1.addEventListener($2, h$makeMVarListener($3, false, false, false));"
    js_addEventListener :: DomElement -> JSString -> JSObject (MVar JSEvent) -> IO ()

eventListener :: DomElement
              -> String
              -> (JSEvent -> IO())
              -> IO ()
eventListener el et hnd = do
    mv <- newEmptyMVar :: IO (MVar JSEvent)
    forkIO (forever $ takeMVar mv >>= hnd)
    js_addEventListener el (toJSString et) (mvarRef mv)

foreign import javascript unsafe "$1.style.border = '1px solid green';"
    mark :: DomElement -> IO ()

bldWidget :: IO PopupWidget
bldWidget = do
    pppWnd <- getElementById "popup"
    pppCls <- getElementById "ppp-close"
    tabs   <- pppWnd `getChildrenByClass` "content" >>= fromArray
    pppTbs <- gatherTabs tabs
    return $ PopupWidget pppWnd pppCls pppTbs
    where gatherTabs :: [DomElement] -> IO [PopupTab]
          gatherTabs tbs
                     | null tbs = return []
                     | otherwise = mapM (\t -> elId t >>= bldTab . (drop 8)) tbs
          bldTab eId = do
              exT <- getEl' "ppp-show-" eId
              inT <- getEl' "item-"     eId
              cnt <- getEl' "content-"  eId
              return $ PopupTab exT inT cnt
          getEl' prefix idStr = getElementById $ prefix ++ idStr

mkEvents :: Int -> IO [(Event a, a -> Reactive ())]
mkEvents n = sync $ replicateM n newEvent

mkReactiveUi :: PopupWidget
               -> [(Event a, a -> Reactive ())]
               -> Reactive (Behavior (Maybe PopupTab))
mkReactiveUi pppw es = do
    let closeBhv = pure (Nothing :: Maybe PopupTab)
    items' <- mapM (\t -> newBehavior (Just t) >>= return . fst) $ tabs pppw
    let items = closeBhv:items'
    events <- mapM (return . fst) es
    let eItems = zipWith (\i e -> fmap (const i) e) items events
    sel    <- hold closeBhv $ mergeFold eItems
    switch sel
  where mergeFold :: [Event a] -> Event a
        mergeFold (e:es) = foldl merge e es

render :: PopupWidget -> Maybe PopupTab -> IO ()
render w Nothing  = (popupClose w) >> (releaseTabs w)
render w (Just t) = (popupOpen w) >> (renderTabs w t)

popupClose :: PopupWidget -> IO ()
popupClose w = window w `addClass` "Dn"

popupOpen  :: PopupWidget -> IO ()
popupOpen  w = window w `removeClass` "Dn"

releaseTabs :: PopupWidget -> IO ()
releaseTabs w = mapM_ (\t -> do
                          (exTrigger t) `removeClass` "hold"
                          (inTrigger t) `removeClass` "hold"
                          ) (tabs w)

renderTabs :: PopupWidget -> PopupTab -> IO ()
renderTabs w t = mapM_ (\t' -> do 
                            eq <- js_eq_elements (content t') (content t)
                            elId (content t') >>= putStrLn
                            print eq
                            elId (content t)  >>= putStrLn
                            if eq
                               then do
                                 (content t') `removeClass` "Dn"
                                 (exTrigger t') `addClass`  "hold"
                                 (inTrigger t') `addClass`  "hold"
                               else do
                                 (content t') `addClass`      "Dn"
                                 (exTrigger t') `removeClass` "hold"
                                 (inTrigger t') `removeClass` "hold"
                               ) (tabs w)

initUi :: IO ()
initUi = do
    w    <- bldWidget
    es   <- mkEvents $ length (tabs w) + 1
    rui  <- sync $ mkReactiveUi w es
    kill <- sync $ listen (value rui) (render w)

    mapM_ (\(t,(_,f)) -> do
              eventListener (exTrigger t) "click" (\_ -> sync $ f ())
              eventListener (inTrigger t) "click" (\_ -> sync $ f ())
              ) $ zip (tabs w) (tail es)

    let pushClose = snd (head es)
    eventListener (closeB w) "click" (\_ -> sync $ pushClose ())

    putStrLn "Initialized!"

main :: IO ()
main = asserted >>= flip when initUi

Markup:

<!DOCTYPE html>
<html lang="en">
  <head>
    <title> GHCJS | Sodium Reactive UI </title>
    <meta charset="utf-8">
    <script type="text/javascript" language="javascript" src="lib.js"></script>
    <script type="text/javascript" language="javascript" src="rts.js"></script>
    <script type="text/javascript" language="javascript" src="lib1.js"></script>
    <script type="text/javascript" language="javascript" src="out.js"></script>
    <link rel="stylesheet" type="text/css" href="style.css">
  </head>

  <body lang="ru">

    <div id="page" class="Pos">
         <h1>Header</h1>
         <p>Please select entity</p>
         <div id="ppp-select">
              <p id="ppp-show-about" class="trigger">About Us</p>
              <p id="ppp-show-contacts" class="trigger">Contact Us</p>
              <p id="ppp-show-service" class="trigger">Centers of Service</p>
              <p id="ppp-show-book-measure" class="trigger">Book measure</p>
         </div>
         <div>
           Lorem ipsum dolor sit amet, consectetur adipiscing elit. Cras sed eros nisi. Pellentesque mi lectus, molestie viverra suscipit vel, ullamcorper pretium leo. Quisque et lorem arcu. Mauris auctor porttitor adipiscing. Quisque pretium ante ac magna porttitor ornare eget eu dui. Vestibulum vel commodo nunc. Phasellus eu eros tellus. Fusce sed nibh et neque venenatis euismod ut ac leo. Morbi mi velit, tempor et consequat eu, consequat ullamcorper urna. Proin eu elementum mi, non accumsan neque. Nunc sit amet ullamcorper odio, quis sagittis nibh. Ut at facilisis tellus.
         </div>

    </div>

    <div id="popup" class="Dn Pos-A Plate">
         <div id="ppp-close" class="trigger">Close</div>

         <div id="ppp-nav">
              <div id="item-about" class="trigger">About Us</div>
              <div id="item-contacts" class="trigger">Contacts</div>
              <div id="item-service" class="trigger">Centers of Service</div>
              <div id="item-book-measure" class="trigger">Book Measure</div>
         </div>

         <div id="ppp-content">
              <div id="content-about" class="content">Lorem ipsum dolor sit amet.</div>
              <div id="content-contacts" class="content">
                   Tel: +1-234-567-890
                   </br>
           Address: Ap.01, Reactive Street, UI Town, Sodium.
              </div>
              <div id="content-service" class="content">Aliquam tortor dolor, sodales sed suscipit eget, porta non nulla.</div>
              <div id="content-book-measure" class="content">Donec sodales tortor quis ante mattis, at aliquet magna pretium.</div>
         </div>
    </div>

  </body>
  <script type="text/javascript" language="javascript">

h$main(h$mainZCMainzimain);

  </script>
</html>

Styles:

.Dn { display: none; }

.Pos   { position: relative; }
.Pos-A { position: absolute; }

.Plate {
  background-color: white;
  border: 1px solid #aaa;
}

.trigger {
  display: inline-block;
  text-decoration: underline;
  color: #555;
  padding: 5px;
}
.trigger:hover {
  cursor: pointer;
  background-color: #CCC2B2;
  color: #000;
}
.trigger.hold {
  background-color: #B2ACA1;
  text-decoration: none;
  color: #333;
}

#page {
  width: 700px;
  margin: 0 auto;
}

#popup {
  left: 50px; right: 50px;
  top: 170px; bottom: 50px;
  padding: 10px;
}

  #popup .trigger  { font-size: 80%; }
  #ppp-content     { margin: 25px; }
  #ppp-close       { color: #E36B49; }
  #ppp-close:hover { 
    color: #964730;
    background-color: transparent;
  }

BODY {
  background-color: #F5FCF8;
  font-family: sans-serif;
}

geraldus commented 10 years ago

let eChan1 = map (const channel1) eButton1

Is it correct? Looks like map should take two events and return another event, but (const channel1) is Behavior, right?

Can you explain, what means mapping Event over Event?

the-real-blackh commented 10 years ago

I don't quite understand what you want to do. Do you want to make an event that captures the value of a behaviour when the button click happens? If so, use snapshot. Otherwise, explain a bit more what you want and I'll tell you how to do it.

geraldus commented 10 years ago

There are opening "triggers" and one closing "trigger". The idea is to have one Behavior, which holds value of last clicked trigger, if it was closing button the value should be Nothing, otherwise the value is Just PopupTab. Thus, having such behavior we can listen for its values, and when new value occurs we can decide what to do: open specific tab or hide modal window. Is it understandable?

P.S. In the example above I don't have listen for actual click events yet. The idea was to create inside IO event streams for each trigger (mkEvents), then produce final behavior (makeReactiveUi) and then bind reactive events to actual clicks.

the-real-blackh commented 10 years ago

Oh, I see. 'map' is for lists only. You want fmap.

let eChan1 = fmap (const (Just channel1)) eButton1
let eChan2 = fmap (const Nothing) eButton2
b <- hold Nothing (eChan1 <> eChan2)

Note that <> is shorthand for merge. It is imported from Data.Monoid.

geraldus commented 10 years ago

Stephen, can you please explain what means to map a behavior over event? I want to catch the meaning. Oh, guess I understood. Let me check...

geraldus commented 10 years ago

let eChan1 = map (const channel1) eButton1
let eChan2 = map (const channel2) eButton2
let sel = hold fuzz (merge eChan1 eChan2)
let screen = switch sel

In this case sel should have the type Reactive (Behavior Image), but switch needs Behavior (Behavior a)). Right?

UPDATE: Finally, I've solved type errors, and it compiles now. The next step is to bind reactive logic with actual event occurrences. When I'll finish everything I'll post my results with explanations and comments.

the-real-blackh commented 10 years ago

'map' should be 'fmap' and the third line should be

sel <- hold fuzz (merge eChan1 eChan2)

I don't know what it means to map a behaviour over an event. Are you talking about mapping a function over an event? That is what fmap does.

geraldus commented 10 years ago

Yes, I've already guess that there should be fmap, then I understood that const channel is not a Behavior, but function which returns a Behavior. I've also used <- instead of let = with sel. Thank you anyway. Now I have a little issue about how to bind actual events without JQuery and how to call some IO actions when events occur, but I assume the one of possible solutions it to use MVars (like JQuery does), so I studying this theory now.

the-real-blackh commented 10 years ago

MVars and forkIO are a good way to do things. In GHC and GHCJS they are very light-weight, so you should use them whenever you need them.

geraldus commented 10 years ago

The problem is the same, I have not use them yet, so I need some time to understand what is it and how all it works. :) I only have read "Learn You a Haskell For a Great Good". Thus I still can do very limited things, but I hope soon things will become more familiar for me.

UPDATE: Cool! I've understood how MVars works, what forkIO is for and how event listening implemented in ghcjs-jquery. Heh, it took me a while. Now I have full code which compiles, but without rendering yet! Now I testing it, and I see within inspector event listeners on DOM elements but after clicks happens nothing, I'll find out an issue and post the first unrefactored working version with explanations.

geraldus commented 10 years ago

Sthephen, I need your help. I've done some tests which shown that code works. But there is one issue, let me show. Please have a look at code:

-- ...
eventListener :: DomElement
              -> String
              -> (JSEvent -> IO())
              -> IO ()
eventListener el et hnd = do
   mv <- newEmptyMVar :: IO (MVar JSEvent)
   forkIO (forever $ takeMVar mv >>= hnd)
   js_addEventListener el (toJSString et) (mvarRef mv)

mkEvents :: Int -> IO [(Event a, a -> Reactive ())]
mkEvents n = liftM (replicate n) $ sync newEvent

initUi :: IO ()
initUi = do
    w       <- bldWidget
    es      <- mkEvents $ length $ tabs w
    rui     <- sync $ mkReactiveUi w es
    let actions = map (\epr -> (\_ -> sync $ (snd epr) ())) es
    mapM_ (\(a,t) -> do
                 eventListener (exTrigger t) "click" a
                 eventListener (inTrigger t) "click" a
                 ) $ zip actions $ tabs w
    kill <- sync $ listen (values rui) test
-- ...

First I make a list of pairs of events and their pushing functions. Then I create reactive logic. Finally, I make a list of functions which should be called when real click events occurs, namely actions. The type of each action is (JSEvent -> IO ()), the idea is when event occurs I push unit value () to concrete event stream. But this is not working. I tried to replace action function with simple putStrLn actions and it works, when I click trigger I have a message in console. Thus reactive logic works. E.g.

let actions = map (\epr -> (\_ -> putStrLn "Yeeep!")) es

If I call some action inside main function, the logic works too and test function calls. One thing I can guess that sync $ pushE () does not have effect, because it runs inside forked thread. What can you say about this?

the-real-blackh commented 10 years ago

I have read the code but I can't see a specific problem. Can you tell me what mvarRef and test do?

The most likely thing is that there is a deadlock, because there is a mutex (implemented using MVar) around Sodium execution. The only rule is that you can't use 'sync' inside a 'listen' handler. However, if the listener handler blocks, that wouldn't work either.

Here are some suggestions: Try using a Chan instead of an MVar. An MVar can block on write but a Chan can't.

Or, instead of (mvarRef mv) - which I assume means (putMVar mv), use (\ev -> forkIO $ hnd ev).

geraldus commented 10 years ago

mvarRef takes MVar JSEvent and returns JSObject (MVar JSEvent). It's just unsafeCoerce behind the scenes. I think this is needed to have ability pass MVar itself to javascript code. Test now just prints "Nothing" or "Click" depending on arrived value (of type Maybe PopupTab), in final example it will be replaced with rendering function.

UPDATE I've tested my code with JQuery event listeners and discovered that it is not work also. I used this handler:

c <- select "#ppp-close"
click (\_ -> putStrLn "!" >> S.sync ((snd (head es)) ()) ) def c

When I click on "close button" "!" appears in console, but reactive logic misses sync action. So, now I know that's not my flaw. Let me study about Chan.

geraldus commented 10 years ago

Stephen, can you help with Chans? When I used MVars I used built-in shim h$makeMVarListener to create javascript code which writes values to MVar of new occurred events. And I used another thread created with forkIO to read that values from MVar. Now I can't guess how write values of events to channel from Javascript. Moreover if my assumption about that sync action will have no effect inside another thread means that I will have to implement some logic (e.g. forever loop) which checks each channel for presence of new values. In other words I need some kind of example how to use Chan and populate it with values from JS.

the-real-blackh commented 10 years ago

In Haskell you would replace putMVar with writeChan. Can you show me the code where you write into the MVar?

the-real-blackh commented 10 years ago

I'll tell you what would be a really easy way to do it: forkIO a new thread that reads from your MVar and writes into your Chan. That thread can't block, so the MVar then can't block on write.

geraldus commented 10 years ago

Here it is:

foreign import javascript unsafe "$1.addEventListener($2, h$makeMVarListener($3, false, false, false));"
    js_addEventListener :: DomElement -> JSString -> JSObject (MVar JSEvent) -> IO ()

eventListener :: DomElement
              -> String
              -> (JSEvent -> IO())
              -> IO ()
eventListener el et hnd = do
   -- Create empty MVar
   mv <- newEmptyMVar :: IO (MVar JSEvent)
   -- Loop in separate thread that reads new values and passes them to handler function
   forkIO (forever $ takeMVar mv >>= hnd)
   -- Create javascript code, which will write new values to MVar when even occurs.
   js_addEventListener el (toJSString et) (mvarRef mv)

initUi :: IO ()
initUi = do
    w    <- bldWidget
    es   <- mkEvents $ length (tabs w) + 1
    rui  <- sync $ mkReactiveUi w es
    kill <- sync $ listen (values rui) render
    let pushClose = snd (head es)
    callback <- asyncCallback False ((putStrLn "X") >> (sync $ pushClose ()))
    putStrLn "Initialized!"
    kill

Few hours ago happened something strange and I've log big piece of code. Writing value to MVar is done by using shim h$makeMVarListener, I use it in js_addEventListener. The code I've presented prints to console "X", but render function does not evaluated, I assume there is no lock, because each event is handled, only sync operation have no effect.

The first thing that I've tried was to fork a new thread which reads MVar and writes its value to Chan, but have no luck. The one thing I've did not tested yet is not to fork new thread, but create forever loop, which reads values from MVar/Chan.

P.S. There are no listeners for clicks on all triggers (because of this code lost due bug) in last code example now, but here I've tested built-in way to create callbacks and passing this callbacks directly to Javascript. Here is the missing piece with testListener:

foreign import javascript unsafe "$1.addEventListener($2, $3);"
    js_testListener :: DomElement -> JSString -> (JSFun (IO ())) -> IO ()

testListener :: DomElement -> String -> (JSFun (IO ())) -> IO ()
testListener el et cb = do
    js_testListener el (toJSString et) cb

Earlier clicks were listened this way:

let actions = map (\epr -> (\_ -> sync $ (snd epr) ())) es
mapM_ (\(a,t) -> do
                 eventListener (exTrigger t) "click" a
                 eventListener (inTrigger t) "click" a
                 ) $ zip actions $ tabs w
kill <- sync $ listen (values rui) test

In all cases events are handled, the only problem is that sync $ pushE () have no effect.

geraldus commented 10 years ago

I have no idea what's wrong.

eventListener' :: DomElement -> String -> IO (MVar JSEvent)
eventListener' de et = do
    mv <- newEmptyMVar :: IO (MVar JSEvent)
    js_addEventListener de (toJSString et) (mvarRef mv)
    return mv

initUI :: IO ()
initUI = do
    -- ...
    mv <- eventListener' (closeB w) "click"
    putStrLn "Initialized!"
    kill
    forever $ tryTakeMVar mv >>= run (\_ -> putStrLn "X" >> (sync $ pushClose ()))
  where run :: (JSEvent -> IO ()) -> Maybe JSEvent -> IO ()
        run _ Nothing  = return ()
        run h (Just e) = h e

This code gives the same result, it successfully prints "X" to console, but reactive sync action have no effect, even though it executes inside main thread within forever loop.

I also tried to use Chans:

foreign import javascript unsafe "$1.addEventListener($2, $3);"
    js_testListener1 :: DomElement -> JSString -> (JSFun (JSEvent -> IO ())) -> IO ()

chanListener :: DomElement -> String -> (JSEvent -> IO ()) -> IO ()
chanListener el et cb = do
    ch <- newChan :: IO (Chan JSEvent)
    forkIO (forever $ readChan ch >>= cb)
    callback <- syncCallback1 False True (\e -> writeChan ch e)
    js_testListener1 el (toJSString et) callback

Javascript writes new value to Chan itself. Event listener created inside initUi this way chanListener (closeB w) "click" (\_ -> putStrLn "X" >> (sync $ pushClose ())). This gives the same results. So, where is the trouble lies?

geraldus commented 10 years ago

Kawaboonga! I found out the reason! When I removed kill function within initUi everything works now! Look:

initUi :: IO ()
initUi = do
    w    <- bldWidget
    es   <- mkEvents $ length (tabs w) + 1
    rui  <- sync $ mkReactiveUi w es
    kill <- sync $ listen (values rui) render

    let pushClose = snd (head es)
    mv <- eventListener' (closeB w) "click"
    putStrLn "Initialized!"
    -- | If uncomment next line reactive logic stops to work!
    -- kill
    forever $ tryTakeMVar mv >>= run (\_ -> putStrLn "X" >> (sync $ pushClose ()))
  where run :: (JSEvent -> IO ()) -> Maybe JSEvent -> IO ()
        run _ Nothing  = return ()
        run h (Just e) = h e

Stephen, can you explain why this happens? I wrote kill there to be sure that it will not be garbage collected. Meanwhile I'll finish my example.

the-real-blackh commented 10 years ago

I am actually not entirely sure whether 'kill' is needed or not. If it is called, it will cancel the listener, so if your program loops forever, what you are trying to do is to keep the 'kill' alive, but not run it.

I think I may have been completely wrong about this. When I find some time, I will look at this more and tidy it up. In the meantime, if it works without kill, then I think you are good.

geraldus commented 10 years ago

Cool! I've just tested all techniques of click handling and all of them (MVar, Chan and JSFun) works now!

the-real-blackh commented 10 years ago

Sorry I didn't help much. I have been really busy today. Will be away from keyboard over the weekend.

geraldus commented 10 years ago

While you're here I'll ask one little question.

Looks like my idea about merging events via foldl don't work:

mkReactiveUi pppw es = do
    let closeBhv = pure (Nothing :: Maybe PopupTab)
    items' <- mapM (\t -> newBehavior (Just t) >>= return . fst) $ tabs pppw
    let items = closeBhv:items'
    events <- mapM (return . fst) es
    let eItems = zipWith (\i e -> fmap (const i) e) items events
    sel    <- hold closeBhv $ mergeFold eItems
    screen <- switch sel
    return screen
  where mergeFold :: [Event a] -> Event a
        mergeFold (e:[]) = e
        mergeFold (e:es) = foldl merge e es

es is events of type Event (Behavior Maybe PopupTab) each for concrete tab and one for close button. I believed that if I merge them into one event using foldl then click on any trigger will produce an event, containing specific Behavior. But in real world no matter what trigger was clicked, it always return the same value.

Have a nice weekend!

the-real-blackh commented 10 years ago

"foldl1' merge es" is shorter (import from Data.List)

That looks OK to me and should work. If it's really broken, turn it into a test case and I'll fix it.

geraldus commented 10 years ago

I've finally updated my first post, it took me a week to write first edition of tutorial. Please have a look.

the-real-blackh commented 10 years ago

That's great! I've put a link to it on my blog: http://blog.reactiveprogramming.org/?p=151

luite commented 10 years ago

very cool, I'll read it tonight and see if I have suggestions.

There are going to be some new options for JS event handling soon, that make it easier to write code that does not leak memory when removing DOM nodes while still behaving as expected with weak references (which Sodium uses to clean up its FRP graph)

(With an mvarListener like ghcjs-jquery you get a listener thread that's never deallocated (unless you throwTo an async exception to it, but the current version doesn't give you the ThreadId required for that. This is far from ideal, so I'll probably change this in ghcjs-jquery before uploading the first version to hackage).

geraldus commented 10 years ago

@luite, hi! To compare two DOM elements I've used foreign javascript code in my tutorial:

foreign import javascript unsafe "$1 == $2"
    js_eq_elements :: DomElement -> DomElement -> IO Bool

I've tried to derive Eq instance for my DomElement type, but faced compilation errors. I was unable to solve this issue myself. Is there a way to have possibility to compare custom data types directly in Haskell? I've also going to place working demo of this code somewhere.

luite commented 10 years ago

Can't you use the eqRef function in GHCJS.Types ? Since you're comparing references the comparison should be pure.

I have updated the ghcjs-base code a bit to make it clearer how callbacks are retained by foreign code (beware that DOM retention doesn't actually work yet), but it does change the types.

Also there are some other GHCJS updates to fix some sodium related bugs, and the pull req I sent to the sodium repository removes the reliance of sodium on unpredictable behaviour of finalizers on regular Haskell objects (GHCJS behaves a bit different most of the time, but according to the specs is still correct)

rvl commented 10 years ago

Thanks for the tutorial geraldus. I actually couldn't get this code working with current ghcjs. So I changed it to use ghcjs-jquery which also simplifies things...

module Main where

import Control.Applicative( pure )
import Control.Concurrent( forkIO )
import Control.Concurrent.Chan
import Control.Concurrent.MVar
import Control.Monad( foldM, forever, liftM, mapM, replicateM, when, void, join )
import Data.Default
import qualified Data.Text as T

import GHCJS.Foreign
import GHCJS.Types
import FRP.Sodium

import JavaScript.JQuery hiding (Event)
import qualified JavaScript.JQuery as JQ

data PopupTab    = PopupTab { exTrigger :: JQuery
                            , inTrigger :: JQuery
                            , content   :: JQuery
                            }

data PopupWidget = PopupWidget { window :: JQuery
                               , closeB :: JQuery
                               , tabs   :: [PopupTab]
                               }

-- | Assert presence of ui elements.
asserted :: IO Bool
asserted = return True

foreign import javascript unsafe "$1.length" jq_length :: JQuery -> IO Int

elems :: JQuery -> IO [JQuery]
elems a = do
  len <- jq_length a
  mapM (flip eq a) [0..len - 1]

bldWidget :: IO PopupWidget
bldWidget = do
    pppWnd <- select "#popup"
    pppCls <- select "#ppp-close"
    tabs   <- find ".content" pppWnd >>= elems
    pppTbs <- gatherTabs tabs
    return $ PopupWidget pppWnd pppCls pppTbs
    where gatherTabs :: [JQuery] -> IO [PopupTab]
          gatherTabs = mapM (\t -> getAttr "id" t >>= bldTab . (T.drop 8))
          bldTab eId = do
              exT <- select (T.append "#ppp-show-" eId)
              inT <- select (T.append "#item-"     eId)
              cnt <- select (T.append "#content-"  eId)
              return $ PopupTab exT inT cnt

mkEvents :: Int -> IO [(Event a, a -> Reactive ())]
mkEvents n = sync $ replicateM n newEvent

mkReactiveUi :: PopupWidget
               -> [(Event a, a -> Reactive ())]
               -> Reactive (Behavior (Maybe PopupTab))
mkReactiveUi pppw es = do
    let closeBhv = pure (Nothing :: Maybe PopupTab)
    items' <- mapM (\t -> newBehavior (Just t) >>= return . fst) $ tabs pppw
    let items = closeBhv:items'
    events <- mapM (return . fst) es
    let eItems = zipWith (\i e -> fmap (const i) e) items events
    sel    <- hold closeBhv $ mergeFold eItems
    switch sel
  where mergeFold :: [Event a] -> Event a
        mergeFold (e:es) = foldl merge e es

render :: PopupWidget -> Maybe PopupTab -> IO ()
render w Nothing  = (popupClose w) >> (releaseTabs w)
render w (Just t) = (popupOpen w) >> (renderTabs w t)

popupClose :: PopupWidget -> IO ()
popupClose w = void $ addClass "Dn" (window w)

popupOpen  :: PopupWidget -> IO ()
popupOpen  w = void $ removeClass "Dn" (window w)

releaseTabs :: PopupWidget -> IO ()
releaseTabs w = mapM_ (\t -> do
                          removeClass "hold" (exTrigger t)
                          removeClass "hold" (inTrigger t)
                          ) (tabs w)

renderTabs :: PopupWidget -> PopupTab -> IO ()
renderTabs w t = mapM_ (\t' -> do 
                            cid' <- getAttr "id" (content t')
                            cid <- getAttr "id" (content t)
                            if cid == cid'
                               then do
                                 removeClass "Dn" (content t')
                                 addClass "hold" (exTrigger t')
                                 addClass "hold" (inTrigger t')
                               else do
                                 addClass "Dn" (content t')
                                 removeClass "hold" (exTrigger t')
                                 removeClass "hold" (inTrigger t')
                               ) (tabs w)

initUi :: IO ()
initUi = do
    w    <- bldWidget
    es   <- mkEvents $ length (tabs w) + 1
    rui  <- sync $ mkReactiveUi w es
    kill <- sync $ listen (value rui) (render w)

    mapM_ (\(t,(_,f)) -> do
              click (const $ sync $ f ()) def (exTrigger t)
              click (const $ sync $ f ()) def (inTrigger t)
              ) $ zip (tabs w) (tail es)

    let pushClose = snd (head es)
    click (\_ -> sync $ pushClose ()) def (closeB w)

    putStrLn "Initialized!"

main :: IO ()
main = asserted >>= flip when initUi

geraldus commented 10 years ago

Thanks! Hope, this was helpful. Yes, there was some updates, I've planned to update example code, but haven't done it. I've used jQuery a lot in past. But then I started to use exciting Polymer project and faced an issue: using both jQuery and Polymer libraries was impossible because of Polymer assertion error. Because of it I weaned myself from jQuery :) I plan to introduce something similar to Polymer based on functional reactive approach with Sodium and GHCJS, but unfortunately my learning and coding temps are similar to snail's speed.

SodiumFRP / sodium

Tutorial. GHCJS and Sodium #8

Authors preface

Overview

Data Types

Reactive Logic

Finding DOM Elements

Javascript Events Handling

Rendering Changes

Full Code