The getElementBy… methods now correctly return an Element with as…

…sociated events.

samples/GetElementsBy.hs

@@ -1,7 +1,5 @@
-import Control.Applicative
 import Control.Monad
 import Data.IORef
-import Data.Maybe
 
 import qualified Graphics.UI.Threepenny as UI
 import Graphics.UI.Threepenny.Core
@@ -14,9 +12,9 @@ setup :: Window -> UI ()
 setup w = do
     return w # set title "Element Test"
 
-    button1 <- UI.button # set UI.text "tag"
-    button2 <- UI.button # set UI.text "class"
-    button3 <- UI.button # set UI.text "id"    # set UI.id_ "me"
+    button1 <- UI.button # set UI.text "by tag"
+    button2 <- UI.button # set UI.text "by class"
+    button3 <- UI.button # set UI.text "by id"    # set UI.id_ "me"
 
     let mkString s = UI.string s # set UI.class_ "string"
 
@@ -32,7 +30,11 @@ setup w = do
         xs <- getElementsByClassName w "string"
         forM_ xs $ \x -> element x # set text "class"
 
+    Just button3 <- getElementById w "me"
+    ref <- liftIO $ newIORef True
     on UI.click button3 $ const $ void $ do
         Just x <- getElementById w "me"
-        element x # set UI.text "got me"
-
+        b <- liftIO $ readIORef ref
+        let s = if b then "yay" else "wow"
+        element x # set UI.text s
+        liftIO $ writeIORef ref (not b)

src/Graphics/UI/Threepenny/Core.hs

@@ -178,6 +178,8 @@ getElementsByTagName _ tag =
     mapM fromJSObject =<< callFunction (ffi "document.getElementsByTagName(%1)" tag)
 
 -- | Get an element by a particular ID.
+--
+-- FIXME: Misleading type, throws a JavaScript exception when element not found.
 getElementById
     :: Window              -- ^ Browser window
     -> String              -- ^ The ID string.

src/Graphics/UI/Threepenny/Internal.hs

@@ -42,6 +42,7 @@ import Foreign.JavaScript hiding (runFunction, callFunction, debug, Window)
 data Window = Window
     { jsWindow    :: JS.Window  -- JavaScript window
     , eDisconnect :: E.Event () -- event that happens when client disconnects
+    , wEvents     :: Foreign.Vendor Events -- events associated to 'Element's
     }
 
 -- | Start server for GUI sessions.
@@ -53,12 +54,18 @@ startGUI config init = JS.serve config $ \w -> do
     -- set up disconnect event
     (eDisconnect, handleDisconnect) <- E.newEvent
     JS.onDisconnect w $ handleDisconnect ()
-    let window = Window { jsWindow = w, eDisconnect = eDisconnect }
-
+
+    -- make window
+    wEvents <- Foreign.newVendor
+    let window = Window
+            { jsWindow    = w
+            , eDisconnect = eDisconnect
+            , wEvents     = wEvents
+            }
+
     -- run initialization
     runUI window $ init window
 
-
 -- | Event that occurs whenever the client has disconnected,
 -- be it by closing the browser window or by exception.
 --
@@ -73,25 +80,57 @@ disconnect = eDisconnect
 type Events = String -> E.Event [JSON.Value]
 
 data Element = Element
-    { eEvents    :: Events      -- FRP event mapping
-    , toJSObject :: JS.JSObject -- corresponding JavaScript object
-    , eWindow    :: Window      -- Window in which the element was created
+    { toJSObject  :: JS.JSObject -- corresponding JavaScript object
+    , elEvents    :: Events      -- FRP event mapping
+    , elWindow    :: Window      -- Window in which the element was created
     }
 
 instance ToJS Element where
     render = render . toJSObject
 
--- Convert JavaScript object into an element
--- FIXME: Add events
+getWindow :: Element -> IO Window
+getWindow = return . elWindow
+
+-- | Convert JavaScript object into an element.
+--
+-- FIXME: For the purpose of garbage collection, this element
+-- will always be reachable from the root.
 fromJSObject :: JS.JSObject -> UI Element
-fromJSObject e = do
-    w <- askWindow
-    liftIO $ Foreign.addReachable (JS.root $ jsWindow w) e
-    return $ Element (error "Not implemented!") e w
+fromJSObject el = do
+    window <- askWindow
+    liftIO $ do
+        Foreign.addReachable (JS.root $ jsWindow window) el
+        events <- getEvents el window
+        return $ Element el events window
+
+-- | Add lazy FRP events to a JavaScript object.
+addEvents :: JS.JSObject -> Window -> IO Events
+addEvents el Window{ jsWindow = w, wEvents = wEvents } = do
+    -- Lazily create FRP events whenever they are needed.
+    let initializeEvent (name,_,handler) = do
+            handlerPtr <- JS.exportHandler handler w
+            -- make handler reachable from element
+            Foreign.addReachable el handlerPtr
+            JS.runFunction w $
+                ffi "Haskell.bind(%1,%2,%3)" el name handlerPtr
 
-getWindow :: Element -> IO Window
-getWindow = return . eWindow
+    events <- E.newEventsNamed initializeEvent
+
+    -- Create new pointer and add reachability.
+    Foreign.withRemotePtr el $ \coupon _ -> do
+        ptr <- Foreign.newRemotePtr coupon events wEvents
+        Foreign.addReachable el ptr
+
+    return events
 
+-- | Lookup or create lazy events for an a JavaScript object.
+getEvents :: JS.JSObject -> Window -> IO Events
+getEvents el window@Window{ wEvents = wEvents } = do
+    Foreign.withRemotePtr el $ \coupon _ -> do
+        mptr <- Foreign.lookup coupon wEvents
+        case mptr of
+            Nothing -> addEvents el window
+            Just p  -> Foreign.withRemotePtr p $ \_ -> return
 
 type EventData = [String]
 
@@ -104,7 +143,7 @@ domEvent
         --   the name is @click@ and so on.
     -> Element          -- ^ Element where the event is to occur.
     -> E.Event EventData
-domEvent name el = fmap (fromSuccess . JSON.fromJSON . head) $ eEvents el name
+domEvent name el = fmap (fromSuccess . JSON.fromJSON . head) $ elEvents el name
     where
     fromSuccess (JSON.Success x) = x
 
@@ -119,22 +158,12 @@ mkElementNamespace :: Maybe String -> String -> UI Element
 mkElementNamespace namespace tag = do
     window <- askWindow
     let w = jsWindow window
-    el <- liftIO $ JS.callFunction w $ case namespace of
-        Nothing -> ffi "document.createElement(%1)" tag
-        Just ns -> ffi "document.createElementNS(%1,%2)" ns tag
-
-    -- Lazily create FRP events whenever they are needed.
-    let initializeEvent (name,_,handler) = do
-            handlerPtr <- JS.exportHandler handler w
-            -- make handler reachable from element
-            Foreign.addReachable el handlerPtr
-            JS.runFunction w $
-                ffi "Haskell.bind(%1,%2,%3)" el name handlerPtr
-
-    events <- liftIO $ E.newEventsNamed initializeEvent
-
-    -- FIXME: Add support for JavaScript functions that /return/ elements.
-    return $ Element events el window
+    liftIO $ do
+        el <- JS.callFunction w $ case namespace of
+            Nothing -> ffi "document.createElement(%1)" tag
+            Just ns -> ffi "document.createElementNS(%1,%2)" ns tag
+        events <- getEvents el window
+        return $ Element el events window
 
 -- | Delete the given element.
 delete :: Element -> UI ()
@@ -144,14 +173,14 @@ delete el = liftJSWindow $ \w -> do
 
 -- | Remove all child elements.
 clearChildren :: Element -> UI ()
-clearChildren (Element _ el _) = liftJSWindow $ \w -> do
+clearChildren (Element el _ _) = liftJSWindow $ \w -> do
     Foreign.withRemotePtr el $ \_ _ -> do
         Foreign.clearReachable el
         JS.runFunction w $ ffi "$(%1).contents().detach()" el
 
 -- | Append a child element.
 appendChild :: Element -> Element -> UI ()
-appendChild (Element _ eParent _) (Element _ eChild _) = liftJSWindow $ \w -> do
+appendChild (Element eParent _ _) (Element eChild _ _) = liftJSWindow $ \w -> do
     -- FIXME: We have to stop the child being reachable from its
     -- /previous/ parent.
     Foreign.addReachable eParent eChild